Merge branch 'emacs-24' of git.sv.gnu.org:/srv/git/emacs into emacs-24
[emacs.git] / src / charset.c
blob3566b156736939053160394e0e1e563717323980
1 /* Basic character set support.
3 Copyright (C) 2001-2014 Free Software Foundation, Inc.
5 Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
6 2005, 2006, 2007, 2008, 2009, 2010, 2011
7 National Institute of Advanced Industrial Science and Technology (AIST)
8 Registration Number H14PRO021
10 Copyright (C) 2003, 2004
11 National Institute of Advanced Industrial Science and Technology (AIST)
12 Registration Number H13PRO009
14 This file is part of GNU Emacs.
16 GNU Emacs is free software: you can redistribute it and/or modify
17 it under the terms of the GNU General Public License as published by
18 the Free Software Foundation, either version 3 of the License, or
19 (at your option) any later version.
21 GNU Emacs is distributed in the hope that it will be useful,
22 but WITHOUT ANY WARRANTY; without even the implied warranty of
23 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
24 GNU General Public License for more details.
26 You should have received a copy of the GNU General Public License
27 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
29 #include <config.h>
31 #include <errno.h>
32 #include <stdio.h>
33 #include <unistd.h>
34 #include <limits.h>
35 #include <sys/types.h>
36 #include <c-ctype.h>
37 #include "lisp.h"
38 #include "character.h"
39 #include "charset.h"
40 #include "coding.h"
41 #include "disptab.h"
42 #include "buffer.h"
44 /*** GENERAL NOTES on CODED CHARACTER SETS (CHARSETS) ***
46 A coded character set ("charset" hereafter) is a meaningful
47 collection (i.e. language, culture, functionality, etc.) of
48 characters. Emacs handles multiple charsets at once. In Emacs Lisp
49 code, a charset is represented by a symbol. In C code, a charset is
50 represented by its ID number or by a pointer to a struct charset.
52 The actual information about each charset is stored in two places.
53 Lispy information is stored in the hash table Vcharset_hash_table as
54 a vector (charset attributes). The other information is stored in
55 charset_table as a struct charset.
59 /* Hash table that contains attributes of each charset. Keys are
60 charset symbols, and values are vectors of charset attributes. */
61 Lisp_Object Vcharset_hash_table;
63 /* Table of struct charset. */
64 struct charset *charset_table;
66 static ptrdiff_t charset_table_size;
67 static int charset_table_used;
69 Lisp_Object Qcharsetp;
71 /* Special charset symbols. */
72 Lisp_Object Qascii;
73 static Lisp_Object Qeight_bit;
74 static Lisp_Object Qiso_8859_1;
75 static Lisp_Object Qunicode;
76 static Lisp_Object Qemacs;
78 /* The corresponding charsets. */
79 int charset_ascii;
80 int charset_eight_bit;
81 static int charset_iso_8859_1;
82 int charset_unicode;
83 static int charset_emacs;
85 /* The other special charsets. */
86 int charset_jisx0201_roman;
87 int charset_jisx0208_1978;
88 int charset_jisx0208;
89 int charset_ksc5601;
91 /* Value of charset attribute `charset-iso-plane'. */
92 static Lisp_Object Qgl, Qgr;
94 /* Charset of unibyte characters. */
95 int charset_unibyte;
97 /* List of charsets ordered by the priority. */
98 Lisp_Object Vcharset_ordered_list;
100 /* Sub-list of Vcharset_ordered_list that contains all non-preferred
101 charsets. */
102 Lisp_Object Vcharset_non_preferred_head;
104 /* Incremented everytime we change Vcharset_ordered_list. This is
105 unsigned short so that it fits in Lisp_Int and never matches
106 -1. */
107 unsigned short charset_ordered_list_tick;
109 /* List of iso-2022 charsets. */
110 Lisp_Object Viso_2022_charset_list;
112 /* List of emacs-mule charsets. */
113 Lisp_Object Vemacs_mule_charset_list;
115 int emacs_mule_charset[256];
117 /* Mapping table from ISO2022's charset (specified by DIMENSION,
118 CHARS, and FINAL-CHAR) to Emacs' charset. */
119 int iso_charset_table[ISO_MAX_DIMENSION][ISO_MAX_CHARS][ISO_MAX_FINAL];
121 #define CODE_POINT_TO_INDEX(charset, code) \
122 ((charset)->code_linear_p \
123 ? (int) ((code) - (charset)->min_code) \
124 : (((charset)->code_space_mask[(code) >> 24] & 0x8) \
125 && ((charset)->code_space_mask[((code) >> 16) & 0xFF] & 0x4) \
126 && ((charset)->code_space_mask[((code) >> 8) & 0xFF] & 0x2) \
127 && ((charset)->code_space_mask[(code) & 0xFF] & 0x1)) \
128 ? (int) (((((code) >> 24) - (charset)->code_space[12]) \
129 * (charset)->code_space[11]) \
130 + (((((code) >> 16) & 0xFF) - (charset)->code_space[8]) \
131 * (charset)->code_space[7]) \
132 + (((((code) >> 8) & 0xFF) - (charset)->code_space[4]) \
133 * (charset)->code_space[3]) \
134 + (((code) & 0xFF) - (charset)->code_space[0]) \
135 - ((charset)->char_index_offset)) \
136 : -1)
139 /* Return the code-point for the character index IDX in CHARSET.
140 IDX should be an unsigned int variable in a valid range (which is
141 always in nonnegative int range too). IDX contains garbage afterwards. */
143 #define INDEX_TO_CODE_POINT(charset, idx) \
144 ((charset)->code_linear_p \
145 ? (idx) + (charset)->min_code \
146 : (idx += (charset)->char_index_offset, \
147 (((charset)->code_space[0] + (idx) % (charset)->code_space[2]) \
148 | (((charset)->code_space[4] \
149 + ((idx) / (charset)->code_space[3] % (charset)->code_space[6])) \
150 << 8) \
151 | (((charset)->code_space[8] \
152 + ((idx) / (charset)->code_space[7] % (charset)->code_space[10])) \
153 << 16) \
154 | (((charset)->code_space[12] + ((idx) / (charset)->code_space[11])) \
155 << 24))))
157 /* Structure to hold mapping tables for a charset. Used by temacs
158 invoked for dumping. */
160 static struct
162 /* The current charset for which the following tables are setup. */
163 struct charset *current;
165 /* 1 iff the following table is used for encoder. */
166 short for_encoder;
168 /* When the following table is used for encoding, minimum and
169 maximum character of the current charset. */
170 int min_char, max_char;
172 /* A Unicode character corresponding to the code index 0 (i.e. the
173 minimum code-point) of the current charset, or -1 if the code
174 index 0 is not a Unicode character. This is checked when
175 table.encoder[CHAR] is zero. */
176 int zero_index_char;
178 union {
179 /* Table mapping code-indices (not code-points) of the current
180 charset to Unicode characters. If decoder[CHAR] is -1, CHAR
181 doesn't belong to the current charset. */
182 int decoder[0x10000];
183 /* Table mapping Unicode characters to code-indices of the current
184 charset. The first 0x10000 elements are for BMP (0..0xFFFF),
185 and the last 0x10000 are for SMP (0x10000..0x1FFFF) or SIP
186 (0x20000..0x2FFFF). Note that there is no charset map that
187 uses both SMP and SIP. */
188 unsigned short encoder[0x20000];
189 } table;
190 } *temp_charset_work;
192 #define SET_TEMP_CHARSET_WORK_ENCODER(C, CODE) \
193 do { \
194 if ((CODE) == 0) \
195 temp_charset_work->zero_index_char = (C); \
196 else if ((C) < 0x20000) \
197 temp_charset_work->table.encoder[(C)] = (CODE); \
198 else \
199 temp_charset_work->table.encoder[(C) - 0x10000] = (CODE); \
200 } while (0)
202 #define GET_TEMP_CHARSET_WORK_ENCODER(C) \
203 ((C) == temp_charset_work->zero_index_char ? 0 \
204 : (C) < 0x20000 ? (temp_charset_work->table.encoder[(C)] \
205 ? (int) temp_charset_work->table.encoder[(C)] : -1) \
206 : temp_charset_work->table.encoder[(C) - 0x10000] \
207 ? temp_charset_work->table.encoder[(C) - 0x10000] : -1)
209 #define SET_TEMP_CHARSET_WORK_DECODER(C, CODE) \
210 (temp_charset_work->table.decoder[(CODE)] = (C))
212 #define GET_TEMP_CHARSET_WORK_DECODER(CODE) \
213 (temp_charset_work->table.decoder[(CODE)])
216 /* Set to 1 to warn that a charset map is loaded and thus a buffer
217 text and a string data may be relocated. */
218 bool charset_map_loaded;
220 struct charset_map_entries
222 struct {
223 unsigned from, to;
224 int c;
225 } entry[0x10000];
226 struct charset_map_entries *next;
229 /* Load the mapping information of CHARSET from ENTRIES for
230 initializing (CONTROL_FLAG == 0), decoding (CONTROL_FLAG == 1), and
231 encoding (CONTROL_FLAG == 2).
233 If CONTROL_FLAG is 0, setup CHARSET->min_char, CHARSET->max_char,
234 and CHARSET->fast_map.
236 If CONTROL_FLAG is 1, setup the following tables according to
237 CHARSET->method and inhibit_load_charset_map.
239 CHARSET->method | inhibit_lcm == 0 | inhibit_lcm == 1
240 ----------------------+--------------------+---------------------------
241 CHARSET_METHOD_MAP | CHARSET->decoder | temp_charset_work->decoder
242 ----------------------+--------------------+---------------------------
243 CHARSET_METHOD_OFFSET | Vchar_unify_table | temp_charset_work->decoder
245 If CONTROL_FLAG is 2, setup the following tables.
247 CHARSET->method | inhibit_lcm == 0 | inhibit_lcm == 1
248 ----------------------+--------------------+---------------------------
249 CHARSET_METHOD_MAP | CHARSET->encoder | temp_charset_work->encoder
250 ----------------------+--------------------+--------------------------
251 CHARSET_METHOD_OFFSET | CHARSET->deunifier | temp_charset_work->encoder
254 static void
255 load_charset_map (struct charset *charset, struct charset_map_entries *entries, int n_entries, int control_flag)
257 Lisp_Object vec IF_LINT (= Qnil), table IF_LINT (= Qnil);
258 unsigned max_code = CHARSET_MAX_CODE (charset);
259 bool ascii_compatible_p = charset->ascii_compatible_p;
260 int min_char, max_char, nonascii_min_char;
261 int i;
262 unsigned char *fast_map = charset->fast_map;
264 if (n_entries <= 0)
265 return;
267 if (control_flag)
269 if (! inhibit_load_charset_map)
271 if (control_flag == 1)
273 if (charset->method == CHARSET_METHOD_MAP)
275 int n = CODE_POINT_TO_INDEX (charset, max_code) + 1;
277 vec = Fmake_vector (make_number (n), make_number (-1));
278 set_charset_attr (charset, charset_decoder, vec);
280 else
282 char_table_set_range (Vchar_unify_table,
283 charset->min_char, charset->max_char,
284 Qnil);
287 else
289 table = Fmake_char_table (Qnil, Qnil);
290 set_charset_attr (charset,
291 (charset->method == CHARSET_METHOD_MAP
292 ? charset_encoder : charset_deunifier),
293 table);
296 else
298 if (! temp_charset_work)
299 temp_charset_work = xmalloc (sizeof *temp_charset_work);
300 if (control_flag == 1)
302 memset (temp_charset_work->table.decoder, -1,
303 sizeof (int) * 0x10000);
305 else
307 memset (temp_charset_work->table.encoder, 0,
308 sizeof (unsigned short) * 0x20000);
309 temp_charset_work->zero_index_char = -1;
311 temp_charset_work->current = charset;
312 temp_charset_work->for_encoder = (control_flag == 2);
313 control_flag += 2;
315 charset_map_loaded = 1;
318 min_char = max_char = entries->entry[0].c;
319 nonascii_min_char = MAX_CHAR;
320 for (i = 0; i < n_entries; i++)
322 unsigned from, to;
323 int from_index, to_index, lim_index;
324 int from_c, to_c;
325 int idx = i % 0x10000;
327 if (i > 0 && idx == 0)
328 entries = entries->next;
329 from = entries->entry[idx].from;
330 to = entries->entry[idx].to;
331 from_c = entries->entry[idx].c;
332 from_index = CODE_POINT_TO_INDEX (charset, from);
333 if (from == to)
335 to_index = from_index;
336 to_c = from_c;
338 else
340 to_index = CODE_POINT_TO_INDEX (charset, to);
341 to_c = from_c + (to_index - from_index);
343 if (from_index < 0 || to_index < 0)
344 continue;
345 lim_index = to_index + 1;
347 if (to_c > max_char)
348 max_char = to_c;
349 else if (from_c < min_char)
350 min_char = from_c;
352 if (control_flag == 1)
354 if (charset->method == CHARSET_METHOD_MAP)
355 for (; from_index < lim_index; from_index++, from_c++)
356 ASET (vec, from_index, make_number (from_c));
357 else
358 for (; from_index < lim_index; from_index++, from_c++)
359 CHAR_TABLE_SET (Vchar_unify_table,
360 CHARSET_CODE_OFFSET (charset) + from_index,
361 make_number (from_c));
363 else if (control_flag == 2)
365 if (charset->method == CHARSET_METHOD_MAP
366 && CHARSET_COMPACT_CODES_P (charset))
367 for (; from_index < lim_index; from_index++, from_c++)
369 unsigned code = from_index;
370 code = INDEX_TO_CODE_POINT (charset, code);
372 if (NILP (CHAR_TABLE_REF (table, from_c)))
373 CHAR_TABLE_SET (table, from_c, make_number (code));
375 else
376 for (; from_index < lim_index; from_index++, from_c++)
378 if (NILP (CHAR_TABLE_REF (table, from_c)))
379 CHAR_TABLE_SET (table, from_c, make_number (from_index));
382 else if (control_flag == 3)
383 for (; from_index < lim_index; from_index++, from_c++)
384 SET_TEMP_CHARSET_WORK_DECODER (from_c, from_index);
385 else if (control_flag == 4)
386 for (; from_index < lim_index; from_index++, from_c++)
387 SET_TEMP_CHARSET_WORK_ENCODER (from_c, from_index);
388 else /* control_flag == 0 */
390 if (ascii_compatible_p)
392 if (! ASCII_BYTE_P (from_c))
394 if (from_c < nonascii_min_char)
395 nonascii_min_char = from_c;
397 else if (! ASCII_BYTE_P (to_c))
399 nonascii_min_char = 0x80;
403 for (; from_c <= to_c; from_c++)
404 CHARSET_FAST_MAP_SET (from_c, fast_map);
408 if (control_flag == 0)
410 CHARSET_MIN_CHAR (charset) = (ascii_compatible_p
411 ? nonascii_min_char : min_char);
412 CHARSET_MAX_CHAR (charset) = max_char;
414 else if (control_flag == 4)
416 temp_charset_work->min_char = min_char;
417 temp_charset_work->max_char = max_char;
422 /* Read a hexadecimal number (preceded by "0x") from the file FP while
423 paying attention to comment character '#'. */
425 static unsigned
426 read_hex (FILE *fp, bool *eof, bool *overflow)
428 int c;
429 unsigned n;
431 while ((c = getc (fp)) != EOF)
433 if (c == '#')
435 while ((c = getc (fp)) != EOF && c != '\n');
437 else if (c == '0')
439 if ((c = getc (fp)) == EOF || c == 'x')
440 break;
443 if (c == EOF)
445 *eof = 1;
446 return 0;
448 n = 0;
449 while (c_isxdigit (c = getc (fp)))
451 if (UINT_MAX >> 4 < n)
452 *overflow = 1;
453 n = ((n << 4)
454 | (c - ('0' <= c && c <= '9' ? '0'
455 : 'A' <= c && c <= 'F' ? 'A' - 10
456 : 'a' - 10)));
458 if (c != EOF)
459 ungetc (c, fp);
460 return n;
463 /* Return a mapping vector for CHARSET loaded from MAPFILE.
464 Each line of MAPFILE has this form
465 0xAAAA 0xCCCC
466 where 0xAAAA is a code-point and 0xCCCC is the corresponding
467 character code, or this form
468 0xAAAA-0xBBBB 0xCCCC
469 where 0xAAAA and 0xBBBB are code-points specifying a range, and
470 0xCCCC is the first character code of the range.
472 The returned vector has this form:
473 [ CODE1 CHAR1 CODE2 CHAR2 .... ]
474 where CODE1 is a code-point or a cons of code-points specifying a
475 range.
477 Note that this function uses `openp' to open MAPFILE but ignores
478 `file-name-handler-alist' to avoid running any Lisp code. */
480 static void
481 load_charset_map_from_file (struct charset *charset, Lisp_Object mapfile,
482 int control_flag)
484 unsigned min_code = CHARSET_MIN_CODE (charset);
485 unsigned max_code = CHARSET_MAX_CODE (charset);
486 int fd;
487 FILE *fp;
488 Lisp_Object suffixes;
489 struct charset_map_entries *head, *entries;
490 int n_entries;
491 ptrdiff_t count;
493 suffixes = list2 (build_string (".map"), build_string (".TXT"));
495 count = SPECPDL_INDEX ();
496 record_unwind_protect_nothing ();
497 specbind (Qfile_name_handler_alist, Qnil);
498 fd = openp (Vcharset_map_path, mapfile, suffixes, NULL, Qnil, false);
499 fp = fd < 0 ? 0 : fdopen (fd, "r");
500 if (!fp)
502 int open_errno = errno;
503 emacs_close (fd);
504 report_file_errno ("Loading charset map", mapfile, open_errno);
506 set_unwind_protect_ptr (count, fclose_unwind, fp);
507 unbind_to (count + 1, Qnil);
509 /* Use record_xmalloc, as `charset_map_entries' is
510 large (larger than MAX_ALLOCA). */
511 head = record_xmalloc (sizeof *head);
512 entries = head;
513 memset (entries, 0, sizeof (struct charset_map_entries));
515 n_entries = 0;
516 while (1)
518 unsigned from, to, c;
519 int idx;
520 bool eof = 0, overflow = 0;
522 from = read_hex (fp, &eof, &overflow);
523 if (eof)
524 break;
525 if (getc (fp) == '-')
526 to = read_hex (fp, &eof, &overflow);
527 else
528 to = from;
529 if (eof)
530 break;
531 c = read_hex (fp, &eof, &overflow);
532 if (eof)
533 break;
535 if (overflow)
536 continue;
537 if (from < min_code || to > max_code || from > to || c > MAX_CHAR)
538 continue;
540 if (n_entries == 0x10000)
542 entries->next = record_xmalloc (sizeof *entries->next);
543 entries = entries->next;
544 memset (entries, 0, sizeof (struct charset_map_entries));
545 n_entries = 0;
547 idx = n_entries;
548 entries->entry[idx].from = from;
549 entries->entry[idx].to = to;
550 entries->entry[idx].c = c;
551 n_entries++;
553 fclose (fp);
554 clear_unwind_protect (count);
556 load_charset_map (charset, head, n_entries, control_flag);
557 unbind_to (count, Qnil);
560 static void
561 load_charset_map_from_vector (struct charset *charset, Lisp_Object vec, int control_flag)
563 unsigned min_code = CHARSET_MIN_CODE (charset);
564 unsigned max_code = CHARSET_MAX_CODE (charset);
565 struct charset_map_entries *head, *entries;
566 int n_entries;
567 int len = ASIZE (vec);
568 int i;
569 USE_SAFE_ALLOCA;
571 if (len % 2 == 1)
573 add_to_log ("Failure in loading charset map: %V", vec, Qnil);
574 return;
577 /* Use SAFE_ALLOCA instead of alloca, as `charset_map_entries' is
578 large (larger than MAX_ALLOCA). */
579 head = SAFE_ALLOCA (sizeof *head);
580 entries = head;
581 memset (entries, 0, sizeof (struct charset_map_entries));
583 n_entries = 0;
584 for (i = 0; i < len; i += 2)
586 Lisp_Object val, val2;
587 unsigned from, to;
588 EMACS_INT c;
589 int idx;
591 val = AREF (vec, i);
592 if (CONSP (val))
594 val2 = XCDR (val);
595 val = XCAR (val);
596 from = XFASTINT (val);
597 to = XFASTINT (val2);
599 else
600 from = to = XFASTINT (val);
601 val = AREF (vec, i + 1);
602 CHECK_NATNUM (val);
603 c = XFASTINT (val);
605 if (from < min_code || to > max_code || from > to || c > MAX_CHAR)
606 continue;
608 if (n_entries > 0 && (n_entries % 0x10000) == 0)
610 entries->next = SAFE_ALLOCA (sizeof *entries->next);
611 entries = entries->next;
612 memset (entries, 0, sizeof (struct charset_map_entries));
614 idx = n_entries % 0x10000;
615 entries->entry[idx].from = from;
616 entries->entry[idx].to = to;
617 entries->entry[idx].c = c;
618 n_entries++;
621 load_charset_map (charset, head, n_entries, control_flag);
622 SAFE_FREE ();
626 /* Load a mapping table for CHARSET. CONTROL-FLAG tells what kind of
627 map it is (see the comment of load_charset_map for the detail). */
629 static void
630 load_charset (struct charset *charset, int control_flag)
632 Lisp_Object map;
634 if (inhibit_load_charset_map
635 && temp_charset_work
636 && charset == temp_charset_work->current
637 && ((control_flag == 2) == temp_charset_work->for_encoder))
638 return;
640 if (CHARSET_METHOD (charset) == CHARSET_METHOD_MAP)
641 map = CHARSET_MAP (charset);
642 else
644 if (! CHARSET_UNIFIED_P (charset))
645 emacs_abort ();
646 map = CHARSET_UNIFY_MAP (charset);
648 if (STRINGP (map))
649 load_charset_map_from_file (charset, map, control_flag);
650 else
651 load_charset_map_from_vector (charset, map, control_flag);
655 DEFUN ("charsetp", Fcharsetp, Scharsetp, 1, 1, 0,
656 doc: /* Return non-nil if and only if OBJECT is a charset.*/)
657 (Lisp_Object object)
659 return (CHARSETP (object) ? Qt : Qnil);
663 static void
664 map_charset_for_dump (void (*c_function) (Lisp_Object, Lisp_Object),
665 Lisp_Object function, Lisp_Object arg,
666 unsigned int from, unsigned int to)
668 int from_idx = CODE_POINT_TO_INDEX (temp_charset_work->current, from);
669 int to_idx = CODE_POINT_TO_INDEX (temp_charset_work->current, to);
670 Lisp_Object range;
671 int c, stop;
672 struct gcpro gcpro1;
674 range = Fcons (Qnil, Qnil);
675 GCPRO1 (range);
677 c = temp_charset_work->min_char;
678 stop = (temp_charset_work->max_char < 0x20000
679 ? temp_charset_work->max_char : 0xFFFF);
681 while (1)
683 int idx = GET_TEMP_CHARSET_WORK_ENCODER (c);
685 if (idx >= from_idx && idx <= to_idx)
687 if (NILP (XCAR (range)))
688 XSETCAR (range, make_number (c));
690 else if (! NILP (XCAR (range)))
692 XSETCDR (range, make_number (c - 1));
693 if (c_function)
694 (*c_function) (arg, range);
695 else
696 call2 (function, range, arg);
697 XSETCAR (range, Qnil);
699 if (c == stop)
701 if (c == temp_charset_work->max_char)
703 if (! NILP (XCAR (range)))
705 XSETCDR (range, make_number (c));
706 if (c_function)
707 (*c_function) (arg, range);
708 else
709 call2 (function, range, arg);
711 break;
713 c = 0x1FFFF;
714 stop = temp_charset_work->max_char;
716 c++;
718 UNGCPRO;
721 void
722 map_charset_chars (void (*c_function)(Lisp_Object, Lisp_Object), Lisp_Object function,
723 Lisp_Object arg, struct charset *charset, unsigned from, unsigned to)
725 Lisp_Object range;
726 bool partial = (from > CHARSET_MIN_CODE (charset)
727 || to < CHARSET_MAX_CODE (charset));
729 if (CHARSET_METHOD (charset) == CHARSET_METHOD_OFFSET)
731 int from_idx = CODE_POINT_TO_INDEX (charset, from);
732 int to_idx = CODE_POINT_TO_INDEX (charset, to);
733 int from_c = from_idx + CHARSET_CODE_OFFSET (charset);
734 int to_c = to_idx + CHARSET_CODE_OFFSET (charset);
736 if (CHARSET_UNIFIED_P (charset))
738 if (! CHAR_TABLE_P (CHARSET_DEUNIFIER (charset)))
739 load_charset (charset, 2);
740 if (CHAR_TABLE_P (CHARSET_DEUNIFIER (charset)))
741 map_char_table_for_charset (c_function, function,
742 CHARSET_DEUNIFIER (charset), arg,
743 partial ? charset : NULL, from, to);
744 else
745 map_charset_for_dump (c_function, function, arg, from, to);
748 range = Fcons (make_number (from_c), make_number (to_c));
749 if (NILP (function))
750 (*c_function) (arg, range);
751 else
752 call2 (function, range, arg);
754 else if (CHARSET_METHOD (charset) == CHARSET_METHOD_MAP)
756 if (! CHAR_TABLE_P (CHARSET_ENCODER (charset)))
757 load_charset (charset, 2);
758 if (CHAR_TABLE_P (CHARSET_ENCODER (charset)))
759 map_char_table_for_charset (c_function, function,
760 CHARSET_ENCODER (charset), arg,
761 partial ? charset : NULL, from, to);
762 else
763 map_charset_for_dump (c_function, function, arg, from, to);
765 else if (CHARSET_METHOD (charset) == CHARSET_METHOD_SUBSET)
767 Lisp_Object subset_info;
768 int offset;
770 subset_info = CHARSET_SUBSET (charset);
771 charset = CHARSET_FROM_ID (XFASTINT (AREF (subset_info, 0)));
772 offset = XINT (AREF (subset_info, 3));
773 from -= offset;
774 if (from < XFASTINT (AREF (subset_info, 1)))
775 from = XFASTINT (AREF (subset_info, 1));
776 to -= offset;
777 if (to > XFASTINT (AREF (subset_info, 2)))
778 to = XFASTINT (AREF (subset_info, 2));
779 map_charset_chars (c_function, function, arg, charset, from, to);
781 else /* i.e. CHARSET_METHOD_SUPERSET */
783 Lisp_Object parents;
785 for (parents = CHARSET_SUPERSET (charset); CONSP (parents);
786 parents = XCDR (parents))
788 int offset;
789 unsigned this_from, this_to;
791 charset = CHARSET_FROM_ID (XFASTINT (XCAR (XCAR (parents))));
792 offset = XINT (XCDR (XCAR (parents)));
793 this_from = from > offset ? from - offset : 0;
794 this_to = to > offset ? to - offset : 0;
795 if (this_from < CHARSET_MIN_CODE (charset))
796 this_from = CHARSET_MIN_CODE (charset);
797 if (this_to > CHARSET_MAX_CODE (charset))
798 this_to = CHARSET_MAX_CODE (charset);
799 map_charset_chars (c_function, function, arg, charset,
800 this_from, this_to);
805 DEFUN ("map-charset-chars", Fmap_charset_chars, Smap_charset_chars, 2, 5, 0,
806 doc: /* Call FUNCTION for all characters in CHARSET.
807 FUNCTION is called with an argument RANGE and the optional 3rd
808 argument ARG.
810 RANGE is a cons (FROM . TO), where FROM and TO indicate a range of
811 characters contained in CHARSET.
813 The optional 4th and 5th arguments FROM-CODE and TO-CODE specify the
814 range of code points (in CHARSET) of target characters. */)
815 (Lisp_Object function, Lisp_Object charset, Lisp_Object arg, Lisp_Object from_code, Lisp_Object to_code)
817 struct charset *cs;
818 unsigned from, to;
820 CHECK_CHARSET_GET_CHARSET (charset, cs);
821 if (NILP (from_code))
822 from = CHARSET_MIN_CODE (cs);
823 else
825 from = XINT (from_code);
826 if (from < CHARSET_MIN_CODE (cs))
827 from = CHARSET_MIN_CODE (cs);
829 if (NILP (to_code))
830 to = CHARSET_MAX_CODE (cs);
831 else
833 to = XINT (to_code);
834 if (to > CHARSET_MAX_CODE (cs))
835 to = CHARSET_MAX_CODE (cs);
837 map_charset_chars (NULL, function, arg, cs, from, to);
838 return Qnil;
842 /* Define a charset according to the arguments. The Nth argument is
843 the Nth attribute of the charset (the last attribute `charset-id'
844 is not included). See the docstring of `define-charset' for the
845 detail. */
847 DEFUN ("define-charset-internal", Fdefine_charset_internal,
848 Sdefine_charset_internal, charset_arg_max, MANY, 0,
849 doc: /* For internal use only.
850 usage: (define-charset-internal ...) */)
851 (ptrdiff_t nargs, Lisp_Object *args)
853 /* Charset attr vector. */
854 Lisp_Object attrs;
855 Lisp_Object val;
856 EMACS_UINT hash_code;
857 struct Lisp_Hash_Table *hash_table = XHASH_TABLE (Vcharset_hash_table);
858 int i, j;
859 struct charset charset;
860 int id;
861 int dimension;
862 bool new_definition_p;
863 int nchars;
865 if (nargs != charset_arg_max)
866 return Fsignal (Qwrong_number_of_arguments,
867 Fcons (intern ("define-charset-internal"),
868 make_number (nargs)));
870 attrs = Fmake_vector (make_number (charset_attr_max), Qnil);
872 CHECK_SYMBOL (args[charset_arg_name]);
873 ASET (attrs, charset_name, args[charset_arg_name]);
875 val = args[charset_arg_code_space];
876 for (i = 0, dimension = 0, nchars = 1; ; i++)
878 Lisp_Object min_byte_obj, max_byte_obj;
879 int min_byte, max_byte;
881 min_byte_obj = Faref (val, make_number (i * 2));
882 max_byte_obj = Faref (val, make_number (i * 2 + 1));
883 CHECK_RANGED_INTEGER (min_byte_obj, 0, 255);
884 min_byte = XINT (min_byte_obj);
885 CHECK_RANGED_INTEGER (max_byte_obj, min_byte, 255);
886 max_byte = XINT (max_byte_obj);
887 charset.code_space[i * 4] = min_byte;
888 charset.code_space[i * 4 + 1] = max_byte;
889 charset.code_space[i * 4 + 2] = max_byte - min_byte + 1;
890 if (max_byte > 0)
891 dimension = i + 1;
892 if (i == 3)
893 break;
894 nchars *= charset.code_space[i * 4 + 2];
895 charset.code_space[i * 4 + 3] = nchars;
898 val = args[charset_arg_dimension];
899 if (NILP (val))
900 charset.dimension = dimension;
901 else
903 CHECK_RANGED_INTEGER (val, 1, 4);
904 charset.dimension = XINT (val);
907 charset.code_linear_p
908 = (charset.dimension == 1
909 || (charset.code_space[2] == 256
910 && (charset.dimension == 2
911 || (charset.code_space[6] == 256
912 && (charset.dimension == 3
913 || charset.code_space[10] == 256)))));
915 if (! charset.code_linear_p)
917 charset.code_space_mask = xzalloc (256);
918 for (i = 0; i < 4; i++)
919 for (j = charset.code_space[i * 4]; j <= charset.code_space[i * 4 + 1];
920 j++)
921 charset.code_space_mask[j] |= (1 << i);
924 charset.iso_chars_96 = charset.code_space[2] == 96;
926 charset.min_code = (charset.code_space[0]
927 | (charset.code_space[4] << 8)
928 | (charset.code_space[8] << 16)
929 | ((unsigned) charset.code_space[12] << 24));
930 charset.max_code = (charset.code_space[1]
931 | (charset.code_space[5] << 8)
932 | (charset.code_space[9] << 16)
933 | ((unsigned) charset.code_space[13] << 24));
934 charset.char_index_offset = 0;
936 val = args[charset_arg_min_code];
937 if (! NILP (val))
939 unsigned code = cons_to_unsigned (val, UINT_MAX);
941 if (code < charset.min_code
942 || code > charset.max_code)
943 args_out_of_range_3 (make_fixnum_or_float (charset.min_code),
944 make_fixnum_or_float (charset.max_code), val);
945 charset.char_index_offset = CODE_POINT_TO_INDEX (&charset, code);
946 charset.min_code = code;
949 val = args[charset_arg_max_code];
950 if (! NILP (val))
952 unsigned code = cons_to_unsigned (val, UINT_MAX);
954 if (code < charset.min_code
955 || code > charset.max_code)
956 args_out_of_range_3 (make_fixnum_or_float (charset.min_code),
957 make_fixnum_or_float (charset.max_code), val);
958 charset.max_code = code;
961 charset.compact_codes_p = charset.max_code < 0x10000;
963 val = args[charset_arg_invalid_code];
964 if (NILP (val))
966 if (charset.min_code > 0)
967 charset.invalid_code = 0;
968 else
970 if (charset.max_code < UINT_MAX)
971 charset.invalid_code = charset.max_code + 1;
972 else
973 error ("Attribute :invalid-code must be specified");
976 else
977 charset.invalid_code = cons_to_unsigned (val, UINT_MAX);
979 val = args[charset_arg_iso_final];
980 if (NILP (val))
981 charset.iso_final = -1;
982 else
984 CHECK_NUMBER (val);
985 if (XINT (val) < '0' || XINT (val) > 127)
986 error ("Invalid iso-final-char: %"pI"d", XINT (val));
987 charset.iso_final = XINT (val);
990 val = args[charset_arg_iso_revision];
991 if (NILP (val))
992 charset.iso_revision = -1;
993 else
995 CHECK_RANGED_INTEGER (val, -1, 63);
996 charset.iso_revision = XINT (val);
999 val = args[charset_arg_emacs_mule_id];
1000 if (NILP (val))
1001 charset.emacs_mule_id = -1;
1002 else
1004 CHECK_NATNUM (val);
1005 if ((XINT (val) > 0 && XINT (val) <= 128) || XINT (val) >= 256)
1006 error ("Invalid emacs-mule-id: %"pI"d", XINT (val));
1007 charset.emacs_mule_id = XINT (val);
1010 charset.ascii_compatible_p = ! NILP (args[charset_arg_ascii_compatible_p]);
1012 charset.supplementary_p = ! NILP (args[charset_arg_supplementary_p]);
1014 charset.unified_p = 0;
1016 memset (charset.fast_map, 0, sizeof (charset.fast_map));
1018 if (! NILP (args[charset_arg_code_offset]))
1020 val = args[charset_arg_code_offset];
1021 CHECK_CHARACTER (val);
1023 charset.method = CHARSET_METHOD_OFFSET;
1024 charset.code_offset = XINT (val);
1026 i = CODE_POINT_TO_INDEX (&charset, charset.max_code);
1027 if (MAX_CHAR - charset.code_offset < i)
1028 error ("Unsupported max char: %d", charset.max_char);
1029 charset.max_char = i + charset.code_offset;
1030 i = CODE_POINT_TO_INDEX (&charset, charset.min_code);
1031 charset.min_char = i + charset.code_offset;
1033 i = (charset.min_char >> 7) << 7;
1034 for (; i < 0x10000 && i <= charset.max_char; i += 128)
1035 CHARSET_FAST_MAP_SET (i, charset.fast_map);
1036 i = (i >> 12) << 12;
1037 for (; i <= charset.max_char; i += 0x1000)
1038 CHARSET_FAST_MAP_SET (i, charset.fast_map);
1039 if (charset.code_offset == 0 && charset.max_char >= 0x80)
1040 charset.ascii_compatible_p = 1;
1042 else if (! NILP (args[charset_arg_map]))
1044 val = args[charset_arg_map];
1045 ASET (attrs, charset_map, val);
1046 charset.method = CHARSET_METHOD_MAP;
1048 else if (! NILP (args[charset_arg_subset]))
1050 Lisp_Object parent;
1051 Lisp_Object parent_min_code, parent_max_code, parent_code_offset;
1052 struct charset *parent_charset;
1054 val = args[charset_arg_subset];
1055 parent = Fcar (val);
1056 CHECK_CHARSET_GET_CHARSET (parent, parent_charset);
1057 parent_min_code = Fnth (make_number (1), val);
1058 CHECK_NATNUM (parent_min_code);
1059 parent_max_code = Fnth (make_number (2), val);
1060 CHECK_NATNUM (parent_max_code);
1061 parent_code_offset = Fnth (make_number (3), val);
1062 CHECK_NUMBER (parent_code_offset);
1063 val = make_uninit_vector (4);
1064 ASET (val, 0, make_number (parent_charset->id));
1065 ASET (val, 1, parent_min_code);
1066 ASET (val, 2, parent_max_code);
1067 ASET (val, 3, parent_code_offset);
1068 ASET (attrs, charset_subset, val);
1070 charset.method = CHARSET_METHOD_SUBSET;
1071 /* Here, we just copy the parent's fast_map. It's not accurate,
1072 but at least it works for quickly detecting which character
1073 DOESN'T belong to this charset. */
1074 for (i = 0; i < 190; i++)
1075 charset.fast_map[i] = parent_charset->fast_map[i];
1077 /* We also copy these for parents. */
1078 charset.min_char = parent_charset->min_char;
1079 charset.max_char = parent_charset->max_char;
1081 else if (! NILP (args[charset_arg_superset]))
1083 val = args[charset_arg_superset];
1084 charset.method = CHARSET_METHOD_SUPERSET;
1085 val = Fcopy_sequence (val);
1086 ASET (attrs, charset_superset, val);
1088 charset.min_char = MAX_CHAR;
1089 charset.max_char = 0;
1090 for (; ! NILP (val); val = Fcdr (val))
1092 Lisp_Object elt, car_part, cdr_part;
1093 int this_id, offset;
1094 struct charset *this_charset;
1096 elt = Fcar (val);
1097 if (CONSP (elt))
1099 car_part = XCAR (elt);
1100 cdr_part = XCDR (elt);
1101 CHECK_CHARSET_GET_ID (car_part, this_id);
1102 CHECK_TYPE_RANGED_INTEGER (int, cdr_part);
1103 offset = XINT (cdr_part);
1105 else
1107 CHECK_CHARSET_GET_ID (elt, this_id);
1108 offset = 0;
1110 XSETCAR (val, Fcons (make_number (this_id), make_number (offset)));
1112 this_charset = CHARSET_FROM_ID (this_id);
1113 if (charset.min_char > this_charset->min_char)
1114 charset.min_char = this_charset->min_char;
1115 if (charset.max_char < this_charset->max_char)
1116 charset.max_char = this_charset->max_char;
1117 for (i = 0; i < 190; i++)
1118 charset.fast_map[i] |= this_charset->fast_map[i];
1121 else
1122 error ("None of :code-offset, :map, :parents are specified");
1124 val = args[charset_arg_unify_map];
1125 if (! NILP (val) && !STRINGP (val))
1126 CHECK_VECTOR (val);
1127 ASET (attrs, charset_unify_map, val);
1129 CHECK_LIST (args[charset_arg_plist]);
1130 ASET (attrs, charset_plist, args[charset_arg_plist]);
1132 charset.hash_index = hash_lookup (hash_table, args[charset_arg_name],
1133 &hash_code);
1134 if (charset.hash_index >= 0)
1136 new_definition_p = 0;
1137 id = XFASTINT (CHARSET_SYMBOL_ID (args[charset_arg_name]));
1138 set_hash_value_slot (hash_table, charset.hash_index, attrs);
1140 else
1142 charset.hash_index = hash_put (hash_table, args[charset_arg_name], attrs,
1143 hash_code);
1144 if (charset_table_used == charset_table_size)
1146 /* Ensure that charset IDs fit into 'int' as well as into the
1147 restriction imposed by fixnums. Although the 'int' restriction
1148 could be removed, too much other code would need altering; for
1149 example, the IDs are stuffed into struct
1150 coding_system.charbuf[i] entries, which are 'int'. */
1151 int old_size = charset_table_size;
1152 ptrdiff_t new_size = old_size;
1153 struct charset *new_table =
1154 xpalloc (0, &new_size, 1,
1155 min (INT_MAX, MOST_POSITIVE_FIXNUM),
1156 sizeof *charset_table);
1157 memcpy (new_table, charset_table, old_size * sizeof *new_table);
1158 charset_table = new_table;
1159 charset_table_size = new_size;
1160 /* FIXME: This leaks memory, as the old charset_table becomes
1161 unreachable. If the old charset table is charset_table_init
1162 then this leak is intentional; otherwise, it's unclear.
1163 If the latter memory leak is intentional, a
1164 comment should be added to explain this. If not, the old
1165 charset_table should be freed, by passing it as the 1st argument
1166 to xpalloc and removing the memcpy. */
1168 id = charset_table_used++;
1169 new_definition_p = 1;
1172 ASET (attrs, charset_id, make_number (id));
1173 charset.id = id;
1174 charset_table[id] = charset;
1176 if (charset.method == CHARSET_METHOD_MAP)
1178 load_charset (&charset, 0);
1179 charset_table[id] = charset;
1182 if (charset.iso_final >= 0)
1184 ISO_CHARSET_TABLE (charset.dimension, charset.iso_chars_96,
1185 charset.iso_final) = id;
1186 if (new_definition_p)
1187 Viso_2022_charset_list = nconc2 (Viso_2022_charset_list,
1188 list1 (make_number (id)));
1189 if (ISO_CHARSET_TABLE (1, 0, 'J') == id)
1190 charset_jisx0201_roman = id;
1191 else if (ISO_CHARSET_TABLE (2, 0, '@') == id)
1192 charset_jisx0208_1978 = id;
1193 else if (ISO_CHARSET_TABLE (2, 0, 'B') == id)
1194 charset_jisx0208 = id;
1195 else if (ISO_CHARSET_TABLE (2, 0, 'C') == id)
1196 charset_ksc5601 = id;
1199 if (charset.emacs_mule_id >= 0)
1201 emacs_mule_charset[charset.emacs_mule_id] = id;
1202 if (charset.emacs_mule_id < 0xA0)
1203 emacs_mule_bytes[charset.emacs_mule_id] = charset.dimension + 1;
1204 else
1205 emacs_mule_bytes[charset.emacs_mule_id] = charset.dimension + 2;
1206 if (new_definition_p)
1207 Vemacs_mule_charset_list = nconc2 (Vemacs_mule_charset_list,
1208 list1 (make_number (id)));
1211 if (new_definition_p)
1213 Vcharset_list = Fcons (args[charset_arg_name], Vcharset_list);
1214 if (charset.supplementary_p)
1215 Vcharset_ordered_list = nconc2 (Vcharset_ordered_list,
1216 list1 (make_number (id)));
1217 else
1219 Lisp_Object tail;
1221 for (tail = Vcharset_ordered_list; CONSP (tail); tail = XCDR (tail))
1223 struct charset *cs = CHARSET_FROM_ID (XINT (XCAR (tail)));
1225 if (cs->supplementary_p)
1226 break;
1228 if (EQ (tail, Vcharset_ordered_list))
1229 Vcharset_ordered_list = Fcons (make_number (id),
1230 Vcharset_ordered_list);
1231 else if (NILP (tail))
1232 Vcharset_ordered_list = nconc2 (Vcharset_ordered_list,
1233 list1 (make_number (id)));
1234 else
1236 val = Fcons (XCAR (tail), XCDR (tail));
1237 XSETCDR (tail, val);
1238 XSETCAR (tail, make_number (id));
1241 charset_ordered_list_tick++;
1244 return Qnil;
1248 /* Same as Fdefine_charset_internal but arguments are more convenient
1249 to call from C (typically in syms_of_charset). This can define a
1250 charset of `offset' method only. Return the ID of the new
1251 charset. */
1253 static int
1254 define_charset_internal (Lisp_Object name,
1255 int dimension,
1256 const char *code_space_chars,
1257 unsigned min_code, unsigned max_code,
1258 int iso_final, int iso_revision, int emacs_mule_id,
1259 bool ascii_compatible, bool supplementary,
1260 int code_offset)
1262 const unsigned char *code_space = (const unsigned char *) code_space_chars;
1263 Lisp_Object args[charset_arg_max];
1264 Lisp_Object val;
1265 int i;
1267 args[charset_arg_name] = name;
1268 args[charset_arg_dimension] = make_number (dimension);
1269 val = make_uninit_vector (8);
1270 for (i = 0; i < 8; i++)
1271 ASET (val, i, make_number (code_space[i]));
1272 args[charset_arg_code_space] = val;
1273 args[charset_arg_min_code] = make_number (min_code);
1274 args[charset_arg_max_code] = make_number (max_code);
1275 args[charset_arg_iso_final]
1276 = (iso_final < 0 ? Qnil : make_number (iso_final));
1277 args[charset_arg_iso_revision] = make_number (iso_revision);
1278 args[charset_arg_emacs_mule_id]
1279 = (emacs_mule_id < 0 ? Qnil : make_number (emacs_mule_id));
1280 args[charset_arg_ascii_compatible_p] = ascii_compatible ? Qt : Qnil;
1281 args[charset_arg_supplementary_p] = supplementary ? Qt : Qnil;
1282 args[charset_arg_invalid_code] = Qnil;
1283 args[charset_arg_code_offset] = make_number (code_offset);
1284 args[charset_arg_map] = Qnil;
1285 args[charset_arg_subset] = Qnil;
1286 args[charset_arg_superset] = Qnil;
1287 args[charset_arg_unify_map] = Qnil;
1289 args[charset_arg_plist] =
1290 listn (CONSTYPE_HEAP, 14,
1291 intern_c_string (":name"),
1292 args[charset_arg_name],
1293 intern_c_string (":dimension"),
1294 args[charset_arg_dimension],
1295 intern_c_string (":code-space"),
1296 args[charset_arg_code_space],
1297 intern_c_string (":iso-final-char"),
1298 args[charset_arg_iso_final],
1299 intern_c_string (":emacs-mule-id"),
1300 args[charset_arg_emacs_mule_id],
1301 intern_c_string (":ascii-compatible-p"),
1302 args[charset_arg_ascii_compatible_p],
1303 intern_c_string (":code-offset"),
1304 args[charset_arg_code_offset]);
1305 Fdefine_charset_internal (charset_arg_max, args);
1307 return XINT (CHARSET_SYMBOL_ID (name));
1311 DEFUN ("define-charset-alias", Fdefine_charset_alias,
1312 Sdefine_charset_alias, 2, 2, 0,
1313 doc: /* Define ALIAS as an alias for charset CHARSET. */)
1314 (Lisp_Object alias, Lisp_Object charset)
1316 Lisp_Object attr;
1318 CHECK_CHARSET_GET_ATTR (charset, attr);
1319 Fputhash (alias, attr, Vcharset_hash_table);
1320 Vcharset_list = Fcons (alias, Vcharset_list);
1321 return Qnil;
1325 DEFUN ("charset-plist", Fcharset_plist, Scharset_plist, 1, 1, 0,
1326 doc: /* Return the property list of CHARSET. */)
1327 (Lisp_Object charset)
1329 Lisp_Object attrs;
1331 CHECK_CHARSET_GET_ATTR (charset, attrs);
1332 return CHARSET_ATTR_PLIST (attrs);
1336 DEFUN ("set-charset-plist", Fset_charset_plist, Sset_charset_plist, 2, 2, 0,
1337 doc: /* Set CHARSET's property list to PLIST. */)
1338 (Lisp_Object charset, Lisp_Object plist)
1340 Lisp_Object attrs;
1342 CHECK_CHARSET_GET_ATTR (charset, attrs);
1343 ASET (attrs, charset_plist, plist);
1344 return plist;
1348 DEFUN ("unify-charset", Funify_charset, Sunify_charset, 1, 3, 0,
1349 doc: /* Unify characters of CHARSET with Unicode.
1350 This means reading the relevant file and installing the table defined
1351 by CHARSET's `:unify-map' property.
1353 Optional second arg UNIFY-MAP is a file name string or a vector. It has
1354 the same meaning as the `:unify-map' attribute in the function
1355 `define-charset' (which see).
1357 Optional third argument DEUNIFY, if non-nil, means to de-unify CHARSET. */)
1358 (Lisp_Object charset, Lisp_Object unify_map, Lisp_Object deunify)
1360 int id;
1361 struct charset *cs;
1363 CHECK_CHARSET_GET_ID (charset, id);
1364 cs = CHARSET_FROM_ID (id);
1365 if (NILP (deunify)
1366 ? CHARSET_UNIFIED_P (cs) && ! NILP (CHARSET_DEUNIFIER (cs))
1367 : ! CHARSET_UNIFIED_P (cs))
1368 return Qnil;
1370 CHARSET_UNIFIED_P (cs) = 0;
1371 if (NILP (deunify))
1373 if (CHARSET_METHOD (cs) != CHARSET_METHOD_OFFSET
1374 || CHARSET_CODE_OFFSET (cs) < 0x110000)
1375 error ("Can't unify charset: %s", SDATA (SYMBOL_NAME (charset)));
1376 if (NILP (unify_map))
1377 unify_map = CHARSET_UNIFY_MAP (cs);
1378 else
1380 if (! STRINGP (unify_map) && ! VECTORP (unify_map))
1381 signal_error ("Bad unify-map", unify_map);
1382 set_charset_attr (cs, charset_unify_map, unify_map);
1384 if (NILP (Vchar_unify_table))
1385 Vchar_unify_table = Fmake_char_table (Qnil, Qnil);
1386 char_table_set_range (Vchar_unify_table,
1387 cs->min_char, cs->max_char, charset);
1388 CHARSET_UNIFIED_P (cs) = 1;
1390 else if (CHAR_TABLE_P (Vchar_unify_table))
1392 unsigned min_code = CHARSET_MIN_CODE (cs);
1393 unsigned max_code = CHARSET_MAX_CODE (cs);
1394 int min_char = DECODE_CHAR (cs, min_code);
1395 int max_char = DECODE_CHAR (cs, max_code);
1397 char_table_set_range (Vchar_unify_table, min_char, max_char, Qnil);
1400 return Qnil;
1403 DEFUN ("get-unused-iso-final-char", Fget_unused_iso_final_char,
1404 Sget_unused_iso_final_char, 2, 2, 0,
1405 doc: /*
1406 Return an unused ISO final char for a charset of DIMENSION and CHARS.
1407 DIMENSION is the number of bytes to represent a character: 1 or 2.
1408 CHARS is the number of characters in a dimension: 94 or 96.
1410 This final char is for private use, thus the range is `0' (48) .. `?' (63).
1411 If there's no unused final char for the specified kind of charset,
1412 return nil. */)
1413 (Lisp_Object dimension, Lisp_Object chars)
1415 int final_char;
1417 CHECK_NUMBER (dimension);
1418 CHECK_NUMBER (chars);
1419 if (XINT (dimension) != 1 && XINT (dimension) != 2 && XINT (dimension) != 3)
1420 args_out_of_range_3 (dimension, make_number (1), make_number (3));
1421 if (XINT (chars) != 94 && XINT (chars) != 96)
1422 args_out_of_range_3 (chars, make_number (94), make_number (96));
1423 for (final_char = '0'; final_char <= '?'; final_char++)
1424 if (ISO_CHARSET_TABLE (XINT (dimension), XINT (chars), final_char) < 0)
1425 break;
1426 return (final_char <= '?' ? make_number (final_char) : Qnil);
1429 static void
1430 check_iso_charset_parameter (Lisp_Object dimension, Lisp_Object chars, Lisp_Object final_char)
1432 CHECK_NATNUM (dimension);
1433 CHECK_NATNUM (chars);
1434 CHECK_CHARACTER (final_char);
1436 if (XINT (dimension) > 3)
1437 error ("Invalid DIMENSION %"pI"d, it should be 1, 2, or 3",
1438 XINT (dimension));
1439 if (XINT (chars) != 94 && XINT (chars) != 96)
1440 error ("Invalid CHARS %"pI"d, it should be 94 or 96", XINT (chars));
1441 if (XINT (final_char) < '0' || XINT (final_char) > '~')
1442 error ("Invalid FINAL-CHAR %c, it should be `0'..`~'",
1443 (int)XINT (final_char));
1447 DEFUN ("declare-equiv-charset", Fdeclare_equiv_charset, Sdeclare_equiv_charset,
1448 4, 4, 0,
1449 doc: /* Declare an equivalent charset for ISO-2022 decoding.
1451 On decoding by an ISO-2022 base coding system, when a charset
1452 specified by DIMENSION, CHARS, and FINAL-CHAR is designated, behave as
1453 if CHARSET is designated instead. */)
1454 (Lisp_Object dimension, Lisp_Object chars, Lisp_Object final_char, Lisp_Object charset)
1456 int id;
1457 bool chars_flag;
1459 CHECK_CHARSET_GET_ID (charset, id);
1460 check_iso_charset_parameter (dimension, chars, final_char);
1461 chars_flag = XINT (chars) == 96;
1462 ISO_CHARSET_TABLE (XINT (dimension), chars_flag, XINT (final_char)) = id;
1463 return Qnil;
1467 /* Return information about charsets in the text at PTR of NBYTES
1468 bytes, which are NCHARS characters. The value is:
1470 0: Each character is represented by one byte. This is always
1471 true for a unibyte string. For a multibyte string, true if
1472 it contains only ASCII characters.
1474 1: No charsets other than ascii, control-1, and latin-1 are
1475 found.
1477 2: Otherwise.
1481 string_xstring_p (Lisp_Object string)
1483 const unsigned char *p = SDATA (string);
1484 const unsigned char *endp = p + SBYTES (string);
1486 if (SCHARS (string) == SBYTES (string))
1487 return 0;
1489 while (p < endp)
1491 int c = STRING_CHAR_ADVANCE (p);
1493 if (c >= 0x100)
1494 return 2;
1496 return 1;
1500 /* Find charsets in the string at PTR of NCHARS and NBYTES.
1502 CHARSETS is a vector. If Nth element is non-nil, it means the
1503 charset whose id is N is already found.
1505 It may lookup a translation table TABLE if supplied. */
1507 static void
1508 find_charsets_in_text (const unsigned char *ptr, ptrdiff_t nchars,
1509 ptrdiff_t nbytes, Lisp_Object charsets,
1510 Lisp_Object table, bool multibyte)
1512 const unsigned char *pend = ptr + nbytes;
1514 if (nchars == nbytes)
1516 if (multibyte)
1517 ASET (charsets, charset_ascii, Qt);
1518 else
1519 while (ptr < pend)
1521 int c = *ptr++;
1523 if (!NILP (table))
1524 c = translate_char (table, c);
1525 if (ASCII_BYTE_P (c))
1526 ASET (charsets, charset_ascii, Qt);
1527 else
1528 ASET (charsets, charset_eight_bit, Qt);
1531 else
1533 while (ptr < pend)
1535 int c = STRING_CHAR_ADVANCE (ptr);
1536 struct charset *charset;
1538 if (!NILP (table))
1539 c = translate_char (table, c);
1540 charset = CHAR_CHARSET (c);
1541 ASET (charsets, CHARSET_ID (charset), Qt);
1546 DEFUN ("find-charset-region", Ffind_charset_region, Sfind_charset_region,
1547 2, 3, 0,
1548 doc: /* Return a list of charsets in the region between BEG and END.
1549 BEG and END are buffer positions.
1550 Optional arg TABLE if non-nil is a translation table to look up.
1552 If the current buffer is unibyte, the returned list may contain
1553 only `ascii', `eight-bit-control', and `eight-bit-graphic'. */)
1554 (Lisp_Object beg, Lisp_Object end, Lisp_Object table)
1556 Lisp_Object charsets;
1557 ptrdiff_t from, from_byte, to, stop, stop_byte;
1558 int i;
1559 Lisp_Object val;
1560 bool multibyte = ! NILP (BVAR (current_buffer, enable_multibyte_characters));
1562 validate_region (&beg, &end);
1563 from = XFASTINT (beg);
1564 stop = to = XFASTINT (end);
1566 if (from < GPT && GPT < to)
1568 stop = GPT;
1569 stop_byte = GPT_BYTE;
1571 else
1572 stop_byte = CHAR_TO_BYTE (stop);
1574 from_byte = CHAR_TO_BYTE (from);
1576 charsets = Fmake_vector (make_number (charset_table_used), Qnil);
1577 while (1)
1579 find_charsets_in_text (BYTE_POS_ADDR (from_byte), stop - from,
1580 stop_byte - from_byte, charsets, table,
1581 multibyte);
1582 if (stop < to)
1584 from = stop, from_byte = stop_byte;
1585 stop = to, stop_byte = CHAR_TO_BYTE (stop);
1587 else
1588 break;
1591 val = Qnil;
1592 for (i = charset_table_used - 1; i >= 0; i--)
1593 if (!NILP (AREF (charsets, i)))
1594 val = Fcons (CHARSET_NAME (charset_table + i), val);
1595 return val;
1598 DEFUN ("find-charset-string", Ffind_charset_string, Sfind_charset_string,
1599 1, 2, 0,
1600 doc: /* Return a list of charsets in STR.
1601 Optional arg TABLE if non-nil is a translation table to look up.
1603 If STR is unibyte, the returned list may contain
1604 only `ascii', `eight-bit-control', and `eight-bit-graphic'. */)
1605 (Lisp_Object str, Lisp_Object table)
1607 Lisp_Object charsets;
1608 int i;
1609 Lisp_Object val;
1611 CHECK_STRING (str);
1613 charsets = Fmake_vector (make_number (charset_table_used), Qnil);
1614 find_charsets_in_text (SDATA (str), SCHARS (str), SBYTES (str),
1615 charsets, table,
1616 STRING_MULTIBYTE (str));
1617 val = Qnil;
1618 for (i = charset_table_used - 1; i >= 0; i--)
1619 if (!NILP (AREF (charsets, i)))
1620 val = Fcons (CHARSET_NAME (charset_table + i), val);
1621 return val;
1626 /* Return a unified character code for C (>= 0x110000). VAL is a
1627 value of Vchar_unify_table for C; i.e. it is nil, an integer, or a
1628 charset symbol. */
1629 static int
1630 maybe_unify_char (int c, Lisp_Object val)
1632 struct charset *charset;
1634 if (INTEGERP (val))
1635 return XFASTINT (val);
1636 if (NILP (val))
1637 return c;
1639 CHECK_CHARSET_GET_CHARSET (val, charset);
1640 #ifdef REL_ALLOC
1641 /* The call to load_charset below can allocate memory, which screws
1642 callers of this function through STRING_CHAR_* macros that hold C
1643 pointers to buffer text, if REL_ALLOC is used. */
1644 r_alloc_inhibit_buffer_relocation (1);
1645 #endif
1646 load_charset (charset, 1);
1647 if (! inhibit_load_charset_map)
1649 val = CHAR_TABLE_REF (Vchar_unify_table, c);
1650 if (! NILP (val))
1651 c = XFASTINT (val);
1653 else
1655 int code_index = c - CHARSET_CODE_OFFSET (charset);
1656 int unified = GET_TEMP_CHARSET_WORK_DECODER (code_index);
1658 if (unified > 0)
1659 c = unified;
1661 #ifdef REL_ALLOC
1662 r_alloc_inhibit_buffer_relocation (0);
1663 #endif
1664 return c;
1668 /* Return a character corresponding to the code-point CODE of
1669 CHARSET. */
1672 decode_char (struct charset *charset, unsigned int code)
1674 int c, char_index;
1675 enum charset_method method = CHARSET_METHOD (charset);
1677 if (code < CHARSET_MIN_CODE (charset) || code > CHARSET_MAX_CODE (charset))
1678 return -1;
1680 if (method == CHARSET_METHOD_SUBSET)
1682 Lisp_Object subset_info;
1684 subset_info = CHARSET_SUBSET (charset);
1685 charset = CHARSET_FROM_ID (XFASTINT (AREF (subset_info, 0)));
1686 code -= XINT (AREF (subset_info, 3));
1687 if (code < XFASTINT (AREF (subset_info, 1))
1688 || code > XFASTINT (AREF (subset_info, 2)))
1689 c = -1;
1690 else
1691 c = DECODE_CHAR (charset, code);
1693 else if (method == CHARSET_METHOD_SUPERSET)
1695 Lisp_Object parents;
1697 parents = CHARSET_SUPERSET (charset);
1698 c = -1;
1699 for (; CONSP (parents); parents = XCDR (parents))
1701 int id = XINT (XCAR (XCAR (parents)));
1702 int code_offset = XINT (XCDR (XCAR (parents)));
1703 unsigned this_code = code - code_offset;
1705 charset = CHARSET_FROM_ID (id);
1706 if ((c = DECODE_CHAR (charset, this_code)) >= 0)
1707 break;
1710 else
1712 char_index = CODE_POINT_TO_INDEX (charset, code);
1713 if (char_index < 0)
1714 return -1;
1716 if (method == CHARSET_METHOD_MAP)
1718 Lisp_Object decoder;
1720 decoder = CHARSET_DECODER (charset);
1721 if (! VECTORP (decoder))
1723 load_charset (charset, 1);
1724 decoder = CHARSET_DECODER (charset);
1726 if (VECTORP (decoder))
1727 c = XINT (AREF (decoder, char_index));
1728 else
1729 c = GET_TEMP_CHARSET_WORK_DECODER (char_index);
1731 else /* method == CHARSET_METHOD_OFFSET */
1733 c = char_index + CHARSET_CODE_OFFSET (charset);
1734 if (CHARSET_UNIFIED_P (charset)
1735 && MAX_UNICODE_CHAR < c && c <= MAX_5_BYTE_CHAR)
1737 /* Unify C with a Unicode character if possible. */
1738 Lisp_Object val = CHAR_TABLE_REF (Vchar_unify_table, c);
1739 c = maybe_unify_char (c, val);
1744 return c;
1747 /* Variable used temporarily by the macro ENCODE_CHAR. */
1748 Lisp_Object charset_work;
1750 /* Return a code-point of C in CHARSET. If C doesn't belong to
1751 CHARSET, return CHARSET_INVALID_CODE (CHARSET). If STRICT is true,
1752 use CHARSET's strict_max_char instead of max_char. */
1754 unsigned
1755 encode_char (struct charset *charset, int c)
1757 unsigned code;
1758 enum charset_method method = CHARSET_METHOD (charset);
1760 if (CHARSET_UNIFIED_P (charset))
1762 Lisp_Object deunifier;
1763 int code_index = -1;
1765 deunifier = CHARSET_DEUNIFIER (charset);
1766 if (! CHAR_TABLE_P (deunifier))
1768 load_charset (charset, 2);
1769 deunifier = CHARSET_DEUNIFIER (charset);
1771 if (CHAR_TABLE_P (deunifier))
1773 Lisp_Object deunified = CHAR_TABLE_REF (deunifier, c);
1775 if (INTEGERP (deunified))
1776 code_index = XINT (deunified);
1778 else
1780 code_index = GET_TEMP_CHARSET_WORK_ENCODER (c);
1782 if (code_index >= 0)
1783 c = CHARSET_CODE_OFFSET (charset) + code_index;
1786 if (method == CHARSET_METHOD_SUBSET)
1788 Lisp_Object subset_info;
1789 struct charset *this_charset;
1791 subset_info = CHARSET_SUBSET (charset);
1792 this_charset = CHARSET_FROM_ID (XFASTINT (AREF (subset_info, 0)));
1793 code = ENCODE_CHAR (this_charset, c);
1794 if (code == CHARSET_INVALID_CODE (this_charset)
1795 || code < XFASTINT (AREF (subset_info, 1))
1796 || code > XFASTINT (AREF (subset_info, 2)))
1797 return CHARSET_INVALID_CODE (charset);
1798 code += XINT (AREF (subset_info, 3));
1799 return code;
1802 if (method == CHARSET_METHOD_SUPERSET)
1804 Lisp_Object parents;
1806 parents = CHARSET_SUPERSET (charset);
1807 for (; CONSP (parents); parents = XCDR (parents))
1809 int id = XINT (XCAR (XCAR (parents)));
1810 int code_offset = XINT (XCDR (XCAR (parents)));
1811 struct charset *this_charset = CHARSET_FROM_ID (id);
1813 code = ENCODE_CHAR (this_charset, c);
1814 if (code != CHARSET_INVALID_CODE (this_charset))
1815 return code + code_offset;
1817 return CHARSET_INVALID_CODE (charset);
1820 if (! CHARSET_FAST_MAP_REF ((c), charset->fast_map)
1821 || c < CHARSET_MIN_CHAR (charset) || c > CHARSET_MAX_CHAR (charset))
1822 return CHARSET_INVALID_CODE (charset);
1824 if (method == CHARSET_METHOD_MAP)
1826 Lisp_Object encoder;
1827 Lisp_Object val;
1829 encoder = CHARSET_ENCODER (charset);
1830 if (! CHAR_TABLE_P (CHARSET_ENCODER (charset)))
1832 load_charset (charset, 2);
1833 encoder = CHARSET_ENCODER (charset);
1835 if (CHAR_TABLE_P (encoder))
1837 val = CHAR_TABLE_REF (encoder, c);
1838 if (NILP (val))
1839 return CHARSET_INVALID_CODE (charset);
1840 code = XINT (val);
1841 if (! CHARSET_COMPACT_CODES_P (charset))
1842 code = INDEX_TO_CODE_POINT (charset, code);
1844 else
1846 code = GET_TEMP_CHARSET_WORK_ENCODER (c);
1847 code = INDEX_TO_CODE_POINT (charset, code);
1850 else /* method == CHARSET_METHOD_OFFSET */
1852 unsigned code_index = c - CHARSET_CODE_OFFSET (charset);
1854 code = INDEX_TO_CODE_POINT (charset, code_index);
1857 return code;
1861 DEFUN ("decode-char", Fdecode_char, Sdecode_char, 2, 3, 0,
1862 doc: /* Decode the pair of CHARSET and CODE-POINT into a character.
1863 Return nil if CODE-POINT is not valid in CHARSET.
1865 CODE-POINT may be a cons (HIGHER-16-BIT-VALUE . LOWER-16-BIT-VALUE). */)
1866 (Lisp_Object charset, Lisp_Object code_point, Lisp_Object restriction)
1868 int c, id;
1869 unsigned code;
1870 struct charset *charsetp;
1872 CHECK_CHARSET_GET_ID (charset, id);
1873 code = cons_to_unsigned (code_point, UINT_MAX);
1874 charsetp = CHARSET_FROM_ID (id);
1875 c = DECODE_CHAR (charsetp, code);
1876 return (c >= 0 ? make_number (c) : Qnil);
1880 DEFUN ("encode-char", Fencode_char, Sencode_char, 2, 3, 0,
1881 doc: /* Encode the character CH into a code-point of CHARSET.
1882 Return nil if CHARSET doesn't include CH. */)
1883 (Lisp_Object ch, Lisp_Object charset, Lisp_Object restriction)
1885 int c, id;
1886 unsigned code;
1887 struct charset *charsetp;
1889 CHECK_CHARSET_GET_ID (charset, id);
1890 CHECK_CHARACTER (ch);
1891 c = XFASTINT (ch);
1892 charsetp = CHARSET_FROM_ID (id);
1893 code = ENCODE_CHAR (charsetp, c);
1894 if (code == CHARSET_INVALID_CODE (charsetp))
1895 return Qnil;
1896 return INTEGER_TO_CONS (code);
1900 DEFUN ("make-char", Fmake_char, Smake_char, 1, 5, 0,
1901 doc:
1902 /* Return a character of CHARSET whose position codes are CODEn.
1904 CODE1 through CODE4 are optional, but if you don't supply sufficient
1905 position codes, it is assumed that the minimum code in each dimension
1906 is specified. */)
1907 (Lisp_Object charset, Lisp_Object code1, Lisp_Object code2, Lisp_Object code3, Lisp_Object code4)
1909 int id, dimension;
1910 struct charset *charsetp;
1911 unsigned code;
1912 int c;
1914 CHECK_CHARSET_GET_ID (charset, id);
1915 charsetp = CHARSET_FROM_ID (id);
1917 dimension = CHARSET_DIMENSION (charsetp);
1918 if (NILP (code1))
1919 code = (CHARSET_ASCII_COMPATIBLE_P (charsetp)
1920 ? 0 : CHARSET_MIN_CODE (charsetp));
1921 else
1923 CHECK_NATNUM (code1);
1924 if (XFASTINT (code1) >= 0x100)
1925 args_out_of_range (make_number (0xFF), code1);
1926 code = XFASTINT (code1);
1928 if (dimension > 1)
1930 code <<= 8;
1931 if (NILP (code2))
1932 code |= charsetp->code_space[(dimension - 2) * 4];
1933 else
1935 CHECK_NATNUM (code2);
1936 if (XFASTINT (code2) >= 0x100)
1937 args_out_of_range (make_number (0xFF), code2);
1938 code |= XFASTINT (code2);
1941 if (dimension > 2)
1943 code <<= 8;
1944 if (NILP (code3))
1945 code |= charsetp->code_space[(dimension - 3) * 4];
1946 else
1948 CHECK_NATNUM (code3);
1949 if (XFASTINT (code3) >= 0x100)
1950 args_out_of_range (make_number (0xFF), code3);
1951 code |= XFASTINT (code3);
1954 if (dimension > 3)
1956 code <<= 8;
1957 if (NILP (code4))
1958 code |= charsetp->code_space[0];
1959 else
1961 CHECK_NATNUM (code4);
1962 if (XFASTINT (code4) >= 0x100)
1963 args_out_of_range (make_number (0xFF), code4);
1964 code |= XFASTINT (code4);
1971 if (CHARSET_ISO_FINAL (charsetp) >= 0)
1972 code &= 0x7F7F7F7F;
1973 c = DECODE_CHAR (charsetp, code);
1974 if (c < 0)
1975 error ("Invalid code(s)");
1976 return make_number (c);
1980 /* Return the first charset in CHARSET_LIST that contains C.
1981 CHARSET_LIST is a list of charset IDs. If it is nil, use
1982 Vcharset_ordered_list. */
1984 struct charset *
1985 char_charset (int c, Lisp_Object charset_list, unsigned int *code_return)
1987 bool maybe_null = 0;
1989 if (NILP (charset_list))
1990 charset_list = Vcharset_ordered_list;
1991 else
1992 maybe_null = 1;
1994 while (CONSP (charset_list))
1996 struct charset *charset = CHARSET_FROM_ID (XINT (XCAR (charset_list)));
1997 unsigned code = ENCODE_CHAR (charset, c);
1999 if (code != CHARSET_INVALID_CODE (charset))
2001 if (code_return)
2002 *code_return = code;
2003 return charset;
2005 charset_list = XCDR (charset_list);
2006 if (! maybe_null
2007 && c <= MAX_UNICODE_CHAR
2008 && EQ (charset_list, Vcharset_non_preferred_head))
2009 return CHARSET_FROM_ID (charset_unicode);
2011 return (maybe_null ? NULL
2012 : c <= MAX_5_BYTE_CHAR ? CHARSET_FROM_ID (charset_emacs)
2013 : CHARSET_FROM_ID (charset_eight_bit));
2017 DEFUN ("split-char", Fsplit_char, Ssplit_char, 1, 1, 0,
2018 doc:
2019 /*Return list of charset and one to four position-codes of CH.
2020 The charset is decided by the current priority order of charsets.
2021 A position-code is a byte value of each dimension of the code-point of
2022 CH in the charset. */)
2023 (Lisp_Object ch)
2025 struct charset *charset;
2026 int c, dimension;
2027 unsigned code;
2028 Lisp_Object val;
2030 CHECK_CHARACTER (ch);
2031 c = XFASTINT (ch);
2032 charset = CHAR_CHARSET (c);
2033 if (! charset)
2034 emacs_abort ();
2035 code = ENCODE_CHAR (charset, c);
2036 if (code == CHARSET_INVALID_CODE (charset))
2037 emacs_abort ();
2038 dimension = CHARSET_DIMENSION (charset);
2039 for (val = Qnil; dimension > 0; dimension--)
2041 val = Fcons (make_number (code & 0xFF), val);
2042 code >>= 8;
2044 return Fcons (CHARSET_NAME (charset), val);
2048 DEFUN ("char-charset", Fchar_charset, Schar_charset, 1, 2, 0,
2049 doc: /* Return the charset of highest priority that contains CH.
2050 ASCII characters are an exception: for them, this function always
2051 returns `ascii'.
2052 If optional 2nd arg RESTRICTION is non-nil, it is a list of charsets
2053 from which to find the charset. It may also be a coding system. In
2054 that case, find the charset from what supported by that coding system. */)
2055 (Lisp_Object ch, Lisp_Object restriction)
2057 struct charset *charset;
2059 CHECK_CHARACTER (ch);
2060 if (NILP (restriction))
2061 charset = CHAR_CHARSET (XINT (ch));
2062 else
2064 if (CONSP (restriction))
2066 int c = XFASTINT (ch);
2068 for (; CONSP (restriction); restriction = XCDR (restriction))
2070 struct charset *rcharset;
2072 CHECK_CHARSET_GET_CHARSET (XCAR (restriction), rcharset);
2073 if (ENCODE_CHAR (rcharset, c) != CHARSET_INVALID_CODE (rcharset))
2074 return XCAR (restriction);
2076 return Qnil;
2078 restriction = coding_system_charset_list (restriction);
2079 charset = char_charset (XINT (ch), restriction, NULL);
2080 if (! charset)
2081 return Qnil;
2083 return (CHARSET_NAME (charset));
2087 DEFUN ("charset-after", Fcharset_after, Scharset_after, 0, 1, 0,
2088 doc: /*
2089 Return charset of a character in the current buffer at position POS.
2090 If POS is nil, it defaults to the current point.
2091 If POS is out of range, the value is nil. */)
2092 (Lisp_Object pos)
2094 Lisp_Object ch;
2095 struct charset *charset;
2097 ch = Fchar_after (pos);
2098 if (! INTEGERP (ch))
2099 return ch;
2100 charset = CHAR_CHARSET (XINT (ch));
2101 return (CHARSET_NAME (charset));
2105 DEFUN ("iso-charset", Fiso_charset, Siso_charset, 3, 3, 0,
2106 doc: /*
2107 Return charset of ISO's specification DIMENSION, CHARS, and FINAL-CHAR.
2109 ISO 2022's designation sequence (escape sequence) distinguishes charsets
2110 by their DIMENSION, CHARS, and FINAL-CHAR,
2111 whereas Emacs distinguishes them by charset symbol.
2112 See the documentation of the function `charset-info' for the meanings of
2113 DIMENSION, CHARS, and FINAL-CHAR. */)
2114 (Lisp_Object dimension, Lisp_Object chars, Lisp_Object final_char)
2116 int id;
2117 bool chars_flag;
2119 check_iso_charset_parameter (dimension, chars, final_char);
2120 chars_flag = XFASTINT (chars) == 96;
2121 id = ISO_CHARSET_TABLE (XFASTINT (dimension), chars_flag,
2122 XFASTINT (final_char));
2123 return (id >= 0 ? CHARSET_NAME (CHARSET_FROM_ID (id)) : Qnil);
2127 DEFUN ("clear-charset-maps", Fclear_charset_maps, Sclear_charset_maps,
2128 0, 0, 0,
2129 doc: /*
2130 Internal use only.
2131 Clear temporary charset mapping tables.
2132 It should be called only from temacs invoked for dumping. */)
2133 (void)
2135 if (temp_charset_work)
2137 xfree (temp_charset_work);
2138 temp_charset_work = NULL;
2141 if (CHAR_TABLE_P (Vchar_unify_table))
2142 Foptimize_char_table (Vchar_unify_table, Qnil);
2144 return Qnil;
2147 DEFUN ("charset-priority-list", Fcharset_priority_list,
2148 Scharset_priority_list, 0, 1, 0,
2149 doc: /* Return the list of charsets ordered by priority.
2150 HIGHESTP non-nil means just return the highest priority one. */)
2151 (Lisp_Object highestp)
2153 Lisp_Object val = Qnil, list = Vcharset_ordered_list;
2155 if (!NILP (highestp))
2156 return CHARSET_NAME (CHARSET_FROM_ID (XINT (Fcar (list))));
2158 while (!NILP (list))
2160 val = Fcons (CHARSET_NAME (CHARSET_FROM_ID (XINT (XCAR (list)))), val);
2161 list = XCDR (list);
2163 return Fnreverse (val);
2166 DEFUN ("set-charset-priority", Fset_charset_priority, Sset_charset_priority,
2167 1, MANY, 0,
2168 doc: /* Assign higher priority to the charsets given as arguments.
2169 usage: (set-charset-priority &rest charsets) */)
2170 (ptrdiff_t nargs, Lisp_Object *args)
2172 Lisp_Object new_head, old_list, arglist[2];
2173 Lisp_Object list_2022, list_emacs_mule;
2174 ptrdiff_t i;
2175 int id;
2177 old_list = Fcopy_sequence (Vcharset_ordered_list);
2178 new_head = Qnil;
2179 for (i = 0; i < nargs; i++)
2181 CHECK_CHARSET_GET_ID (args[i], id);
2182 if (! NILP (Fmemq (make_number (id), old_list)))
2184 old_list = Fdelq (make_number (id), old_list);
2185 new_head = Fcons (make_number (id), new_head);
2188 arglist[0] = Fnreverse (new_head);
2189 arglist[1] = Vcharset_non_preferred_head = old_list;
2190 Vcharset_ordered_list = Fnconc (2, arglist);
2191 charset_ordered_list_tick++;
2193 charset_unibyte = -1;
2194 for (old_list = Vcharset_ordered_list, list_2022 = list_emacs_mule = Qnil;
2195 CONSP (old_list); old_list = XCDR (old_list))
2197 if (! NILP (Fmemq (XCAR (old_list), Viso_2022_charset_list)))
2198 list_2022 = Fcons (XCAR (old_list), list_2022);
2199 if (! NILP (Fmemq (XCAR (old_list), Vemacs_mule_charset_list)))
2200 list_emacs_mule = Fcons (XCAR (old_list), list_emacs_mule);
2201 if (charset_unibyte < 0)
2203 struct charset *charset = CHARSET_FROM_ID (XINT (XCAR (old_list)));
2205 if (CHARSET_DIMENSION (charset) == 1
2206 && CHARSET_ASCII_COMPATIBLE_P (charset)
2207 && CHARSET_MAX_CHAR (charset) >= 0x80)
2208 charset_unibyte = CHARSET_ID (charset);
2211 Viso_2022_charset_list = Fnreverse (list_2022);
2212 Vemacs_mule_charset_list = Fnreverse (list_emacs_mule);
2213 if (charset_unibyte < 0)
2214 charset_unibyte = charset_iso_8859_1;
2216 return Qnil;
2219 DEFUN ("charset-id-internal", Fcharset_id_internal, Scharset_id_internal,
2220 0, 1, 0,
2221 doc: /* Internal use only.
2222 Return charset identification number of CHARSET. */)
2223 (Lisp_Object charset)
2225 int id;
2227 CHECK_CHARSET_GET_ID (charset, id);
2228 return make_number (id);
2231 struct charset_sort_data
2233 Lisp_Object charset;
2234 int id;
2235 ptrdiff_t priority;
2238 static int
2239 charset_compare (const void *d1, const void *d2)
2241 const struct charset_sort_data *data1 = d1, *data2 = d2;
2242 if (data1->priority != data2->priority)
2243 return data1->priority < data2->priority ? -1 : 1;
2244 return 0;
2247 DEFUN ("sort-charsets", Fsort_charsets, Ssort_charsets, 1, 1, 0,
2248 doc: /* Sort charset list CHARSETS by a priority of each charset.
2249 Return the sorted list. CHARSETS is modified by side effects.
2250 See also `charset-priority-list' and `set-charset-priority'. */)
2251 (Lisp_Object charsets)
2253 Lisp_Object len = Flength (charsets);
2254 ptrdiff_t n = XFASTINT (len), i, j;
2255 int done;
2256 Lisp_Object tail, elt, attrs;
2257 struct charset_sort_data *sort_data;
2258 int id, min_id = INT_MAX, max_id = INT_MIN;
2259 USE_SAFE_ALLOCA;
2261 if (n == 0)
2262 return Qnil;
2263 SAFE_NALLOCA (sort_data, 1, n);
2264 for (tail = charsets, i = 0; CONSP (tail); tail = XCDR (tail), i++)
2266 elt = XCAR (tail);
2267 CHECK_CHARSET_GET_ATTR (elt, attrs);
2268 sort_data[i].charset = elt;
2269 sort_data[i].id = id = XINT (CHARSET_ATTR_ID (attrs));
2270 if (id < min_id)
2271 min_id = id;
2272 if (id > max_id)
2273 max_id = id;
2275 for (done = 0, tail = Vcharset_ordered_list, i = 0;
2276 done < n && CONSP (tail); tail = XCDR (tail), i++)
2278 elt = XCAR (tail);
2279 id = XFASTINT (elt);
2280 if (id >= min_id && id <= max_id)
2281 for (j = 0; j < n; j++)
2282 if (sort_data[j].id == id)
2284 sort_data[j].priority = i;
2285 done++;
2288 qsort (sort_data, n, sizeof *sort_data, charset_compare);
2289 for (i = 0, tail = charsets; CONSP (tail); tail = XCDR (tail), i++)
2290 XSETCAR (tail, sort_data[i].charset);
2291 SAFE_FREE ();
2292 return charsets;
2296 void
2297 init_charset (void)
2299 Lisp_Object tempdir;
2300 tempdir = Fexpand_file_name (build_string ("charsets"), Vdata_directory);
2301 if (! file_accessible_directory_p (SSDATA (tempdir)))
2303 /* This used to be non-fatal (dir_warning), but it should not
2304 happen, and if it does sooner or later it will cause some
2305 obscure problem (eg bug#6401), so better abort. */
2306 fprintf (stderr, "Error: charsets directory not found:\n\
2307 %s\n\
2308 Emacs will not function correctly without the character map files.\n%s\
2309 Please check your installation!\n",
2310 SDATA (tempdir),
2311 egetenv("EMACSDATA") ? "The EMACSDATA environment \
2312 variable is set, maybe it has the wrong value?\n" : "");
2313 exit (1);
2316 Vcharset_map_path = list1 (tempdir);
2320 void
2321 init_charset_once (void)
2323 int i, j, k;
2325 for (i = 0; i < ISO_MAX_DIMENSION; i++)
2326 for (j = 0; j < ISO_MAX_CHARS; j++)
2327 for (k = 0; k < ISO_MAX_FINAL; k++)
2328 iso_charset_table[i][j][k] = -1;
2330 for (i = 0; i < 256; i++)
2331 emacs_mule_charset[i] = -1;
2333 charset_jisx0201_roman = -1;
2334 charset_jisx0208_1978 = -1;
2335 charset_jisx0208 = -1;
2336 charset_ksc5601 = -1;
2339 #ifdef emacs
2341 /* Allocate an initial charset table that is large enough to handle
2342 Emacs while it is bootstrapping. As of September 2011, the size
2343 needs to be at least 166; make it a bit bigger to allow for future
2344 expansion.
2346 Don't make the value so small that the table is reallocated during
2347 bootstrapping, as glibc malloc calls larger than just under 64 KiB
2348 during an initial bootstrap wreak havoc after dumping; see the
2349 M_MMAP_THRESHOLD value in alloc.c, plus there is a extra overhead
2350 internal to glibc malloc and perhaps to Emacs malloc debugging. */
2351 static struct charset charset_table_init[180];
2353 void
2354 syms_of_charset (void)
2356 DEFSYM (Qcharsetp, "charsetp");
2358 DEFSYM (Qascii, "ascii");
2359 DEFSYM (Qunicode, "unicode");
2360 DEFSYM (Qemacs, "emacs");
2361 DEFSYM (Qeight_bit, "eight-bit");
2362 DEFSYM (Qiso_8859_1, "iso-8859-1");
2364 DEFSYM (Qgl, "gl");
2365 DEFSYM (Qgr, "gr");
2367 staticpro (&Vcharset_ordered_list);
2368 Vcharset_ordered_list = Qnil;
2370 staticpro (&Viso_2022_charset_list);
2371 Viso_2022_charset_list = Qnil;
2373 staticpro (&Vemacs_mule_charset_list);
2374 Vemacs_mule_charset_list = Qnil;
2376 /* Don't staticpro them here. It's done in syms_of_fns. */
2377 QCtest = intern_c_string (":test");
2378 Qeq = intern_c_string ("eq");
2380 staticpro (&Vcharset_hash_table);
2382 Lisp_Object args[2];
2383 args[0] = QCtest;
2384 args[1] = Qeq;
2385 Vcharset_hash_table = Fmake_hash_table (2, args);
2388 charset_table = charset_table_init;
2389 charset_table_size = sizeof charset_table_init / sizeof *charset_table_init;
2390 charset_table_used = 0;
2392 defsubr (&Scharsetp);
2393 defsubr (&Smap_charset_chars);
2394 defsubr (&Sdefine_charset_internal);
2395 defsubr (&Sdefine_charset_alias);
2396 defsubr (&Scharset_plist);
2397 defsubr (&Sset_charset_plist);
2398 defsubr (&Sunify_charset);
2399 defsubr (&Sget_unused_iso_final_char);
2400 defsubr (&Sdeclare_equiv_charset);
2401 defsubr (&Sfind_charset_region);
2402 defsubr (&Sfind_charset_string);
2403 defsubr (&Sdecode_char);
2404 defsubr (&Sencode_char);
2405 defsubr (&Ssplit_char);
2406 defsubr (&Smake_char);
2407 defsubr (&Schar_charset);
2408 defsubr (&Scharset_after);
2409 defsubr (&Siso_charset);
2410 defsubr (&Sclear_charset_maps);
2411 defsubr (&Scharset_priority_list);
2412 defsubr (&Sset_charset_priority);
2413 defsubr (&Scharset_id_internal);
2414 defsubr (&Ssort_charsets);
2416 DEFVAR_LISP ("charset-map-path", Vcharset_map_path,
2417 doc: /* List of directories to search for charset map files. */);
2418 Vcharset_map_path = Qnil;
2420 DEFVAR_BOOL ("inhibit-load-charset-map", inhibit_load_charset_map,
2421 doc: /* Inhibit loading of charset maps. Used when dumping Emacs. */);
2422 inhibit_load_charset_map = 0;
2424 DEFVAR_LISP ("charset-list", Vcharset_list,
2425 doc: /* List of all charsets ever defined. */);
2426 Vcharset_list = Qnil;
2428 DEFVAR_LISP ("current-iso639-language", Vcurrent_iso639_language,
2429 doc: /* ISO639 language mnemonic symbol for the current language environment.
2430 If the current language environment is for multiple languages (e.g. "Latin-1"),
2431 the value may be a list of mnemonics. */);
2432 Vcurrent_iso639_language = Qnil;
2434 charset_ascii
2435 = define_charset_internal (Qascii, 1, "\x00\x7F\0\0\0\0\0",
2436 0, 127, 'B', -1, 0, 1, 0, 0);
2437 charset_iso_8859_1
2438 = define_charset_internal (Qiso_8859_1, 1, "\x00\xFF\0\0\0\0\0",
2439 0, 255, -1, -1, -1, 1, 0, 0);
2440 charset_unicode
2441 = define_charset_internal (Qunicode, 3, "\x00\xFF\x00\xFF\x00\x10\0",
2442 0, MAX_UNICODE_CHAR, -1, 0, -1, 1, 0, 0);
2443 charset_emacs
2444 = define_charset_internal (Qemacs, 3, "\x00\xFF\x00\xFF\x00\x3F\0",
2445 0, MAX_5_BYTE_CHAR, -1, 0, -1, 1, 1, 0);
2446 charset_eight_bit
2447 = define_charset_internal (Qeight_bit, 1, "\x80\xFF\0\0\0\0\0",
2448 128, 255, -1, 0, -1, 0, 1,
2449 MAX_5_BYTE_CHAR + 1);
2450 charset_unibyte = charset_iso_8859_1;
2453 #endif /* emacs */