XEmacs 21.2.28 "Hermes".
[chise/xemacs-chise.git.1] / src / file-coding.c
1 /* Code conversion functions.
2    Copyright (C) 1991, 1995 Free Software Foundation, Inc.
3    Copyright (C) 1995 Sun Microsystems, Inc.
4
5 This file is part of XEmacs.
6
7 XEmacs is free software; you can redistribute it and/or modify it
8 under the terms of the GNU General Public License as published by the
9 Free Software Foundation; either version 2, or (at your option) any
10 later version.
11
12 XEmacs is distributed in the hope that it will be useful, but WITHOUT
13 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
15 for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with XEmacs; see the file COPYING.  If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA.  */
21
22 /* Synched up with: Mule 2.3.   Not in FSF. */
23
24 /* Rewritten by Ben Wing <ben@xemacs.org>. */
25
26 #include <config.h>
27 #include "lisp.h"
28
29 #include "buffer.h"
30 #include "elhash.h"
31 #include "insdel.h"
32 #include "lstream.h"
33 #include "opaque.h"
34 #ifdef MULE
35 #include "mule-ccl.h"
36 #include "chartab.h"
37 #endif
38 #include "file-coding.h"
39
40 Lisp_Object Qcoding_system_error;
41
42 Lisp_Object Vkeyboard_coding_system;
43 Lisp_Object Vterminal_coding_system;
44 Lisp_Object Vcoding_system_for_read;
45 Lisp_Object Vcoding_system_for_write;
46 Lisp_Object Vfile_name_coding_system;
47
48 /* Table of symbols identifying each coding category. */
49 Lisp_Object coding_category_symbol[CODING_CATEGORY_LAST + 1];
50
51
52
53 struct file_coding_dump {
54   /* Coding system currently associated with each coding category. */
55   Lisp_Object coding_category_system[CODING_CATEGORY_LAST + 1];
56
57   /* Table of all coding categories in decreasing order of priority.
58      This describes a permutation of the possible coding categories. */
59   int coding_category_by_priority[CODING_CATEGORY_LAST + 1];
60
61 #ifdef MULE
62   Lisp_Object ucs_to_mule_table[65536];
63 #endif
64 } *fcd;
65
66 static const struct lrecord_description fcd_description_1[] = {
67   { XD_LISP_OBJECT_ARRAY, offsetof (struct file_coding_dump, coding_category_system), CODING_CATEGORY_LAST + 1 },
68 #ifdef MULE
69   { XD_LISP_OBJECT_ARRAY, offsetof (struct file_coding_dump, ucs_to_mule_table), 65536 },
70 #endif
71   { XD_END }
72 };
73
74 static const struct struct_description fcd_description = {
75   sizeof (struct file_coding_dump),
76   fcd_description_1
77 };
78
79 Lisp_Object mule_to_ucs_table;
80
81 Lisp_Object Qcoding_systemp;
82
83 Lisp_Object Qraw_text, Qno_conversion, Qccl, Qiso2022;
84 /* Qinternal in general.c */
85
86 Lisp_Object Qmnemonic, Qeol_type;
87 Lisp_Object Qcr, Qcrlf, Qlf;
88 Lisp_Object Qeol_cr, Qeol_crlf, Qeol_lf;
89 Lisp_Object Qpost_read_conversion;
90 Lisp_Object Qpre_write_conversion;
91
92 #ifdef MULE
93 Lisp_Object Qucs4, Qutf8;
94 Lisp_Object Qbig5, Qshift_jis;
95 Lisp_Object Qcharset_g0, Qcharset_g1, Qcharset_g2, Qcharset_g3;
96 Lisp_Object Qforce_g0_on_output, Qforce_g1_on_output;
97 Lisp_Object Qforce_g2_on_output, Qforce_g3_on_output;
98 Lisp_Object Qno_iso6429;
99 Lisp_Object Qinput_charset_conversion, Qoutput_charset_conversion;
100 Lisp_Object Qescape_quoted;
101 Lisp_Object Qshort, Qno_ascii_eol, Qno_ascii_cntl, Qseven, Qlock_shift;
102 #endif
103 Lisp_Object Qencode, Qdecode;
104
105 Lisp_Object Vcoding_system_hash_table;
106
107 int enable_multibyte_characters;
108
109 #ifdef MULE
110 /* Additional information used by the ISO2022 decoder and detector. */
111 struct iso2022_decoder
112 {
113   /* CHARSET holds the character sets currently assigned to the G0
114      through G3 variables.  It is initialized from the array
115      INITIAL_CHARSET in CODESYS. */
116   Lisp_Object charset[4];
117
118   /* Which registers are currently invoked into the left (GL) and
119      right (GR) halves of the 8-bit encoding space? */
120   int register_left, register_right;
121
122   /* ISO_ESC holds a value indicating part of an escape sequence
123      that has already been seen. */
124   enum iso_esc_flag esc;
125
126   /* This records the bytes we've seen so far in an escape sequence,
127      in case the sequence is invalid (we spit out the bytes unchanged). */
128   unsigned char esc_bytes[8];
129
130   /* Index for next byte to store in ISO escape sequence. */
131   int esc_bytes_index;
132
133 #ifdef ENABLE_COMPOSITE_CHARS
134   /* Stuff seen so far when composing a string. */
135   unsigned_char_dynarr *composite_chars;
136 #endif
137
138   /* If we saw an invalid designation sequence for a particular
139      register, we flag it here and switch to ASCII.  The next time we
140      see a valid designation for this register, we turn off the flag
141      and do the designation normally, but pretend the sequence was
142      invalid.  The effect of all this is that (most of the time) the
143      escape sequences for both the switch to the unknown charset, and
144      the switch back to the known charset, get inserted literally into
145      the buffer and saved out as such.  The hope is that we can
146      preserve the escape sequences so that the resulting written out
147      file makes sense.  If we don't do any of this, the designation
148      to the invalid charset will be preserved but that switch back
149      to the known charset will probably get eaten because it was
150      the same charset that was already present in the register. */
151   unsigned char invalid_designated[4];
152
153   /* We try to do similar things as above for direction-switching
154      sequences.  If we encountered a direction switch while an
155      invalid designation was present, or an invalid designation
156      just after a direction switch (i.e. no valid designation
157      encountered yet), we insert the direction-switch escape
158      sequence literally into the output stream, and later on
159      insert the corresponding direction-restoring escape sequence
160      literally also. */
161   unsigned int switched_dir_and_no_valid_charset_yet :1;
162   unsigned int invalid_switch_dir :1;
163
164   /* Tells the decoder to output the escape sequence literally
165      even though it was valid.  Used in the games we play to
166      avoid lossage when we encounter invalid designations. */
167   unsigned int output_literally :1;
168   /* We encountered a direction switch followed by an invalid
169      designation.  We didn't output the direction switch
170      literally because we didn't know about the invalid designation;
171      but we have to do so now. */
172   unsigned int output_direction_sequence :1;
173 };
174 #endif /* MULE */
175 EXFUN (Fcopy_coding_system, 2);
176 #ifdef MULE
177 struct detection_state;
178 static int detect_coding_sjis (struct detection_state *st,
179                                CONST unsigned char *src,
180                                unsigned int n);
181 static void decode_coding_sjis (Lstream *decoding,
182                                 CONST unsigned char *src,
183                                 unsigned_char_dynarr *dst,
184                                 unsigned int n);
185 static void encode_coding_sjis (Lstream *encoding,
186                                 CONST unsigned char *src,
187                                 unsigned_char_dynarr *dst,
188                                 unsigned int n);
189 static int detect_coding_big5 (struct detection_state *st,
190                                CONST unsigned char *src,
191                                unsigned int n);
192 static void decode_coding_big5 (Lstream *decoding,
193                                 CONST unsigned char *src,
194                                 unsigned_char_dynarr *dst, unsigned int n);
195 static void encode_coding_big5 (Lstream *encoding,
196                                 CONST unsigned char *src,
197                                 unsigned_char_dynarr *dst, unsigned int n);
198 static int detect_coding_ucs4 (struct detection_state *st,
199                                CONST unsigned char *src,
200                                unsigned int n);
201 static void decode_coding_ucs4 (Lstream *decoding,
202                                 CONST unsigned char *src,
203                                 unsigned_char_dynarr *dst, unsigned int n);
204 static void encode_coding_ucs4 (Lstream *encoding,
205                                 CONST unsigned char *src,
206                                 unsigned_char_dynarr *dst, unsigned int n);
207 static int detect_coding_utf8 (struct detection_state *st,
208                                CONST unsigned char *src,
209                                unsigned int n);
210 static void decode_coding_utf8 (Lstream *decoding,
211                                 CONST unsigned char *src,
212                                 unsigned_char_dynarr *dst, unsigned int n);
213 static void encode_coding_utf8 (Lstream *encoding,
214                                 CONST unsigned char *src,
215                                 unsigned_char_dynarr *dst, unsigned int n);
216 static int postprocess_iso2022_mask (int mask);
217 static void reset_iso2022 (Lisp_Object coding_system,
218                            struct iso2022_decoder *iso);
219 static int detect_coding_iso2022 (struct detection_state *st,
220                                   CONST unsigned char *src,
221                                   unsigned int n);
222 static void decode_coding_iso2022 (Lstream *decoding,
223                                    CONST unsigned char *src,
224                                    unsigned_char_dynarr *dst, unsigned int n);
225 static void encode_coding_iso2022 (Lstream *encoding,
226                                    CONST unsigned char *src,
227                                    unsigned_char_dynarr *dst, unsigned int n);
228 #endif /* MULE */
229 static void decode_coding_no_conversion (Lstream *decoding,
230                                          CONST unsigned char *src,
231                                          unsigned_char_dynarr *dst,
232                                          unsigned int n);
233 static void encode_coding_no_conversion (Lstream *encoding,
234                                          CONST unsigned char *src,
235                                          unsigned_char_dynarr *dst,
236                                          unsigned int n);
237 static void mule_decode (Lstream *decoding, CONST unsigned char *src,
238                          unsigned_char_dynarr *dst, unsigned int n);
239 static void mule_encode (Lstream *encoding, CONST unsigned char *src,
240                          unsigned_char_dynarr *dst, unsigned int n);
241
242 typedef struct codesys_prop codesys_prop;
243 struct codesys_prop
244 {
245   Lisp_Object sym;
246   int prop_type;
247 };
248
249 typedef struct
250 {
251   Dynarr_declare (codesys_prop);
252 } codesys_prop_dynarr;
253
254 static const struct lrecord_description codesys_prop_description_1[] = {
255   { XD_LISP_OBJECT, offsetof (codesys_prop, sym) },
256   { XD_END }
257 };
258
259 static const struct struct_description codesys_prop_description = {
260   sizeof (codesys_prop),
261   codesys_prop_description_1
262 };
263
264 static const struct lrecord_description codesys_prop_dynarr_description_1[] = {
265   XD_DYNARR_DESC (codesys_prop_dynarr, &codesys_prop_description),
266   { XD_END }
267 };
268
269 static const struct struct_description codesys_prop_dynarr_description = {
270   sizeof (codesys_prop_dynarr),
271   codesys_prop_dynarr_description_1
272 };
273
274 codesys_prop_dynarr *the_codesys_prop_dynarr;
275
276 enum codesys_prop_enum
277 {
278   CODESYS_PROP_ALL_OK,
279   CODESYS_PROP_ISO2022,
280   CODESYS_PROP_CCL
281 };
282
283 \f
284 /************************************************************************/
285 /*                       Coding system functions                        */
286 /************************************************************************/
287
288 static Lisp_Object mark_coding_system (Lisp_Object);
289 static void print_coding_system (Lisp_Object, Lisp_Object, int);
290 static void finalize_coding_system (void *header, int for_disksave);
291
292 #ifdef MULE
293 static const struct lrecord_description ccs_description_1[] = {
294   { XD_LISP_OBJECT, offsetof (charset_conversion_spec, from_charset) },
295   { XD_LISP_OBJECT, offsetof (charset_conversion_spec, to_charset) },
296   { XD_END }
297 };
298
299 static const struct struct_description ccs_description = {
300   sizeof (charset_conversion_spec),
301   ccs_description_1
302 };
303
304 static const struct lrecord_description ccsd_description_1[] = {
305   XD_DYNARR_DESC (charset_conversion_spec_dynarr, &ccs_description),
306   { XD_END }
307 };
308
309 static const struct struct_description ccsd_description = {
310   sizeof (charset_conversion_spec_dynarr),
311   ccsd_description_1
312 };
313 #endif
314
315 static const struct lrecord_description coding_system_description[] = {
316   { XD_LISP_OBJECT, offsetof (Lisp_Coding_System, name) },
317   { XD_LISP_OBJECT, offsetof (Lisp_Coding_System, doc_string) },
318   { XD_LISP_OBJECT, offsetof (Lisp_Coding_System, mnemonic) },
319   { XD_LISP_OBJECT, offsetof (Lisp_Coding_System, post_read_conversion) },
320   { XD_LISP_OBJECT, offsetof (Lisp_Coding_System, pre_write_conversion) },
321   { XD_LISP_OBJECT, offsetof (Lisp_Coding_System, eol_lf) },
322   { XD_LISP_OBJECT, offsetof (Lisp_Coding_System, eol_crlf) },
323   { XD_LISP_OBJECT, offsetof (Lisp_Coding_System, eol_cr) },
324 #ifdef MULE
325   { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Coding_System, iso2022.initial_charset), 4 },
326   { XD_STRUCT_PTR,  offsetof (Lisp_Coding_System, iso2022.input_conv),  1, &ccsd_description },
327   { XD_STRUCT_PTR,  offsetof (Lisp_Coding_System, iso2022.output_conv), 1, &ccsd_description },
328   { XD_LISP_OBJECT, offsetof (Lisp_Coding_System, ccl.decode) },
329   { XD_LISP_OBJECT, offsetof (Lisp_Coding_System, ccl.encode) },
330 #endif
331   { XD_END }
332 };
333
334 DEFINE_LRECORD_IMPLEMENTATION ("coding-system", coding_system,
335                                mark_coding_system, print_coding_system,
336                                finalize_coding_system,
337                                0, 0, coding_system_description,
338                                Lisp_Coding_System);
339
340 static Lisp_Object
341 mark_coding_system (Lisp_Object obj)
342 {
343   Lisp_Coding_System *codesys = XCODING_SYSTEM (obj);
344
345   mark_object (CODING_SYSTEM_NAME (codesys));
346   mark_object (CODING_SYSTEM_DOC_STRING (codesys));
347   mark_object (CODING_SYSTEM_MNEMONIC (codesys));
348   mark_object (CODING_SYSTEM_EOL_LF (codesys));
349   mark_object (CODING_SYSTEM_EOL_CRLF (codesys));
350   mark_object (CODING_SYSTEM_EOL_CR (codesys));
351
352   switch (CODING_SYSTEM_TYPE (codesys))
353     {
354 #ifdef MULE
355       int i;
356     case CODESYS_ISO2022:
357       for (i = 0; i < 4; i++)
358         mark_object (CODING_SYSTEM_ISO2022_INITIAL_CHARSET (codesys, i));
359       if (codesys->iso2022.input_conv)
360         {
361           for (i = 0; i < Dynarr_length (codesys->iso2022.input_conv); i++)
362             {
363               struct charset_conversion_spec *ccs =
364                 Dynarr_atp (codesys->iso2022.input_conv, i);
365               mark_object (ccs->from_charset);
366               mark_object (ccs->to_charset);
367             }
368         }
369       if (codesys->iso2022.output_conv)
370         {
371           for (i = 0; i < Dynarr_length (codesys->iso2022.output_conv); i++)
372             {
373               struct charset_conversion_spec *ccs =
374                 Dynarr_atp (codesys->iso2022.output_conv, i);
375               mark_object (ccs->from_charset);
376               mark_object (ccs->to_charset);
377             }
378         }
379       break;
380
381     case CODESYS_CCL:
382       mark_object (CODING_SYSTEM_CCL_DECODE (codesys));
383       mark_object (CODING_SYSTEM_CCL_ENCODE (codesys));
384       break;
385 #endif /* MULE */
386     default:
387       break;
388     }
389
390   mark_object (CODING_SYSTEM_PRE_WRITE_CONVERSION (codesys));
391   return CODING_SYSTEM_POST_READ_CONVERSION (codesys);
392 }
393
394 static void
395 print_coding_system (Lisp_Object obj, Lisp_Object printcharfun,
396                      int escapeflag)
397 {
398   Lisp_Coding_System *c = XCODING_SYSTEM (obj);
399   if (print_readably)
400     error ("printing unreadable object #<coding_system 0x%x>",
401            c->header.uid);
402
403   write_c_string ("#<coding_system ", printcharfun);
404   print_internal (c->name, printcharfun, 1);
405   write_c_string (">", printcharfun);
406 }
407
408 static void
409 finalize_coding_system (void *header, int for_disksave)
410 {
411   Lisp_Coding_System *c = (Lisp_Coding_System *) header;
412   /* Since coding systems never go away, this function is not
413      necessary.  But it would be necessary if we changed things
414      so that coding systems could go away. */
415   if (!for_disksave) /* see comment in lstream.c */
416     {
417       switch (CODING_SYSTEM_TYPE (c))
418         {
419 #ifdef MULE
420         case CODESYS_ISO2022:
421           if (c->iso2022.input_conv)
422             {
423               Dynarr_free (c->iso2022.input_conv);
424               c->iso2022.input_conv = 0;
425             }
426           if (c->iso2022.output_conv)
427             {
428               Dynarr_free (c->iso2022.output_conv);
429               c->iso2022.output_conv = 0;
430             }
431           break;
432 #endif /* MULE */
433         default:
434           break;
435         }
436     }
437 }
438
439 static eol_type_t
440 symbol_to_eol_type (Lisp_Object symbol)
441 {
442   CHECK_SYMBOL (symbol);
443   if (NILP (symbol))      return EOL_AUTODETECT;
444   if (EQ (symbol, Qlf))   return EOL_LF;
445   if (EQ (symbol, Qcrlf)) return EOL_CRLF;
446   if (EQ (symbol, Qcr))   return EOL_CR;
447
448   signal_simple_error ("Unrecognized eol type", symbol);
449   return EOL_AUTODETECT; /* not reached */
450 }
451
452 static Lisp_Object
453 eol_type_to_symbol (eol_type_t type)
454 {
455   switch (type)
456     {
457     default: abort ();
458     case EOL_LF:         return Qlf;
459     case EOL_CRLF:       return Qcrlf;
460     case EOL_CR:         return Qcr;
461     case EOL_AUTODETECT: return Qnil;
462     }
463 }
464
465 static void
466 setup_eol_coding_systems (Lisp_Coding_System *codesys)
467 {
468   Lisp_Object codesys_obj;
469   int len = string_length (XSYMBOL (CODING_SYSTEM_NAME (codesys))->name);
470   char *codesys_name = (char *) alloca (len + 7);
471   int mlen = -1;
472   char *codesys_mnemonic=0;
473
474   Lisp_Object codesys_name_sym, sub_codesys_obj;
475
476   /* kludge */
477
478   XSETCODING_SYSTEM (codesys_obj, codesys);
479
480   memcpy (codesys_name,
481           string_data (XSYMBOL (CODING_SYSTEM_NAME (codesys))->name), len);
482
483   if (STRINGP (CODING_SYSTEM_MNEMONIC (codesys)))
484     {
485       mlen = XSTRING_LENGTH (CODING_SYSTEM_MNEMONIC (codesys));
486       codesys_mnemonic = (char *) alloca (mlen + 7);
487       memcpy (codesys_mnemonic,
488               XSTRING_DATA (CODING_SYSTEM_MNEMONIC (codesys)), mlen);
489     }
490
491 #define DEFINE_SUB_CODESYS(op_sys, op_sys_abbr, Type) do {                      \
492   strcpy (codesys_name + len, "-" op_sys);                                      \
493   if (mlen != -1)                                                               \
494     strcpy (codesys_mnemonic + mlen, op_sys_abbr);                              \
495   codesys_name_sym = intern (codesys_name);                                     \
496   sub_codesys_obj = Fcopy_coding_system (codesys_obj, codesys_name_sym);        \
497   XCODING_SYSTEM_EOL_TYPE (sub_codesys_obj) = Type;                             \
498   if (mlen != -1)                                                               \
499     XCODING_SYSTEM_MNEMONIC(sub_codesys_obj) =                                  \
500       build_string (codesys_mnemonic);                                          \
501   CODING_SYSTEM_##Type (codesys) = sub_codesys_obj;                             \
502 } while (0)
503
504   DEFINE_SUB_CODESYS("unix", "", EOL_LF);
505   DEFINE_SUB_CODESYS("dos",  ":T", EOL_CRLF);
506   DEFINE_SUB_CODESYS("mac",  ":t", EOL_CR);
507 }
508
509 DEFUN ("coding-system-p", Fcoding_system_p, 1, 1, 0, /*
510 Return t if OBJECT is a coding system.
511 A coding system is an object that defines how text containing multiple
512 character sets is encoded into a stream of (typically 8-bit) bytes.
513 The coding system is used to decode the stream into a series of
514 characters (which may be from multiple charsets) when the text is read
515 from a file or process, and is used to encode the text back into the
516 same format when it is written out to a file or process.
517
518 For example, many ISO2022-compliant coding systems (such as Compound
519 Text, which is used for inter-client data under the X Window System)
520 use escape sequences to switch between different charsets -- Japanese
521 Kanji, for example, is invoked with "ESC $ ( B"; ASCII is invoked
522 with "ESC ( B"; and Cyrillic is invoked with "ESC - L".  See
523 `make-coding-system' for more information.
524
525 Coding systems are normally identified using a symbol, and the
526 symbol is accepted in place of the actual coding system object whenever
527 a coding system is called for. (This is similar to how faces work.)
528 */
529        (object))
530 {
531   return CODING_SYSTEMP (object) ? Qt : Qnil;
532 }
533
534 DEFUN ("find-coding-system", Ffind_coding_system, 1, 1, 0, /*
535 Retrieve the coding system of the given name.
536
537 If CODING-SYSTEM-OR-NAME is a coding-system object, it is simply
538 returned.  Otherwise, CODING-SYSTEM-OR-NAME should be a symbol.
539 If there is no such coding system, nil is returned.  Otherwise the
540 associated coding system object is returned.
541 */
542        (coding_system_or_name))
543 {
544   if (NILP (coding_system_or_name))
545     coding_system_or_name = Qbinary;
546   else if (CODING_SYSTEMP (coding_system_or_name))
547     return coding_system_or_name;
548   else
549     CHECK_SYMBOL (coding_system_or_name);
550
551   while (1)
552     {
553       coding_system_or_name =
554         Fgethash (coding_system_or_name, Vcoding_system_hash_table, Qnil);
555
556       if (CODING_SYSTEMP (coding_system_or_name) || NILP (coding_system_or_name))
557         return coding_system_or_name;
558     }
559 }
560
561 DEFUN ("get-coding-system", Fget_coding_system, 1, 1, 0, /*
562 Retrieve the coding system of the given name.
563 Same as `find-coding-system' except that if there is no such
564 coding system, an error is signaled instead of returning nil.
565 */
566        (name))
567 {
568   Lisp_Object coding_system = Ffind_coding_system (name);
569
570   if (NILP (coding_system))
571     signal_simple_error ("No such coding system", name);
572   return coding_system;
573 }
574
575 /* We store the coding systems in hash tables with the names as the key and the
576    actual coding system object as the value.  Occasionally we need to use them
577    in a list format.  These routines provide us with that. */
578 struct coding_system_list_closure
579 {
580   Lisp_Object *coding_system_list;
581 };
582
583 static int
584 add_coding_system_to_list_mapper (Lisp_Object key, Lisp_Object value,
585                                   void *coding_system_list_closure)
586 {
587   /* This function can GC */
588   struct coding_system_list_closure *cscl =
589     (struct coding_system_list_closure *) coding_system_list_closure;
590   Lisp_Object *coding_system_list = cscl->coding_system_list;
591
592   *coding_system_list = Fcons (key, *coding_system_list);
593   return 0;
594 }
595
596 DEFUN ("coding-system-list", Fcoding_system_list, 0, 0, 0, /*
597 Return a list of the names of all defined coding systems.
598 */
599        ())
600 {
601   Lisp_Object coding_system_list = Qnil;
602   struct gcpro gcpro1;
603   struct coding_system_list_closure coding_system_list_closure;
604
605   GCPRO1 (coding_system_list);
606   coding_system_list_closure.coding_system_list = &coding_system_list;
607   elisp_maphash (add_coding_system_to_list_mapper, Vcoding_system_hash_table,
608                  &coding_system_list_closure);
609   UNGCPRO;
610
611   return coding_system_list;
612 }
613
614 DEFUN ("coding-system-name", Fcoding_system_name, 1, 1, 0, /*
615 Return the name of the given coding system.
616 */
617        (coding_system))
618 {
619   coding_system = Fget_coding_system (coding_system);
620   return XCODING_SYSTEM_NAME (coding_system);
621 }
622
623 static Lisp_Coding_System *
624 allocate_coding_system (enum coding_system_type type, Lisp_Object name)
625 {
626   Lisp_Coding_System *codesys =
627     alloc_lcrecord_type (Lisp_Coding_System, &lrecord_coding_system);
628
629   zero_lcrecord (codesys);
630   CODING_SYSTEM_PRE_WRITE_CONVERSION (codesys) = Qnil;
631   CODING_SYSTEM_POST_READ_CONVERSION (codesys) = Qnil;
632   CODING_SYSTEM_EOL_TYPE (codesys) = EOL_AUTODETECT;
633   CODING_SYSTEM_EOL_CRLF (codesys) = Qnil;
634   CODING_SYSTEM_EOL_CR   (codesys) = Qnil;
635   CODING_SYSTEM_EOL_LF   (codesys) = Qnil;
636   CODING_SYSTEM_TYPE     (codesys) = type;
637   CODING_SYSTEM_MNEMONIC (codesys) = Qnil;
638 #ifdef MULE
639   if (type == CODESYS_ISO2022)
640     {
641       int i;
642       for (i = 0; i < 4; i++)
643         CODING_SYSTEM_ISO2022_INITIAL_CHARSET (codesys, i) = Qnil;
644     }
645   else if (type == CODESYS_CCL)
646     {
647       CODING_SYSTEM_CCL_DECODE (codesys) = Qnil;
648       CODING_SYSTEM_CCL_ENCODE (codesys) = Qnil;
649     }
650 #endif /* MULE */
651   CODING_SYSTEM_NAME (codesys) = name;
652
653   return codesys;
654 }
655
656 #ifdef MULE
657 /* Given a list of charset conversion specs as specified in a Lisp
658    program, parse it into STORE_HERE. */
659
660 static void
661 parse_charset_conversion_specs (charset_conversion_spec_dynarr *store_here,
662                                 Lisp_Object spec_list)
663 {
664   Lisp_Object rest;
665
666   EXTERNAL_LIST_LOOP (rest, spec_list)
667     {
668       Lisp_Object car = XCAR (rest);
669       Lisp_Object from, to;
670       struct charset_conversion_spec spec;
671
672       if (!CONSP (car) || !CONSP (XCDR (car)) || !NILP (XCDR (XCDR (car))))
673         signal_simple_error ("Invalid charset conversion spec", car);
674       from = Fget_charset (XCAR (car));
675       to = Fget_charset (XCAR (XCDR (car)));
676       if (XCHARSET_TYPE (from) != XCHARSET_TYPE (to))
677         signal_simple_error_2
678           ("Attempted conversion between different charset types",
679            from, to);
680       spec.from_charset = from;
681       spec.to_charset = to;
682
683       Dynarr_add (store_here, spec);
684     }
685 }
686
687 /* Given a dynarr LOAD_HERE of internally-stored charset conversion
688    specs, return the equivalent as the Lisp programmer would see it.
689
690    If LOAD_HERE is 0, return Qnil. */
691
692 static Lisp_Object
693 unparse_charset_conversion_specs (charset_conversion_spec_dynarr *load_here)
694 {
695   int i;
696   Lisp_Object result;
697
698   if (!load_here)
699     return Qnil;
700   for (i = 0, result = Qnil; i < Dynarr_length (load_here); i++)
701     {
702       struct charset_conversion_spec *ccs = Dynarr_atp (load_here, i);
703       result = Fcons (list2 (ccs->from_charset, ccs->to_charset), result);
704     }
705
706   return Fnreverse (result);
707 }
708
709 #endif /* MULE */
710
711 DEFUN ("make-coding-system", Fmake_coding_system, 2, 4, 0, /*
712 Register symbol NAME as a coding system.
713
714 TYPE describes the conversion method used and should be one of
715
716 nil or 'undecided
717      Automatic conversion.  XEmacs attempts to detect the coding system
718      used in the file.
719 'no-conversion
720      No conversion.  Use this for binary files and such.  On output,
721      graphic characters that are not in ASCII or Latin-1 will be
722      replaced by a ?. (For a no-conversion-encoded buffer, these
723      characters will only be present if you explicitly insert them.)
724 'shift-jis
725      Shift-JIS (a Japanese encoding commonly used in PC operating systems).
726 'ucs-4
727      ISO 10646 UCS-4 encoding.
728 'utf-8
729      ISO 10646 UTF-8 encoding.
730 'iso2022
731      Any ISO2022-compliant encoding.  Among other things, this includes
732      JIS (the Japanese encoding commonly used for e-mail), EUC (the
733      standard Unix encoding for Japanese and other languages), and
734      Compound Text (the encoding used in X11).  You can specify more
735      specific information about the conversion with the FLAGS argument.
736 'big5
737      Big5 (the encoding commonly used for Taiwanese).
738 'ccl
739      The conversion is performed using a user-written pseudo-code
740      program.  CCL (Code Conversion Language) is the name of this
741      pseudo-code.
742 'internal
743      Write out or read in the raw contents of the memory representing
744      the buffer's text.  This is primarily useful for debugging
745      purposes, and is only enabled when XEmacs has been compiled with
746      DEBUG_XEMACS defined (via the --debug configure option).
747      WARNING: Reading in a file using 'internal conversion can result
748      in an internal inconsistency in the memory representing a
749      buffer's text, which will produce unpredictable results and may
750      cause XEmacs to crash.  Under normal circumstances you should
751      never use 'internal conversion.
752
753 DOC-STRING is a string describing the coding system.
754
755 PROPS is a property list, describing the specific nature of the
756 character set.  Recognized properties are:
757
758 'mnemonic
759      String to be displayed in the modeline when this coding system is
760      active.
761
762 'eol-type
763      End-of-line conversion to be used.  It should be one of
764
765         nil
766                 Automatically detect the end-of-line type (LF, CRLF,
767                 or CR).  Also generate subsidiary coding systems named
768                 `NAME-unix', `NAME-dos', and `NAME-mac', that are
769                 identical to this coding system but have an EOL-TYPE
770                 value of 'lf, 'crlf, and 'cr, respectively.
771         'lf
772                 The end of a line is marked externally using ASCII LF.
773                 Since this is also the way that XEmacs represents an
774                 end-of-line internally, specifying this option results
775                 in no end-of-line conversion.  This is the standard
776                 format for Unix text files.
777         'crlf
778                 The end of a line is marked externally using ASCII
779                 CRLF.  This is the standard format for MS-DOS text
780                 files.
781         'cr
782                 The end of a line is marked externally using ASCII CR.
783                 This is the standard format for Macintosh text files.
784         t
785                 Automatically detect the end-of-line type but do not
786                 generate subsidiary coding systems.  (This value is
787                 converted to nil when stored internally, and
788                 `coding-system-property' will return nil.)
789
790 'post-read-conversion
791      Function called after a file has been read in, to perform the
792      decoding.  Called with two arguments, BEG and END, denoting
793      a region of the current buffer to be decoded.
794
795 'pre-write-conversion
796      Function called before a file is written out, to perform the
797      encoding.  Called with two arguments, BEG and END, denoting
798      a region of the current buffer to be encoded.
799
800
801 The following additional properties are recognized if TYPE is 'iso2022:
802
803 'charset-g0
804 'charset-g1
805 'charset-g2
806 'charset-g3
807      The character set initially designated to the G0 - G3 registers.
808      The value should be one of
809
810           -- A charset object (designate that character set)
811           -- nil (do not ever use this register)
812           -- t (no character set is initially designated to
813                 the register, but may be later on; this automatically
814                 sets the corresponding `force-g*-on-output' property)
815
816 'force-g0-on-output
817 'force-g1-on-output
818 'force-g2-on-output
819 'force-g2-on-output
820      If non-nil, send an explicit designation sequence on output before
821      using the specified register.
822
823 'short
824      If non-nil, use the short forms "ESC $ @", "ESC $ A", and
825      "ESC $ B" on output in place of the full designation sequences
826      "ESC $ ( @", "ESC $ ( A", and "ESC $ ( B".
827
828 'no-ascii-eol
829      If non-nil, don't designate ASCII to G0 at each end of line on output.
830      Setting this to non-nil also suppresses other state-resetting that
831      normally happens at the end of a line.
832
833 'no-ascii-cntl
834      If non-nil, don't designate ASCII to G0 before control chars on output.
835
836 'seven
837      If non-nil, use 7-bit environment on output.  Otherwise, use 8-bit
838      environment.
839
840 'lock-shift
841      If non-nil, use locking-shift (SO/SI) instead of single-shift
842      or designation by escape sequence.
843
844 'no-iso6429
845      If non-nil, don't use ISO6429's direction specification.
846
847 'escape-quoted
848      If non-nil, literal control characters that are the same as
849      the beginning of a recognized ISO2022 or ISO6429 escape sequence
850      (in particular, ESC (0x1B), SO (0x0E), SI (0x0F), SS2 (0x8E),
851      SS3 (0x8F), and CSI (0x9B)) are "quoted" with an escape character
852      so that they can be properly distinguished from an escape sequence.
853      (Note that doing this results in a non-portable encoding.) This
854      encoding flag is used for byte-compiled files.  Note that ESC
855      is a good choice for a quoting character because there are no
856      escape sequences whose second byte is a character from the Control-0
857      or Control-1 character sets; this is explicitly disallowed by the
858      ISO2022 standard.
859
860 'input-charset-conversion
861      A list of conversion specifications, specifying conversion of
862      characters in one charset to another when decoding is performed.
863      Each specification is a list of two elements: the source charset,
864      and the destination charset.
865
866 'output-charset-conversion
867      A list of conversion specifications, specifying conversion of
868      characters in one charset to another when encoding is performed.
869      The form of each specification is the same as for
870      'input-charset-conversion.
871
872
873 The following additional properties are recognized (and required)
874 if TYPE is 'ccl:
875
876 'decode
877      CCL program used for decoding (converting to internal format).
878
879 'encode
880      CCL program used for encoding (converting to external format).
881 */
882        (name, type, doc_string, props))
883 {
884   Lisp_Coding_System *codesys;
885   Lisp_Object rest, key, value;
886   enum coding_system_type ty;
887   int need_to_setup_eol_systems = 1;
888
889   /* Convert type to constant */
890   if (NILP (type) || EQ (type, Qundecided))
891                                       { ty = CODESYS_AUTODETECT; }
892 #ifdef MULE
893   else if (EQ (type, Qshift_jis))     { ty = CODESYS_SHIFT_JIS; }
894   else if (EQ (type, Qiso2022))       { ty = CODESYS_ISO2022; }
895   else if (EQ (type, Qbig5))          { ty = CODESYS_BIG5; }
896   else if (EQ (type, Qucs4))          { ty = CODESYS_UCS4; }
897   else if (EQ (type, Qutf8))          { ty = CODESYS_UTF8; }
898   else if (EQ (type, Qccl))           { ty = CODESYS_CCL; }
899 #endif
900   else if (EQ (type, Qno_conversion)) { ty = CODESYS_NO_CONVERSION; }
901 #ifdef DEBUG_XEMACS
902   else if (EQ (type, Qinternal))      { ty = CODESYS_INTERNAL; }
903 #endif
904   else
905     signal_simple_error ("Invalid coding system type", type);
906
907   CHECK_SYMBOL (name);
908
909   codesys = allocate_coding_system (ty, name);
910
911   if (NILP (doc_string))
912     doc_string = build_string ("");
913   else
914     CHECK_STRING (doc_string);
915   CODING_SYSTEM_DOC_STRING (codesys) = doc_string;
916
917   EXTERNAL_PROPERTY_LIST_LOOP (rest, key, value, props)
918     {
919       if (EQ (key, Qmnemonic))
920         {
921           if (!NILP (value))
922             CHECK_STRING (value);
923           CODING_SYSTEM_MNEMONIC (codesys) = value;
924         }
925
926       else if (EQ (key, Qeol_type))
927         {
928           need_to_setup_eol_systems = NILP (value);
929           if (EQ (value, Qt))
930             value = Qnil;
931           CODING_SYSTEM_EOL_TYPE (codesys) = symbol_to_eol_type (value);
932         }
933
934       else if (EQ (key, Qpost_read_conversion)) CODING_SYSTEM_POST_READ_CONVERSION (codesys) = value;
935       else if (EQ (key, Qpre_write_conversion)) CODING_SYSTEM_PRE_WRITE_CONVERSION (codesys) = value;
936 #ifdef MULE
937       else if (ty == CODESYS_ISO2022)
938         {
939 #define FROB_INITIAL_CHARSET(charset_num) \
940   CODING_SYSTEM_ISO2022_INITIAL_CHARSET (codesys, charset_num) = \
941     ((EQ (value, Qt) || EQ (value, Qnil)) ? value : Fget_charset (value))
942
943           if      (EQ (key, Qcharset_g0)) FROB_INITIAL_CHARSET (0);
944           else if (EQ (key, Qcharset_g1)) FROB_INITIAL_CHARSET (1);
945           else if (EQ (key, Qcharset_g2)) FROB_INITIAL_CHARSET (2);
946           else if (EQ (key, Qcharset_g3)) FROB_INITIAL_CHARSET (3);
947
948 #define FROB_FORCE_CHARSET(charset_num) \
949   CODING_SYSTEM_ISO2022_FORCE_CHARSET_ON_OUTPUT (codesys, charset_num) = !NILP (value)
950
951           else if (EQ (key, Qforce_g0_on_output)) FROB_FORCE_CHARSET (0);
952           else if (EQ (key, Qforce_g1_on_output)) FROB_FORCE_CHARSET (1);
953           else if (EQ (key, Qforce_g2_on_output)) FROB_FORCE_CHARSET (2);
954           else if (EQ (key, Qforce_g3_on_output)) FROB_FORCE_CHARSET (3);
955
956 #define FROB_BOOLEAN_PROPERTY(prop) \
957   CODING_SYSTEM_ISO2022_##prop (codesys) = !NILP (value)
958
959           else if (EQ (key, Qshort))         FROB_BOOLEAN_PROPERTY (SHORT);
960           else if (EQ (key, Qno_ascii_eol))  FROB_BOOLEAN_PROPERTY (NO_ASCII_EOL);
961           else if (EQ (key, Qno_ascii_cntl)) FROB_BOOLEAN_PROPERTY (NO_ASCII_CNTL);
962           else if (EQ (key, Qseven))         FROB_BOOLEAN_PROPERTY (SEVEN);
963           else if (EQ (key, Qlock_shift))    FROB_BOOLEAN_PROPERTY (LOCK_SHIFT);
964           else if (EQ (key, Qno_iso6429))    FROB_BOOLEAN_PROPERTY (NO_ISO6429);
965           else if (EQ (key, Qescape_quoted)) FROB_BOOLEAN_PROPERTY (ESCAPE_QUOTED);
966
967           else if (EQ (key, Qinput_charset_conversion))
968             {
969               codesys->iso2022.input_conv =
970                 Dynarr_new (charset_conversion_spec);
971               parse_charset_conversion_specs (codesys->iso2022.input_conv,
972                                               value);
973             }
974           else if (EQ (key, Qoutput_charset_conversion))
975             {
976               codesys->iso2022.output_conv =
977                 Dynarr_new (charset_conversion_spec);
978               parse_charset_conversion_specs (codesys->iso2022.output_conv,
979                                               value);
980             }
981           else
982             signal_simple_error ("Unrecognized property", key);
983         }
984       else if (EQ (type, Qccl))
985         {
986           if (EQ (key, Qdecode))
987             {
988               CHECK_VECTOR (value);
989               CODING_SYSTEM_CCL_DECODE (codesys) = value;
990             }
991           else if (EQ (key, Qencode))
992             {
993               CHECK_VECTOR (value);
994               CODING_SYSTEM_CCL_ENCODE (codesys) = value;
995             }
996           else
997             signal_simple_error ("Unrecognized property", key);
998         }
999 #endif /* MULE */
1000       else
1001         signal_simple_error ("Unrecognized property", key);
1002     }
1003
1004   if (need_to_setup_eol_systems)
1005     setup_eol_coding_systems (codesys);
1006
1007   {
1008     Lisp_Object codesys_obj;
1009     XSETCODING_SYSTEM (codesys_obj, codesys);
1010     Fputhash (name, codesys_obj, Vcoding_system_hash_table);
1011     return codesys_obj;
1012   }
1013 }
1014
1015 DEFUN ("copy-coding-system", Fcopy_coding_system, 2, 2, 0, /*
1016 Copy OLD-CODING-SYSTEM to NEW-NAME.
1017 If NEW-NAME does not name an existing coding system, a new one will
1018 be created.
1019 */
1020        (old_coding_system, new_name))
1021 {
1022   Lisp_Object new_coding_system;
1023   old_coding_system = Fget_coding_system (old_coding_system);
1024   new_coding_system = Ffind_coding_system (new_name);
1025   if (NILP (new_coding_system))
1026     {
1027       XSETCODING_SYSTEM (new_coding_system,
1028                          allocate_coding_system
1029                          (XCODING_SYSTEM_TYPE (old_coding_system),
1030                           new_name));
1031       Fputhash (new_name, new_coding_system, Vcoding_system_hash_table);
1032     }
1033
1034   {
1035     Lisp_Coding_System *to = XCODING_SYSTEM (new_coding_system);
1036     Lisp_Coding_System *from = XCODING_SYSTEM (old_coding_system);
1037     memcpy (((char *) to  ) + sizeof (to->header),
1038             ((char *) from) + sizeof (from->header),
1039             sizeof (*from) - sizeof (from->header));
1040     to->name = new_name;
1041   }
1042   return new_coding_system;
1043 }
1044
1045 DEFUN ("coding-system-canonical-name-p", Fcoding_system_canonical_name_p, 1, 1, 0, /*
1046 Return t if OBJECT names a coding system, and is not a coding system alias.
1047 */
1048        (object))
1049 {
1050   return CODING_SYSTEMP (Fgethash (object, Vcoding_system_hash_table, Qnil))
1051     ? Qt : Qnil;
1052 }
1053
1054 DEFUN ("coding-system-alias-p", Fcoding_system_alias_p, 1, 1, 0, /*
1055 Return t if OBJECT is a coding system alias.
1056 All coding system aliases are created by `define-coding-system-alias'.
1057 */
1058        (object))
1059 {
1060   return SYMBOLP (Fgethash (object, Vcoding_system_hash_table, Qzero))
1061     ? Qt : Qnil;
1062 }
1063
1064 DEFUN ("coding-system-aliasee", Fcoding_system_aliasee, 1, 1, 0, /*
1065 Return the coding-system symbol for which symbol ALIAS is an alias.
1066 */
1067        (alias))
1068 {
1069   Lisp_Object aliasee = Fgethash (alias, Vcoding_system_hash_table, Qnil);
1070   if (SYMBOLP (aliasee))
1071     return aliasee;
1072   else
1073     signal_simple_error ("Symbol is not a coding system alias", alias);
1074 }
1075
1076 static Lisp_Object
1077 append_suffix_to_symbol (Lisp_Object symbol, const char *ascii_string)
1078 {
1079   return Fintern (concat2 (Fsymbol_name (symbol), build_string (ascii_string)),
1080                   Qnil);
1081 }
1082
1083 /* A maphash function, for removing dangling coding system aliases. */
1084 static int
1085 dangling_coding_system_alias_p (Lisp_Object alias,
1086                                 Lisp_Object aliasee,
1087                                 void *dangling_aliases)
1088 {
1089   if (SYMBOLP (aliasee)
1090       && NILP (Fgethash (aliasee, Vcoding_system_hash_table, Qnil)))
1091     {
1092       (*(int *) dangling_aliases)++;
1093       return 1;
1094     }
1095   else
1096     return 0;
1097 }
1098
1099 DEFUN ("define-coding-system-alias", Fdefine_coding_system_alias, 2, 2, 0, /*
1100 Define symbol ALIAS as an alias for coding system ALIASEE.
1101
1102 You can use this function to redefine an alias that has already been defined,
1103 but you cannot redefine a name which is the canonical name for a coding system.
1104 \(a canonical name of a coding system is what is returned when you call
1105 `coding-system-name' on a coding system).
1106
1107 ALIASEE itself can be an alias, which allows you to define nested aliases.
1108
1109 You are forbidden, however, from creating alias loops or `dangling' aliases.
1110 These will be detected, and an error will be signaled if you attempt to do so.
1111
1112 If ALIASEE is nil, then ALIAS will simply be undefined.
1113
1114 See also `coding-system-alias-p', `coding-system-aliasee',
1115 and `coding-system-canonical-name-p'.
1116 */
1117        (alias, aliasee))
1118 {
1119   Lisp_Object real_coding_system, probe;
1120
1121   CHECK_SYMBOL (alias);
1122
1123   if (!NILP (Fcoding_system_canonical_name_p (alias)))
1124     signal_simple_error
1125       ("Symbol is the canonical name of a coding system and cannot be redefined",
1126        alias);
1127
1128   if (NILP (aliasee))
1129     {
1130       Lisp_Object subsidiary_unix = append_suffix_to_symbol (alias, "-unix");
1131       Lisp_Object subsidiary_dos  = append_suffix_to_symbol (alias, "-dos");
1132       Lisp_Object subsidiary_mac  = append_suffix_to_symbol (alias, "-mac");
1133
1134       Fremhash (alias, Vcoding_system_hash_table);
1135
1136       /* Undefine subsidiary aliases,
1137          presumably created by a previous call to this function */
1138       if (! NILP (Fcoding_system_alias_p (subsidiary_unix)) &&
1139           ! NILP (Fcoding_system_alias_p (subsidiary_dos))  &&
1140           ! NILP (Fcoding_system_alias_p (subsidiary_mac)))
1141         {
1142           Fdefine_coding_system_alias (subsidiary_unix, Qnil);
1143           Fdefine_coding_system_alias (subsidiary_dos,  Qnil);
1144           Fdefine_coding_system_alias (subsidiary_mac,  Qnil);
1145         }
1146
1147       /* Undefine dangling coding system aliases. */
1148       {
1149         int dangling_aliases;
1150
1151         do {
1152           dangling_aliases = 0;
1153           elisp_map_remhash (dangling_coding_system_alias_p,
1154                              Vcoding_system_hash_table,
1155                              &dangling_aliases);
1156         } while (dangling_aliases > 0);
1157       }
1158
1159       return Qnil;
1160     }
1161
1162   if (CODING_SYSTEMP (aliasee))
1163     aliasee = XCODING_SYSTEM_NAME (aliasee);
1164
1165   /* Checks that aliasee names a coding-system */
1166   real_coding_system = Fget_coding_system (aliasee);
1167
1168   /* Check for coding system alias loops */
1169   if (EQ (alias, aliasee))
1170     alias_loop: signal_simple_error_2
1171       ("Attempt to create a coding system alias loop", alias, aliasee);
1172
1173   for (probe = aliasee;
1174        SYMBOLP (probe);
1175        probe = Fgethash (probe, Vcoding_system_hash_table, Qzero))
1176     {
1177       if (EQ (probe, alias))
1178         goto alias_loop;
1179     }
1180
1181   Fputhash (alias, aliasee, Vcoding_system_hash_table);
1182
1183   /* Set up aliases for subsidiaries.
1184      #### There must be a better way to handle subsidiary coding systems. */
1185   {
1186     static const char *suffixes[] = { "-unix", "-dos", "-mac" };
1187     int i;
1188     for (i = 0; i < countof (suffixes); i++)
1189       {
1190         Lisp_Object alias_subsidiary =
1191           append_suffix_to_symbol (alias, suffixes[i]);
1192         Lisp_Object aliasee_subsidiary =
1193           append_suffix_to_symbol (aliasee, suffixes[i]);
1194
1195         if (! NILP (Ffind_coding_system (aliasee_subsidiary)))
1196           Fdefine_coding_system_alias (alias_subsidiary, aliasee_subsidiary);
1197       }
1198   }
1199   /* FSF return value is a vector of [ALIAS-unix ALIAS-dos ALIAS-mac],
1200      but it doesn't look intentional, so I'd rather return something
1201      meaningful or nothing at all. */
1202   return Qnil;
1203 }
1204
1205 static Lisp_Object
1206 subsidiary_coding_system (Lisp_Object coding_system, eol_type_t type)
1207 {
1208   Lisp_Coding_System *cs = XCODING_SYSTEM (coding_system);
1209   Lisp_Object new_coding_system;
1210
1211   if (CODING_SYSTEM_EOL_TYPE (cs) != EOL_AUTODETECT)
1212     return coding_system;
1213
1214   switch (type)
1215     {
1216     case EOL_AUTODETECT: return coding_system;
1217     case EOL_LF:   new_coding_system = CODING_SYSTEM_EOL_LF   (cs); break;
1218     case EOL_CR:   new_coding_system = CODING_SYSTEM_EOL_CR   (cs); break;
1219     case EOL_CRLF: new_coding_system = CODING_SYSTEM_EOL_CRLF (cs); break;
1220     default:       abort ();
1221     }
1222
1223   return NILP (new_coding_system) ? coding_system : new_coding_system;
1224 }
1225
1226 DEFUN ("subsidiary-coding-system", Fsubsidiary_coding_system, 2, 2, 0, /*
1227 Return the subsidiary coding system of CODING-SYSTEM with eol type EOL-TYPE.
1228 */
1229        (coding_system, eol_type))
1230 {
1231   coding_system = Fget_coding_system (coding_system);
1232
1233   return subsidiary_coding_system (coding_system,
1234                                    symbol_to_eol_type (eol_type));
1235 }
1236
1237 \f
1238 /************************************************************************/
1239 /*                         Coding system accessors                      */
1240 /************************************************************************/
1241
1242 DEFUN ("coding-system-doc-string", Fcoding_system_doc_string, 1, 1, 0, /*
1243 Return the doc string for CODING-SYSTEM.
1244 */
1245        (coding_system))
1246 {
1247   coding_system = Fget_coding_system (coding_system);
1248   return XCODING_SYSTEM_DOC_STRING (coding_system);
1249 }
1250
1251 DEFUN ("coding-system-type", Fcoding_system_type, 1, 1, 0, /*
1252 Return the type of CODING-SYSTEM.
1253 */
1254        (coding_system))
1255 {
1256   switch (XCODING_SYSTEM_TYPE (Fget_coding_system (coding_system)))
1257     {
1258     default: abort ();
1259     case CODESYS_AUTODETECT:    return Qundecided;
1260 #ifdef MULE
1261     case CODESYS_SHIFT_JIS:     return Qshift_jis;
1262     case CODESYS_ISO2022:       return Qiso2022;
1263     case CODESYS_BIG5:          return Qbig5;
1264     case CODESYS_UCS4:          return Qucs4;
1265     case CODESYS_UTF8:          return Qutf8;
1266     case CODESYS_CCL:           return Qccl;
1267 #endif
1268     case CODESYS_NO_CONVERSION: return Qno_conversion;
1269 #ifdef DEBUG_XEMACS
1270     case CODESYS_INTERNAL:      return Qinternal;
1271 #endif
1272     }
1273 }
1274
1275 #ifdef MULE
1276 static
1277 Lisp_Object coding_system_charset (Lisp_Object coding_system, int gnum)
1278 {
1279   Lisp_Object cs
1280     = XCODING_SYSTEM_ISO2022_INITIAL_CHARSET (coding_system, gnum);
1281
1282   return CHARSETP (cs) ? XCHARSET_NAME (cs) : Qnil;
1283 }
1284
1285 DEFUN ("coding-system-charset", Fcoding_system_charset, 2, 2, 0, /*
1286 Return initial charset of CODING-SYSTEM designated to GNUM.
1287 GNUM allows 0 .. 3.
1288 */
1289        (coding_system, gnum))
1290 {
1291   coding_system = Fget_coding_system (coding_system);
1292   CHECK_INT (gnum);
1293
1294   return coding_system_charset (coding_system, XINT (gnum));
1295 }
1296 #endif /* MULE */
1297
1298 DEFUN ("coding-system-property", Fcoding_system_property, 2, 2, 0, /*
1299 Return the PROP property of CODING-SYSTEM.
1300 */
1301        (coding_system, prop))
1302 {
1303   int i, ok = 0;
1304   enum coding_system_type type;
1305
1306   coding_system = Fget_coding_system (coding_system);
1307   CHECK_SYMBOL (prop);
1308   type = XCODING_SYSTEM_TYPE (coding_system);
1309
1310   for (i = 0; !ok && i < Dynarr_length (the_codesys_prop_dynarr); i++)
1311     if (EQ (Dynarr_at (the_codesys_prop_dynarr, i).sym, prop))
1312       {
1313         ok = 1;
1314         switch (Dynarr_at (the_codesys_prop_dynarr, i).prop_type)
1315           {
1316           case CODESYS_PROP_ALL_OK:
1317             break;
1318 #ifdef MULE
1319           case CODESYS_PROP_ISO2022:
1320             if (type != CODESYS_ISO2022)
1321               signal_simple_error
1322                 ("Property only valid in ISO2022 coding systems",
1323                  prop);
1324             break;
1325
1326           case CODESYS_PROP_CCL:
1327             if (type != CODESYS_CCL)
1328               signal_simple_error
1329                 ("Property only valid in CCL coding systems",
1330                  prop);
1331             break;
1332 #endif /* MULE */
1333           default:
1334             abort ();
1335           }
1336       }
1337
1338   if (!ok)
1339     signal_simple_error ("Unrecognized property", prop);
1340
1341   if (EQ (prop, Qname))
1342     return XCODING_SYSTEM_NAME (coding_system);
1343   else if (EQ (prop, Qtype))
1344     return Fcoding_system_type (coding_system);
1345   else if (EQ (prop, Qdoc_string))
1346     return XCODING_SYSTEM_DOC_STRING (coding_system);
1347   else if (EQ (prop, Qmnemonic))
1348     return XCODING_SYSTEM_MNEMONIC (coding_system);
1349   else if (EQ (prop, Qeol_type))
1350     return eol_type_to_symbol (XCODING_SYSTEM_EOL_TYPE (coding_system));
1351   else if (EQ (prop, Qeol_lf))
1352     return XCODING_SYSTEM_EOL_LF (coding_system);
1353   else if (EQ (prop, Qeol_crlf))
1354     return XCODING_SYSTEM_EOL_CRLF (coding_system);
1355   else if (EQ (prop, Qeol_cr))
1356     return XCODING_SYSTEM_EOL_CR (coding_system);
1357   else if (EQ (prop, Qpost_read_conversion))
1358     return XCODING_SYSTEM_POST_READ_CONVERSION (coding_system);
1359   else if (EQ (prop, Qpre_write_conversion))
1360     return XCODING_SYSTEM_PRE_WRITE_CONVERSION (coding_system);
1361 #ifdef MULE
1362   else if (type == CODESYS_ISO2022)
1363     {
1364       if (EQ (prop, Qcharset_g0))
1365         return coding_system_charset (coding_system, 0);
1366       else if (EQ (prop, Qcharset_g1))
1367         return coding_system_charset (coding_system, 1);
1368       else if (EQ (prop, Qcharset_g2))
1369         return coding_system_charset (coding_system, 2);
1370       else if (EQ (prop, Qcharset_g3))
1371         return coding_system_charset (coding_system, 3);
1372
1373 #define FORCE_CHARSET(charset_num) \
1374   (XCODING_SYSTEM_ISO2022_FORCE_CHARSET_ON_OUTPUT \
1375    (coding_system, charset_num) ? Qt : Qnil)
1376
1377       else if (EQ (prop, Qforce_g0_on_output)) return FORCE_CHARSET (0);
1378       else if (EQ (prop, Qforce_g1_on_output)) return FORCE_CHARSET (1);
1379       else if (EQ (prop, Qforce_g2_on_output)) return FORCE_CHARSET (2);
1380       else if (EQ (prop, Qforce_g3_on_output)) return FORCE_CHARSET (3);
1381
1382 #define LISP_BOOLEAN(prop) \
1383   (XCODING_SYSTEM_ISO2022_##prop (coding_system) ? Qt : Qnil)
1384
1385       else if (EQ (prop, Qshort))         return LISP_BOOLEAN (SHORT);
1386       else if (EQ (prop, Qno_ascii_eol))  return LISP_BOOLEAN (NO_ASCII_EOL);
1387       else if (EQ (prop, Qno_ascii_cntl)) return LISP_BOOLEAN (NO_ASCII_CNTL);
1388       else if (EQ (prop, Qseven))         return LISP_BOOLEAN (SEVEN);
1389       else if (EQ (prop, Qlock_shift))    return LISP_BOOLEAN (LOCK_SHIFT);
1390       else if (EQ (prop, Qno_iso6429))    return LISP_BOOLEAN (NO_ISO6429);
1391       else if (EQ (prop, Qescape_quoted)) return LISP_BOOLEAN (ESCAPE_QUOTED);
1392
1393       else if (EQ (prop, Qinput_charset_conversion))
1394         return
1395           unparse_charset_conversion_specs
1396             (XCODING_SYSTEM (coding_system)->iso2022.input_conv);
1397       else if (EQ (prop, Qoutput_charset_conversion))
1398         return
1399           unparse_charset_conversion_specs
1400             (XCODING_SYSTEM (coding_system)->iso2022.output_conv);
1401       else
1402         abort ();
1403     }
1404   else if (type == CODESYS_CCL)
1405     {
1406       if (EQ (prop, Qdecode))
1407         return XCODING_SYSTEM_CCL_DECODE (coding_system);
1408       else if (EQ (prop, Qencode))
1409         return XCODING_SYSTEM_CCL_ENCODE (coding_system);
1410       else
1411         abort ();
1412     }
1413 #endif /* MULE */
1414   else
1415     abort ();
1416
1417   return Qnil; /* not reached */
1418 }
1419
1420 \f
1421 /************************************************************************/
1422 /*                       Coding category functions                      */
1423 /************************************************************************/
1424
1425 static int
1426 decode_coding_category (Lisp_Object symbol)
1427 {
1428   int i;
1429
1430   CHECK_SYMBOL (symbol);
1431   for (i = 0; i <= CODING_CATEGORY_LAST; i++)
1432     if (EQ (coding_category_symbol[i], symbol))
1433       return i;
1434
1435   signal_simple_error ("Unrecognized coding category", symbol);
1436   return 0; /* not reached */
1437 }
1438
1439 DEFUN ("coding-category-list", Fcoding_category_list, 0, 0, 0, /*
1440 Return a list of all recognized coding categories.
1441 */
1442        ())
1443 {
1444   int i;
1445   Lisp_Object list = Qnil;
1446
1447   for (i = CODING_CATEGORY_LAST; i >= 0; i--)
1448     list = Fcons (coding_category_symbol[i], list);
1449   return list;
1450 }
1451
1452 DEFUN ("set-coding-priority-list", Fset_coding_priority_list, 1, 1, 0, /*
1453 Change the priority order of the coding categories.
1454 LIST should be list of coding categories, in descending order of
1455 priority.  Unspecified coding categories will be lower in priority
1456 than all specified ones, in the same relative order they were in
1457 previously.
1458 */
1459        (list))
1460 {
1461   int category_to_priority[CODING_CATEGORY_LAST + 1];
1462   int i, j;
1463   Lisp_Object rest;
1464
1465   /* First generate a list that maps coding categories to priorities. */
1466
1467   for (i = 0; i <= CODING_CATEGORY_LAST; i++)
1468     category_to_priority[i] = -1;
1469
1470   /* Highest priority comes from the specified list. */
1471   i = 0;
1472   EXTERNAL_LIST_LOOP (rest, list)
1473     {
1474       int cat = decode_coding_category (XCAR (rest));
1475
1476       if (category_to_priority[cat] >= 0)
1477         signal_simple_error ("Duplicate coding category in list", XCAR (rest));
1478       category_to_priority[cat] = i++;
1479     }
1480
1481   /* Now go through the existing categories by priority to retrieve
1482      the categories not yet specified and preserve their priority
1483      order. */
1484   for (j = 0; j <= CODING_CATEGORY_LAST; j++)
1485     {
1486       int cat = fcd->coding_category_by_priority[j];
1487       if (category_to_priority[cat] < 0)
1488         category_to_priority[cat] = i++;
1489     }
1490
1491   /* Now we need to construct the inverse of the mapping we just
1492      constructed. */
1493
1494   for (i = 0; i <= CODING_CATEGORY_LAST; i++)
1495     fcd->coding_category_by_priority[category_to_priority[i]] = i;
1496
1497   /* Phew!  That was confusing. */
1498   return Qnil;
1499 }
1500
1501 DEFUN ("coding-priority-list", Fcoding_priority_list, 0, 0, 0, /*
1502 Return a list of coding categories in descending order of priority.
1503 */
1504        ())
1505 {
1506   int i;
1507   Lisp_Object list = Qnil;
1508
1509   for (i = CODING_CATEGORY_LAST; i >= 0; i--)
1510     list = Fcons (coding_category_symbol[fcd->coding_category_by_priority[i]],
1511                   list);
1512   return list;
1513 }
1514
1515 DEFUN ("set-coding-category-system", Fset_coding_category_system, 2, 2, 0, /*
1516 Change the coding system associated with a coding category.
1517 */
1518        (coding_category, coding_system))
1519 {
1520   int cat = decode_coding_category (coding_category);
1521
1522   coding_system = Fget_coding_system (coding_system);
1523   fcd->coding_category_system[cat] = coding_system;
1524   return Qnil;
1525 }
1526
1527 DEFUN ("coding-category-system", Fcoding_category_system, 1, 1, 0, /*
1528 Return the coding system associated with a coding category.
1529 */
1530        (coding_category))
1531 {
1532   int cat = decode_coding_category (coding_category);
1533   Lisp_Object sys = fcd->coding_category_system[cat];
1534
1535   if (!NILP (sys))
1536     return XCODING_SYSTEM_NAME (sys);
1537   return Qnil;
1538 }
1539
1540 \f
1541 /************************************************************************/
1542 /*                     Detecting the encoding of data                   */
1543 /************************************************************************/
1544
1545 struct detection_state
1546 {
1547   eol_type_t eol_type;
1548   int seen_non_ascii;
1549   int mask;
1550 #ifdef MULE
1551   struct
1552     {
1553       int mask;
1554       int in_second_byte;
1555     }
1556   big5;
1557
1558   struct
1559     {
1560       int mask;
1561       int in_second_byte;
1562     }
1563   shift_jis;
1564
1565   struct
1566     {
1567       int mask;
1568       int in_byte;
1569   }
1570   ucs4;
1571
1572   struct
1573     {
1574       int mask;
1575       int in_byte;
1576     }
1577   utf8;
1578
1579   struct
1580     {
1581       int mask;
1582       int initted;
1583       struct iso2022_decoder iso;
1584       unsigned int flags;
1585       int high_byte_count;
1586       unsigned int saw_single_shift:1;
1587     }
1588   iso2022;
1589 #endif
1590   struct
1591     {
1592       int seen_anything;
1593       int just_saw_cr;
1594     }
1595   eol;
1596 };
1597
1598 static int
1599 acceptable_control_char_p (int c)
1600 {
1601   switch (c)
1602     {
1603       /* Allow and ignore control characters that you might
1604          reasonably see in a text file */
1605     case '\r':
1606     case '\n':
1607     case '\t':
1608     case  7: /* bell */
1609     case  8: /* backspace */
1610     case 11: /* vertical tab */
1611     case 12: /* form feed */
1612     case 26: /* MS-DOS C-z junk */
1613     case 31: /* '^_' -- for info */
1614       return 1;
1615     default:
1616       return 0;
1617     }
1618 }
1619
1620 static int
1621 mask_has_at_most_one_bit_p (int mask)
1622 {
1623   /* Perhaps the only thing useful you learn from intensive Microsoft
1624      technical interviews */
1625   return (mask & (mask - 1)) == 0;
1626 }
1627
1628 static eol_type_t
1629 detect_eol_type (struct detection_state *st, CONST unsigned char *src,
1630                  unsigned int n)
1631 {
1632   int c;
1633
1634   while (n--)
1635     {
1636       c = *src++;
1637       if (c == '\n')
1638         {
1639           if (st->eol.just_saw_cr)
1640             return EOL_CRLF;
1641           else if (st->eol.seen_anything)
1642             return EOL_LF;
1643         }
1644       else if (st->eol.just_saw_cr)
1645         return EOL_CR;
1646       else if (c == '\r')
1647         st->eol.just_saw_cr = 1;
1648       else
1649         st->eol.just_saw_cr = 0;
1650       st->eol.seen_anything = 1;
1651     }
1652
1653   return EOL_AUTODETECT;
1654 }
1655
1656 /* Attempt to determine the encoding and EOL type of the given text.
1657    Before calling this function for the first type, you must initialize
1658    st->eol_type as appropriate and initialize st->mask to ~0.
1659
1660    st->eol_type holds the determined EOL type, or EOL_AUTODETECT if
1661    not yet known.
1662
1663    st->mask holds the determined coding category mask, or ~0 if only
1664    ASCII has been seen so far.
1665
1666    Returns:
1667
1668    0 == st->eol_type is EOL_AUTODETECT and/or more than coding category
1669         is present in st->mask
1670    1 == definitive answers are here for both st->eol_type and st->mask
1671 */
1672
1673 static int
1674 detect_coding_type (struct detection_state *st, CONST Extbyte *src,
1675                     unsigned int n, int just_do_eol)
1676 {
1677   int c;
1678
1679   if (st->eol_type == EOL_AUTODETECT)
1680     st->eol_type = detect_eol_type (st, src, n);
1681
1682   if (just_do_eol)
1683     return st->eol_type != EOL_AUTODETECT;
1684
1685   if (!st->seen_non_ascii)
1686     {
1687       for (; n; n--, src++)
1688         {
1689           c = *src;
1690           if ((c < 0x20 && !acceptable_control_char_p (c)) || c >= 0x80)
1691             {
1692               st->seen_non_ascii = 1;
1693 #ifdef MULE
1694               st->shift_jis.mask = ~0;
1695               st->big5.mask = ~0;
1696               st->ucs4.mask = ~0;
1697               st->utf8.mask = ~0;
1698               st->iso2022.mask = ~0;
1699 #endif
1700               break;
1701             }
1702         }
1703     }
1704
1705   if (!n)
1706     return 0;
1707 #ifdef MULE
1708   if (!mask_has_at_most_one_bit_p (st->iso2022.mask))
1709     st->iso2022.mask = detect_coding_iso2022 (st, src, n);
1710   if (!mask_has_at_most_one_bit_p (st->shift_jis.mask))
1711     st->shift_jis.mask = detect_coding_sjis (st, src, n);
1712   if (!mask_has_at_most_one_bit_p (st->big5.mask))
1713     st->big5.mask = detect_coding_big5 (st, src, n);
1714   if (!mask_has_at_most_one_bit_p (st->utf8.mask))
1715     st->utf8.mask = detect_coding_utf8 (st, src, n);
1716   if (!mask_has_at_most_one_bit_p (st->ucs4.mask))
1717     st->ucs4.mask = detect_coding_ucs4 (st, src, n);
1718
1719   st->mask
1720     = st->iso2022.mask | st->shift_jis.mask | st->big5.mask
1721     | st->utf8.mask | st->ucs4.mask;
1722 #endif
1723   {
1724     int retval = mask_has_at_most_one_bit_p (st->mask);
1725     st->mask |= CODING_CATEGORY_NO_CONVERSION_MASK;
1726     return retval && st->eol_type != EOL_AUTODETECT;
1727   }
1728 }
1729
1730 static Lisp_Object
1731 coding_system_from_mask (int mask)
1732 {
1733   if (mask == ~0)
1734     {
1735       /* If the file was entirely or basically ASCII, use the
1736          default value of `buffer-file-coding-system'. */
1737       Lisp_Object retval =
1738         XBUFFER (Vbuffer_defaults)->buffer_file_coding_system;
1739       if (!NILP (retval))
1740         {
1741           retval = Ffind_coding_system (retval);
1742           if (NILP (retval))
1743             {
1744               warn_when_safe
1745                 (Qbad_variable, Qwarning,
1746                  "Invalid `default-buffer-file-coding-system', set to nil");
1747               XBUFFER (Vbuffer_defaults)->buffer_file_coding_system = Qnil;
1748             }
1749         }
1750       if (NILP (retval))
1751         retval = Fget_coding_system (Qraw_text);
1752       return retval;
1753     }
1754   else
1755     {
1756       int i;
1757       int cat = -1;
1758 #ifdef MULE
1759       mask = postprocess_iso2022_mask (mask);
1760 #endif
1761       /* Look through the coding categories by priority and find
1762          the first one that is allowed. */
1763       for (i = 0; i <= CODING_CATEGORY_LAST; i++)
1764         {
1765           cat = fcd->coding_category_by_priority[i];
1766           if ((mask & (1 << cat)) &&
1767               !NILP (fcd->coding_category_system[cat]))
1768             break;
1769         }
1770       if (cat >= 0)
1771         return fcd->coding_category_system[cat];
1772       else
1773         return Fget_coding_system (Qraw_text);
1774     }
1775 }
1776
1777 /* Given a seekable read stream and potential coding system and EOL type
1778    as specified, do any autodetection that is called for.  If the
1779    coding system and/or EOL type are not `autodetect', they will be left
1780    alone; but this function will never return an autodetect coding system
1781    or EOL type.
1782
1783    This function does not automatically fetch subsidiary coding systems;
1784    that should be unnecessary with the explicit eol-type argument. */
1785
1786 #define LENGTH(string_constant) (sizeof (string_constant) - 1)
1787
1788 void
1789 determine_real_coding_system (Lstream *stream, Lisp_Object *codesys_in_out,
1790                               eol_type_t *eol_type_in_out)
1791 {
1792   struct detection_state decst;
1793
1794   if (*eol_type_in_out == EOL_AUTODETECT)
1795     *eol_type_in_out = XCODING_SYSTEM_EOL_TYPE (*codesys_in_out);
1796
1797   xzero (decst);
1798   decst.eol_type = *eol_type_in_out;
1799   decst.mask = ~0;
1800
1801   /* If autodetection is called for, do it now. */
1802   if (XCODING_SYSTEM_TYPE (*codesys_in_out) == CODESYS_AUTODETECT
1803       || *eol_type_in_out == EOL_AUTODETECT)
1804     {
1805       Extbyte buf[4096];
1806       Lisp_Object coding_system = Qnil;
1807       Extbyte *p;
1808       ssize_t nread = Lstream_read (stream, buf, sizeof (buf));
1809       Extbyte *scan_end;
1810
1811       /* Look for initial "-*-"; mode line prefix */
1812       for (p = buf,
1813              scan_end = buf + nread - LENGTH ("-*-coding:?-*-");
1814            p <= scan_end
1815              && *p != '\n'
1816              && *p != '\r';
1817            p++)
1818         if (*p == '-' && *(p+1) == '*' && *(p+2) == '-')
1819           {
1820             Extbyte *local_vars_beg = p + 3;
1821             /* Look for final "-*-"; mode line suffix */
1822             for (p = local_vars_beg,
1823                    scan_end = buf + nread - LENGTH ("-*-");
1824                  p <= scan_end
1825                    && *p != '\n'
1826                    && *p != '\r';
1827                  p++)
1828               if (*p == '-' && *(p+1) == '*' && *(p+2) == '-')
1829                 {
1830                   Extbyte *suffix = p;
1831                   /* Look for "coding:" */
1832                   for (p = local_vars_beg,
1833                          scan_end = suffix - LENGTH ("coding:?");
1834                        p <= scan_end;
1835                        p++)
1836                     if (memcmp ("coding:", p, LENGTH ("coding:")) == 0
1837                         && (p == local_vars_beg
1838                             || (*(p-1) == ' '  ||
1839                                 *(p-1) == '\t' ||
1840                                 *(p-1) == ';')))
1841                       {
1842                         Extbyte save;
1843                         int n;
1844                         p += LENGTH ("coding:");
1845                         while (*p == ' ' || *p == '\t') p++;
1846
1847                         /* Get coding system name */
1848                         save = *suffix; *suffix = '\0';
1849                         /* Characters valid in a MIME charset name (rfc 1521),
1850                            and in a Lisp symbol name. */
1851                         n = strspn ( (char *) p,
1852                                     "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
1853                                     "abcdefghijklmnopqrstuvwxyz"
1854                                     "0123456789"
1855                                     "!$%&*+-.^_{|}~");
1856                         *suffix = save;
1857                         if (n > 0)
1858                           {
1859                             save = p[n]; p[n] = '\0';
1860                             coding_system =
1861                               Ffind_coding_system (intern ((char *) p));
1862                             p[n] = save;
1863                           }
1864                         break;
1865                       }
1866                   break;
1867                 }
1868             break;
1869           }
1870
1871       if (NILP (coding_system))
1872         do
1873           {
1874             if (detect_coding_type (&decst, buf, nread,
1875                                     XCODING_SYSTEM_TYPE (*codesys_in_out)
1876                                     != CODESYS_AUTODETECT))
1877               break;
1878             nread = Lstream_read (stream, buf, sizeof (buf));
1879             if (nread == 0)
1880               break;
1881           }
1882         while (1);
1883
1884       else if (XCODING_SYSTEM_TYPE (*codesys_in_out) == CODESYS_AUTODETECT
1885                && XCODING_SYSTEM_EOL_TYPE (coding_system) == EOL_AUTODETECT)
1886         do
1887           {
1888             if (detect_coding_type (&decst, buf, nread, 1))
1889               break;
1890             nread = Lstream_read (stream, buf, sizeof (buf));
1891             if (!nread)
1892               break;
1893           }
1894         while (1);
1895
1896       *eol_type_in_out = decst.eol_type;
1897       if (XCODING_SYSTEM_TYPE (*codesys_in_out) == CODESYS_AUTODETECT)
1898         {
1899           if (NILP (coding_system))
1900             *codesys_in_out = coding_system_from_mask (decst.mask);
1901           else
1902             *codesys_in_out = coding_system;
1903         }
1904     }
1905
1906   /* If we absolutely can't determine the EOL type, just assume LF. */
1907   if (*eol_type_in_out == EOL_AUTODETECT)
1908     *eol_type_in_out = EOL_LF;
1909
1910   Lstream_rewind (stream);
1911 }
1912
1913 DEFUN ("detect-coding-region", Fdetect_coding_region, 2, 3, 0, /*
1914 Detect coding system of the text in the region between START and END.
1915 Returned a list of possible coding systems ordered by priority.
1916 If only ASCII characters are found, it returns 'undecided or one of
1917 its subsidiary coding systems according to a detected end-of-line
1918 type.  Optional arg BUFFER defaults to the current buffer.
1919 */
1920        (start, end, buffer))
1921 {
1922   Lisp_Object val = Qnil;
1923   struct buffer *buf = decode_buffer (buffer, 0);
1924   Bufpos b, e;
1925   Lisp_Object instream, lb_instream;
1926   Lstream *istr, *lb_istr;
1927   struct detection_state decst;
1928   struct gcpro gcpro1, gcpro2;
1929
1930   get_buffer_range_char (buf, start, end, &b, &e, 0);
1931   lb_instream = make_lisp_buffer_input_stream (buf, b, e, 0);
1932   lb_istr = XLSTREAM (lb_instream);
1933   instream = make_encoding_input_stream (lb_istr, Fget_coding_system (Qbinary));
1934   istr = XLSTREAM (instream);
1935   GCPRO2 (instream, lb_instream);
1936   xzero (decst);
1937   decst.eol_type = EOL_AUTODETECT;
1938   decst.mask = ~0;
1939   while (1)
1940     {
1941       unsigned char random_buffer[4096];
1942       ssize_t nread = Lstream_read (istr, random_buffer, sizeof (random_buffer));
1943
1944       if (!nread)
1945         break;
1946       if (detect_coding_type (&decst, random_buffer, nread, 0))
1947         break;
1948     }
1949
1950   if (decst.mask == ~0)
1951     val = subsidiary_coding_system (Fget_coding_system (Qundecided),
1952                                     decst.eol_type);
1953   else
1954     {
1955       int i;
1956
1957       val = Qnil;
1958 #ifdef MULE
1959       decst.mask = postprocess_iso2022_mask (decst.mask);
1960 #endif
1961       for (i = CODING_CATEGORY_LAST; i >= 0; i--)
1962         {
1963           int sys = fcd->coding_category_by_priority[i];
1964           if (decst.mask & (1 << sys))
1965             {
1966               Lisp_Object codesys = fcd->coding_category_system[sys];
1967               if (!NILP (codesys))
1968                 codesys = subsidiary_coding_system (codesys, decst.eol_type);
1969               val = Fcons (codesys, val);
1970             }
1971         }
1972     }
1973   Lstream_close (istr);
1974   UNGCPRO;
1975   Lstream_delete (istr);
1976   Lstream_delete (lb_istr);
1977   return val;
1978 }
1979
1980 \f
1981 /************************************************************************/
1982 /*           Converting to internal Mule format ("decoding")            */
1983 /************************************************************************/
1984
1985 /* A decoding stream is a stream used for decoding text (i.e.
1986    converting from some external format to internal format).
1987    The decoding-stream object keeps track of the actual coding
1988    stream, the stream that is at the other end, and data that
1989    needs to be persistent across the lifetime of the stream. */
1990
1991 /* Handle the EOL stuff related to just-read-in character C.
1992    EOL_TYPE is the EOL type of the coding stream.
1993    FLAGS is the current value of FLAGS in the coding stream, and may
1994    be modified by this macro.  (The macro only looks at the
1995    CODING_STATE_CR flag.)  DST is the Dynarr to which the decoded
1996    bytes are to be written.  You need to also define a local goto
1997    label "label_continue_loop" that is at the end of the main
1998    character-reading loop.
1999
2000    If C is a CR character, then this macro handles it entirely and
2001    jumps to label_continue_loop.  Otherwise, this macro does not add
2002    anything to DST, and continues normally.  You should continue
2003    processing C normally after this macro. */
2004
2005 #define DECODE_HANDLE_EOL_TYPE(eol_type, c, flags, dst)         \
2006 do {                                                            \
2007   if (c == '\r')                                                \
2008     {                                                           \
2009       if (eol_type == EOL_CR)                                   \
2010         Dynarr_add (dst, '\n');                                 \
2011       else if (eol_type != EOL_CRLF || flags & CODING_STATE_CR) \
2012         Dynarr_add (dst, c);                                    \
2013       else                                                      \
2014         flags |= CODING_STATE_CR;                               \
2015       goto label_continue_loop;                                 \
2016     }                                                           \
2017   else if (flags & CODING_STATE_CR)                             \
2018     {   /* eol_type == CODING_SYSTEM_EOL_CRLF */                \
2019       if (c != '\n')                                            \
2020         Dynarr_add (dst, '\r');                                 \
2021       flags &= ~CODING_STATE_CR;                                \
2022     }                                                           \
2023 } while (0)
2024
2025 /* C should be a binary character in the range 0 - 255; convert
2026    to internal format and add to Dynarr DST. */
2027
2028 #define DECODE_ADD_BINARY_CHAR(c, dst)          \
2029 do {                                            \
2030   if (BYTE_ASCII_P (c))                         \
2031     Dynarr_add (dst, c);                        \
2032   else if (BYTE_C1_P (c))                       \
2033     {                                           \
2034       Dynarr_add (dst, LEADING_BYTE_CONTROL_1); \
2035       Dynarr_add (dst, c + 0x20);               \
2036     }                                           \
2037   else                                          \
2038     {                                           \
2039       Dynarr_add (dst, LEADING_BYTE_LATIN_ISO8859_1); \
2040       Dynarr_add (dst, c);                      \
2041     }                                           \
2042 } while (0)
2043
2044 #define DECODE_OUTPUT_PARTIAL_CHAR(ch)  \
2045 do {                                    \
2046   if (ch)                               \
2047     {                                   \
2048       DECODE_ADD_BINARY_CHAR (ch, dst); \
2049       ch = 0;                           \
2050     }                                   \
2051 } while (0)
2052
2053 #define DECODE_HANDLE_END_OF_CONVERSION(flags, ch, dst) \
2054 do {                                    \
2055   if (flags & CODING_STATE_END)         \
2056     {                                   \
2057       DECODE_OUTPUT_PARTIAL_CHAR (ch);  \
2058       if (flags & CODING_STATE_CR)      \
2059         Dynarr_add (dst, '\r');         \
2060     }                                   \
2061 } while (0)
2062
2063 #define DECODING_STREAM_DATA(stream) LSTREAM_TYPE_DATA (stream, decoding)
2064
2065 struct decoding_stream
2066 {
2067   /* Coding system that governs the conversion. */
2068   Lisp_Coding_System *codesys;
2069
2070   /* Stream that we read the encoded data from or
2071      write the decoded data to. */
2072   Lstream *other_end;
2073
2074   /* If we are reading, then we can return only a fixed amount of
2075      data, so if the conversion resulted in too much data, we store it
2076      here for retrieval the next time around. */
2077   unsigned_char_dynarr *runoff;
2078
2079   /* FLAGS holds flags indicating the current state of the decoding.
2080      Some of these flags are dependent on the coding system. */
2081   unsigned int flags;
2082
2083   /* CH holds a partially built-up character.  Since we only deal
2084      with one- and two-byte characters at the moment, we only use
2085      this to store the first byte of a two-byte character. */
2086   unsigned int ch;
2087
2088   /* EOL_TYPE specifies the type of end-of-line conversion that
2089      currently applies.  We need to keep this separate from the
2090      EOL type stored in CODESYS because the latter might indicate
2091      automatic EOL-type detection while the former will always
2092      indicate a particular EOL type. */
2093   eol_type_t eol_type;
2094 #ifdef MULE
2095   /* Additional ISO2022 information.  We define the structure above
2096      because it's also needed by the detection routines. */
2097   struct iso2022_decoder iso2022;
2098
2099   /* Additional information (the state of the running CCL program)
2100      used by the CCL decoder. */
2101   struct ccl_program ccl;
2102
2103   /* counter for UTF-8 or UCS-4 */
2104   unsigned char counter;
2105 #endif
2106   struct detection_state decst;
2107 };
2108
2109 static ssize_t decoding_reader (Lstream *stream,
2110                                 unsigned char *data, size_t size);
2111 static ssize_t decoding_writer (Lstream *stream,
2112                                 CONST unsigned char *data, size_t size);
2113 static int decoding_rewinder   (Lstream *stream);
2114 static int decoding_seekable_p (Lstream *stream);
2115 static int decoding_flusher    (Lstream *stream);
2116 static int decoding_closer     (Lstream *stream);
2117
2118 static Lisp_Object decoding_marker (Lisp_Object stream);
2119
2120 DEFINE_LSTREAM_IMPLEMENTATION ("decoding", lstream_decoding,
2121                                sizeof (struct decoding_stream));
2122
2123 static Lisp_Object
2124 decoding_marker (Lisp_Object stream)
2125 {
2126   Lstream *str = DECODING_STREAM_DATA (XLSTREAM (stream))->other_end;
2127   Lisp_Object str_obj;
2128
2129   /* We do not need to mark the coding systems or charsets stored
2130      within the stream because they are stored in a global list
2131      and automatically marked. */
2132
2133   XSETLSTREAM (str_obj, str);
2134   mark_object (str_obj);
2135   if (str->imp->marker)
2136     return (str->imp->marker) (str_obj);
2137   else
2138     return Qnil;
2139 }
2140
2141 /* Read SIZE bytes of data and store it into DATA.  We are a decoding stream
2142    so we read data from the other end, decode it, and store it into DATA. */
2143
2144 static ssize_t
2145 decoding_reader (Lstream *stream, unsigned char *data, size_t size)
2146 {
2147   struct decoding_stream *str = DECODING_STREAM_DATA (stream);
2148   unsigned char *orig_data = data;
2149   ssize_t read_size;
2150   int error_occurred = 0;
2151
2152   /* We need to interface to mule_decode(), which expects to take some
2153      amount of data and store the result into a Dynarr.  We have
2154      mule_decode() store into str->runoff, and take data from there
2155      as necessary. */
2156
2157   /* We loop until we have enough data, reading chunks from the other
2158      end and decoding it. */
2159   while (1)
2160     {
2161       /* Take data from the runoff if we can.  Make sure to take at
2162          most SIZE bytes, and delete the data from the runoff. */
2163       if (Dynarr_length (str->runoff) > 0)
2164         {
2165           size_t chunk = min (size, (size_t) Dynarr_length (str->runoff));
2166           memcpy (data, Dynarr_atp (str->runoff, 0), chunk);
2167           Dynarr_delete_many (str->runoff, 0, chunk);
2168           data += chunk;
2169           size -= chunk;
2170         }
2171
2172       if (size == 0)
2173         break; /* No more room for data */
2174
2175       if (str->flags & CODING_STATE_END)
2176         /* This means that on the previous iteration, we hit the EOF on
2177            the other end.  We loop once more so that mule_decode() can
2178            output any final stuff it may be holding, or any "go back
2179            to a sane state" escape sequences. (This latter makes sense
2180            during encoding.) */
2181         break;
2182
2183       /* Exhausted the runoff, so get some more.  DATA has at least
2184          SIZE bytes left of storage in it, so it's OK to read directly
2185          into it.  (We'll be overwriting above, after we've decoded it
2186          into the runoff.) */
2187       read_size = Lstream_read (str->other_end, data, size);
2188       if (read_size < 0)
2189         {
2190           error_occurred = 1;
2191           break;
2192         }
2193       if (read_size == 0)
2194         /* There might be some more end data produced in the translation.
2195            See the comment above. */
2196         str->flags |= CODING_STATE_END;
2197       mule_decode (stream, data, str->runoff, read_size);
2198     }
2199
2200   if (data - orig_data == 0)
2201     return error_occurred ? -1 : 0;
2202   else
2203     return data - orig_data;
2204 }
2205
2206 static ssize_t
2207 decoding_writer (Lstream *stream, CONST unsigned char *data, size_t size)
2208 {
2209   struct decoding_stream *str = DECODING_STREAM_DATA (stream);
2210   ssize_t retval;
2211
2212   /* Decode all our data into the runoff, and then attempt to write
2213      it all out to the other end.  Remove whatever chunk we succeeded
2214      in writing. */
2215   mule_decode (stream, data, str->runoff, size);
2216   retval = Lstream_write (str->other_end, Dynarr_atp (str->runoff, 0),
2217                           Dynarr_length (str->runoff));
2218   if (retval > 0)
2219     Dynarr_delete_many (str->runoff, 0, retval);
2220   /* Do NOT return retval.  The return value indicates how much
2221      of the incoming data was written, not how many bytes were
2222      written. */
2223   return size;
2224 }
2225
2226 static void
2227 reset_decoding_stream (struct decoding_stream *str)
2228 {
2229 #ifdef MULE
2230   if (CODING_SYSTEM_TYPE (str->codesys) == CODESYS_ISO2022)
2231     {
2232       Lisp_Object coding_system;
2233       XSETCODING_SYSTEM (coding_system, str->codesys);
2234       reset_iso2022 (coding_system, &str->iso2022);
2235     }
2236   else if (CODING_SYSTEM_TYPE (str->codesys) == CODESYS_CCL)
2237     {
2238       setup_ccl_program (&str->ccl, CODING_SYSTEM_CCL_DECODE (str->codesys));
2239     }
2240   str->counter = 0;
2241 #endif /* MULE */
2242   str->flags = str->ch = 0;
2243 }
2244
2245 static int
2246 decoding_rewinder (Lstream *stream)
2247 {
2248   struct decoding_stream *str = DECODING_STREAM_DATA (stream);
2249   reset_decoding_stream (str);
2250   Dynarr_reset (str->runoff);
2251   return Lstream_rewind (str->other_end);
2252 }
2253
2254 static int
2255 decoding_seekable_p (Lstream *stream)
2256 {
2257   struct decoding_stream *str = DECODING_STREAM_DATA (stream);
2258   return Lstream_seekable_p (str->other_end);
2259 }
2260
2261 static int
2262 decoding_flusher (Lstream *stream)
2263 {
2264   struct decoding_stream *str = DECODING_STREAM_DATA (stream);
2265   return Lstream_flush (str->other_end);
2266 }
2267
2268 static int
2269 decoding_closer (Lstream *stream)
2270 {
2271   struct decoding_stream *str = DECODING_STREAM_DATA (stream);
2272   if (stream->flags & LSTREAM_FL_WRITE)
2273     {
2274       str->flags |= CODING_STATE_END;
2275       decoding_writer (stream, 0, 0);
2276     }
2277   Dynarr_free (str->runoff);
2278 #ifdef MULE
2279 #ifdef ENABLE_COMPOSITE_CHARS
2280   if (str->iso2022.composite_chars)
2281     Dynarr_free (str->iso2022.composite_chars);
2282 #endif
2283 #endif
2284   return Lstream_close (str->other_end);
2285 }
2286
2287 Lisp_Object
2288 decoding_stream_coding_system (Lstream *stream)
2289 {
2290   Lisp_Object coding_system;
2291   struct decoding_stream *str = DECODING_STREAM_DATA (stream);
2292
2293   XSETCODING_SYSTEM (coding_system, str->codesys);
2294   return subsidiary_coding_system (coding_system, str->eol_type);
2295 }
2296
2297 void
2298 set_decoding_stream_coding_system (Lstream *lstr, Lisp_Object codesys)
2299 {
2300   Lisp_Coding_System *cs = XCODING_SYSTEM (codesys);
2301   struct decoding_stream *str = DECODING_STREAM_DATA (lstr);
2302   str->codesys = cs;
2303   if (CODING_SYSTEM_EOL_TYPE (cs) != EOL_AUTODETECT)
2304     str->eol_type = CODING_SYSTEM_EOL_TYPE (cs);
2305   reset_decoding_stream (str);
2306 }
2307
2308 /* WARNING WARNING WARNING WARNING!!!!!  If you open up a decoding
2309    stream for writing, no automatic code detection will be performed.
2310    The reason for this is that automatic code detection requires a
2311    seekable input.  Things will also fail if you open a decoding
2312    stream for reading using a non-fully-specified coding system and
2313    a non-seekable input stream. */
2314
2315 static Lisp_Object
2316 make_decoding_stream_1 (Lstream *stream, Lisp_Object codesys,
2317                         CONST char *mode)
2318 {
2319   Lstream *lstr = Lstream_new (lstream_decoding, mode);
2320   struct decoding_stream *str = DECODING_STREAM_DATA (lstr);
2321   Lisp_Object obj;
2322
2323   xzero (*str);
2324   str->other_end = stream;
2325   str->runoff = (unsigned_char_dynarr *) Dynarr_new (unsigned_char);
2326   str->eol_type = EOL_AUTODETECT;
2327   if (!strcmp (mode, "r")
2328       && Lstream_seekable_p (stream))
2329     /* We can determine the coding system now. */
2330     determine_real_coding_system (stream, &codesys, &str->eol_type);
2331   set_decoding_stream_coding_system (lstr, codesys);
2332   str->decst.eol_type = str->eol_type;
2333   str->decst.mask = ~0;
2334   XSETLSTREAM (obj, lstr);
2335   return obj;
2336 }
2337
2338 Lisp_Object
2339 make_decoding_input_stream (Lstream *stream, Lisp_Object codesys)
2340 {
2341   return make_decoding_stream_1 (stream, codesys, "r");
2342 }
2343
2344 Lisp_Object
2345 make_decoding_output_stream (Lstream *stream, Lisp_Object codesys)
2346 {
2347   return make_decoding_stream_1 (stream, codesys, "w");
2348 }
2349
2350 /* Note: the decode_coding_* functions all take the same
2351    arguments as mule_decode(), which is to say some SRC data of
2352    size N, which is to be stored into dynamic array DST.
2353    DECODING is the stream within which the decoding is
2354    taking place, but no data is actually read from or
2355    written to that stream; that is handled in decoding_reader()
2356    or decoding_writer().  This allows the same functions to
2357    be used for both reading and writing. */
2358
2359 static void
2360 mule_decode (Lstream *decoding, CONST unsigned char *src,
2361              unsigned_char_dynarr *dst, unsigned int n)
2362 {
2363   struct decoding_stream *str = DECODING_STREAM_DATA (decoding);
2364
2365   /* If necessary, do encoding-detection now.  We do this when
2366      we're a writing stream or a non-seekable reading stream,
2367      meaning that we can't just process the whole input,
2368      rewind, and start over. */
2369
2370   if (CODING_SYSTEM_TYPE (str->codesys) == CODESYS_AUTODETECT ||
2371       str->eol_type == EOL_AUTODETECT)
2372     {
2373       Lisp_Object codesys;
2374
2375       XSETCODING_SYSTEM (codesys, str->codesys);
2376       detect_coding_type (&str->decst, src, n,
2377                           CODING_SYSTEM_TYPE (str->codesys) !=
2378                           CODESYS_AUTODETECT);
2379       if (CODING_SYSTEM_TYPE (str->codesys) == CODESYS_AUTODETECT &&
2380           str->decst.mask != ~0)
2381         /* #### This is cheesy.  What we really ought to do is
2382            buffer up a certain amount of data so as to get a
2383            less random result. */
2384         codesys = coding_system_from_mask (str->decst.mask);
2385       str->eol_type = str->decst.eol_type;
2386       if (XCODING_SYSTEM (codesys) != str->codesys)
2387         {
2388           /* Preserve the CODING_STATE_END flag in case it was set.
2389              If we erase it, bad things might happen. */
2390           int was_end = str->flags & CODING_STATE_END;
2391           set_decoding_stream_coding_system (decoding, codesys);
2392           if (was_end)
2393             str->flags |= CODING_STATE_END;
2394         }
2395     }
2396
2397   switch (CODING_SYSTEM_TYPE (str->codesys))
2398     {
2399 #ifdef DEBUG_XEMACS
2400     case CODESYS_INTERNAL:
2401       Dynarr_add_many (dst, src, n);
2402       break;
2403 #endif
2404     case CODESYS_AUTODETECT:
2405       /* If we got this far and still haven't decided on the coding
2406          system, then do no conversion. */
2407     case CODESYS_NO_CONVERSION:
2408       decode_coding_no_conversion (decoding, src, dst, n);
2409       break;
2410 #ifdef MULE
2411     case CODESYS_SHIFT_JIS:
2412       decode_coding_sjis (decoding, src, dst, n);
2413       break;
2414     case CODESYS_BIG5:
2415       decode_coding_big5 (decoding, src, dst, n);
2416       break;
2417     case CODESYS_UCS4:
2418       decode_coding_ucs4 (decoding, src, dst, n);
2419       break;
2420     case CODESYS_UTF8:
2421       decode_coding_utf8 (decoding, src, dst, n);
2422       break;
2423     case CODESYS_CCL:
2424       str->ccl.last_block = str->flags & CODING_STATE_END;
2425       ccl_driver (&str->ccl, src, dst, n, 0, CCL_MODE_DECODING);
2426       break;
2427     case CODESYS_ISO2022:
2428       decode_coding_iso2022 (decoding, src, dst, n);
2429       break;
2430 #endif /* MULE */
2431     default:
2432       abort ();
2433     }
2434 }
2435
2436 DEFUN ("decode-coding-region", Fdecode_coding_region, 3, 4, 0, /*
2437 Decode the text between START and END which is encoded in CODING-SYSTEM.
2438 This is useful if you've read in encoded text from a file without decoding
2439 it (e.g. you read in a JIS-formatted file but used the `binary' or
2440 `no-conversion' coding system, so that it shows up as "^[$B!<!+^[(B").
2441 Return length of decoded text.
2442 BUFFER defaults to the current buffer if unspecified.
2443 */
2444        (start, end, coding_system, buffer))
2445 {
2446   Bufpos b, e;
2447   struct buffer *buf = decode_buffer (buffer, 0);
2448   Lisp_Object instream, lb_outstream, de_outstream, outstream;
2449   Lstream *istr, *ostr;
2450   struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
2451
2452   get_buffer_range_char (buf, start, end, &b, &e, 0);
2453
2454   barf_if_buffer_read_only (buf, b, e);
2455
2456   coding_system = Fget_coding_system (coding_system);
2457   instream = make_lisp_buffer_input_stream  (buf, b, e, 0);
2458   lb_outstream = make_lisp_buffer_output_stream (buf, b, 0);
2459   de_outstream = make_decoding_output_stream (XLSTREAM (lb_outstream),
2460                                               coding_system);
2461   outstream = make_encoding_output_stream (XLSTREAM (de_outstream),
2462                                            Fget_coding_system (Qbinary));
2463   istr = XLSTREAM (instream);
2464   ostr = XLSTREAM (outstream);
2465   GCPRO4 (instream, lb_outstream, de_outstream, outstream);
2466
2467   /* The chain of streams looks like this:
2468
2469      [BUFFER] <----- send through
2470                      ------> [ENCODE AS BINARY]
2471                              ------> [DECODE AS SPECIFIED]
2472                                      ------> [BUFFER]
2473    */
2474
2475   while (1)
2476     {
2477       char tempbuf[1024]; /* some random amount */
2478       Bufpos newpos, even_newer_pos;
2479       Bufpos oldpos = lisp_buffer_stream_startpos (istr);
2480       ssize_t size_in_bytes = Lstream_read (istr, tempbuf, sizeof (tempbuf));
2481
2482       if (!size_in_bytes)
2483         break;
2484       newpos = lisp_buffer_stream_startpos (istr);
2485       Lstream_write (ostr, tempbuf, size_in_bytes);
2486       even_newer_pos = lisp_buffer_stream_startpos (istr);
2487       buffer_delete_range (buf, even_newer_pos - (newpos - oldpos),
2488                            even_newer_pos, 0);
2489     }
2490   Lstream_close (istr);
2491   Lstream_close (ostr);
2492   UNGCPRO;
2493   Lstream_delete (istr);
2494   Lstream_delete (ostr);
2495   Lstream_delete (XLSTREAM (de_outstream));
2496   Lstream_delete (XLSTREAM (lb_outstream));
2497   return Qnil;
2498 }
2499
2500 \f
2501 /************************************************************************/
2502 /*           Converting to an external encoding ("encoding")            */
2503 /************************************************************************/
2504
2505 /* An encoding stream is an output stream.  When you create the
2506    stream, you specify the coding system that governs the encoding
2507    and another stream that the resulting encoded data is to be
2508    sent to, and then start sending data to it. */
2509
2510 #define ENCODING_STREAM_DATA(stream) LSTREAM_TYPE_DATA (stream, encoding)
2511
2512 struct encoding_stream
2513 {
2514   /* Coding system that governs the conversion. */
2515   Lisp_Coding_System *codesys;
2516
2517   /* Stream that we read the encoded data from or
2518      write the decoded data to. */
2519   Lstream *other_end;
2520
2521   /* If we are reading, then we can return only a fixed amount of
2522      data, so if the conversion resulted in too much data, we store it
2523      here for retrieval the next time around. */
2524   unsigned_char_dynarr *runoff;
2525
2526   /* FLAGS holds flags indicating the current state of the encoding.
2527      Some of these flags are dependent on the coding system. */
2528   unsigned int flags;
2529
2530   /* CH holds a partially built-up character.  Since we only deal
2531      with one- and two-byte characters at the moment, we only use
2532      this to store the first byte of a two-byte character. */
2533   unsigned int ch;
2534 #ifdef MULE
2535   /* Additional information used by the ISO2022 encoder. */
2536   struct
2537     {
2538       /* CHARSET holds the character sets currently assigned to the G0
2539          through G3 registers.  It is initialized from the array
2540          INITIAL_CHARSET in CODESYS. */
2541       Lisp_Object charset[4];
2542
2543       /* Which registers are currently invoked into the left (GL) and
2544          right (GR) halves of the 8-bit encoding space? */
2545       int register_left, register_right;
2546
2547       /* Whether we need to explicitly designate the charset in the
2548          G? register before using it.  It is initialized from the
2549          array FORCE_CHARSET_ON_OUTPUT in CODESYS. */
2550       unsigned char force_charset_on_output[4];
2551
2552       /* Other state variables that need to be preserved across
2553          invocations. */
2554       Lisp_Object current_charset;
2555       int current_half;
2556       int current_char_boundary;
2557     } iso2022;
2558
2559   /* Additional information (the state of the running CCL program)
2560      used by the CCL encoder. */
2561   struct ccl_program ccl;
2562 #endif /* MULE */
2563 };
2564
2565 static ssize_t encoding_reader (Lstream *stream, unsigned char *data, size_t size);
2566 static ssize_t encoding_writer (Lstream *stream, CONST unsigned char *data,
2567                                 size_t size);
2568 static int encoding_rewinder   (Lstream *stream);
2569 static int encoding_seekable_p (Lstream *stream);
2570 static int encoding_flusher    (Lstream *stream);
2571 static int encoding_closer     (Lstream *stream);
2572
2573 static Lisp_Object encoding_marker (Lisp_Object stream);
2574
2575 DEFINE_LSTREAM_IMPLEMENTATION ("encoding", lstream_encoding,
2576                                sizeof (struct encoding_stream));
2577
2578 static Lisp_Object
2579 encoding_marker (Lisp_Object stream)
2580 {
2581   Lstream *str = ENCODING_STREAM_DATA (XLSTREAM (stream))->other_end;
2582   Lisp_Object str_obj;
2583
2584   /* We do not need to mark the coding systems or charsets stored
2585      within the stream because they are stored in a global list
2586      and automatically marked. */
2587
2588   XSETLSTREAM (str_obj, str);
2589   mark_object (str_obj);
2590   if (str->imp->marker)
2591     return (str->imp->marker) (str_obj);
2592   else
2593     return Qnil;
2594 }
2595
2596 /* Read SIZE bytes of data and store it into DATA.  We are a encoding stream
2597    so we read data from the other end, encode it, and store it into DATA. */
2598
2599 static ssize_t
2600 encoding_reader (Lstream *stream, unsigned char *data, size_t size)
2601 {
2602   struct encoding_stream *str = ENCODING_STREAM_DATA (stream);
2603   unsigned char *orig_data = data;
2604   ssize_t read_size;
2605   int error_occurred = 0;
2606
2607   /* We need to interface to mule_encode(), which expects to take some
2608      amount of data and store the result into a Dynarr.  We have
2609      mule_encode() store into str->runoff, and take data from there
2610      as necessary. */
2611
2612   /* We loop until we have enough data, reading chunks from the other
2613      end and encoding it. */
2614   while (1)
2615     {
2616       /* Take data from the runoff if we can.  Make sure to take at
2617          most SIZE bytes, and delete the data from the runoff. */
2618       if (Dynarr_length (str->runoff) > 0)
2619         {
2620           int chunk = min ((int) size, Dynarr_length (str->runoff));
2621           memcpy (data, Dynarr_atp (str->runoff, 0), chunk);
2622           Dynarr_delete_many (str->runoff, 0, chunk);
2623           data += chunk;
2624           size -= chunk;
2625         }
2626
2627       if (size == 0)
2628         break; /* No more room for data */
2629
2630       if (str->flags & CODING_STATE_END)
2631         /* This means that on the previous iteration, we hit the EOF on
2632            the other end.  We loop once more so that mule_encode() can
2633            output any final stuff it may be holding, or any "go back
2634            to a sane state" escape sequences. (This latter makes sense
2635            during encoding.) */
2636         break;
2637
2638       /* Exhausted the runoff, so get some more.  DATA at least SIZE bytes
2639          left of storage in it, so it's OK to read directly into it.
2640          (We'll be overwriting above, after we've encoded it into the
2641          runoff.) */
2642       read_size = Lstream_read (str->other_end, data, size);
2643       if (read_size < 0)
2644         {
2645           error_occurred = 1;
2646           break;
2647         }
2648       if (read_size == 0)
2649         /* There might be some more end data produced in the translation.
2650            See the comment above. */
2651         str->flags |= CODING_STATE_END;
2652       mule_encode (stream, data, str->runoff, read_size);
2653     }
2654
2655   if (data == orig_data)
2656     return error_occurred ? -1 : 0;
2657   else
2658     return data - orig_data;
2659 }
2660
2661 static ssize_t
2662 encoding_writer (Lstream *stream, CONST unsigned char *data, size_t size)
2663 {
2664   struct encoding_stream *str = ENCODING_STREAM_DATA (stream);
2665   ssize_t retval;
2666
2667   /* Encode all our data into the runoff, and then attempt to write
2668      it all out to the other end.  Remove whatever chunk we succeeded
2669      in writing. */
2670   mule_encode (stream, data, str->runoff, size);
2671   retval = Lstream_write (str->other_end, Dynarr_atp (str->runoff, 0),
2672                           Dynarr_length (str->runoff));
2673   if (retval > 0)
2674     Dynarr_delete_many (str->runoff, 0, retval);
2675   /* Do NOT return retval.  The return value indicates how much
2676      of the incoming data was written, not how many bytes were
2677      written. */
2678   return size;
2679 }
2680
2681 static void
2682 reset_encoding_stream (struct encoding_stream *str)
2683 {
2684 #ifdef MULE
2685   switch (CODING_SYSTEM_TYPE (str->codesys))
2686     {
2687     case CODESYS_ISO2022:
2688       {
2689         int i;
2690
2691         for (i = 0; i < 4; i++)
2692           {
2693             str->iso2022.charset[i] =
2694               CODING_SYSTEM_ISO2022_INITIAL_CHARSET (str->codesys, i);
2695             str->iso2022.force_charset_on_output[i] =
2696               CODING_SYSTEM_ISO2022_FORCE_CHARSET_ON_OUTPUT (str->codesys, i);
2697           }
2698         str->iso2022.register_left = 0;
2699         str->iso2022.register_right = 1;
2700         str->iso2022.current_charset = Qnil;
2701         str->iso2022.current_half = 0;
2702         str->iso2022.current_char_boundary = 1;
2703         break;
2704       }
2705     case CODESYS_CCL:
2706       setup_ccl_program (&str->ccl, CODING_SYSTEM_CCL_ENCODE (str->codesys));
2707       break;
2708     default:
2709       break;
2710     }
2711 #endif /* MULE */
2712
2713   str->flags = str->ch = 0;
2714 }
2715
2716 static int
2717 encoding_rewinder (Lstream *stream)
2718 {
2719   struct encoding_stream *str = ENCODING_STREAM_DATA (stream);
2720   reset_encoding_stream (str);
2721   Dynarr_reset (str->runoff);
2722   return Lstream_rewind (str->other_end);
2723 }
2724
2725 static int
2726 encoding_seekable_p (Lstream *stream)
2727 {
2728   struct encoding_stream *str = ENCODING_STREAM_DATA (stream);
2729   return Lstream_seekable_p (str->other_end);
2730 }
2731
2732 static int
2733 encoding_flusher (Lstream *stream)
2734 {
2735   struct encoding_stream *str = ENCODING_STREAM_DATA (stream);
2736   return Lstream_flush (str->other_end);
2737 }
2738
2739 static int
2740 encoding_closer (Lstream *stream)
2741 {
2742   struct encoding_stream *str = ENCODING_STREAM_DATA (stream);
2743   if (stream->flags & LSTREAM_FL_WRITE)
2744     {
2745       str->flags |= CODING_STATE_END;
2746       encoding_writer (stream, 0, 0);
2747     }
2748   Dynarr_free (str->runoff);
2749   return Lstream_close (str->other_end);
2750 }
2751
2752 Lisp_Object
2753 encoding_stream_coding_system (Lstream *stream)
2754 {
2755   Lisp_Object coding_system;
2756   struct encoding_stream *str = ENCODING_STREAM_DATA (stream);
2757
2758   XSETCODING_SYSTEM (coding_system, str->codesys);
2759   return coding_system;
2760 }
2761
2762 void
2763 set_encoding_stream_coding_system (Lstream *lstr, Lisp_Object codesys)
2764 {
2765   Lisp_Coding_System *cs = XCODING_SYSTEM (codesys);
2766   struct encoding_stream *str = ENCODING_STREAM_DATA (lstr);
2767   str->codesys = cs;
2768   reset_encoding_stream (str);
2769 }
2770
2771 static Lisp_Object
2772 make_encoding_stream_1 (Lstream *stream, Lisp_Object codesys,
2773                         CONST char *mode)
2774 {
2775   Lstream *lstr = Lstream_new (lstream_encoding, mode);
2776   struct encoding_stream *str = ENCODING_STREAM_DATA (lstr);
2777   Lisp_Object obj;
2778
2779   xzero (*str);
2780   str->runoff = Dynarr_new (unsigned_char);
2781   str->other_end = stream;
2782   set_encoding_stream_coding_system (lstr, codesys);
2783   XSETLSTREAM (obj, lstr);
2784   return obj;
2785 }
2786
2787 Lisp_Object
2788 make_encoding_input_stream (Lstream *stream, Lisp_Object codesys)
2789 {
2790   return make_encoding_stream_1 (stream, codesys, "r");
2791 }
2792
2793 Lisp_Object
2794 make_encoding_output_stream (Lstream *stream, Lisp_Object codesys)
2795 {
2796   return make_encoding_stream_1 (stream, codesys, "w");
2797 }
2798
2799 /* Convert N bytes of internally-formatted data stored in SRC to an
2800    external format, according to the encoding stream ENCODING.
2801    Store the encoded data into DST. */
2802
2803 static void
2804 mule_encode (Lstream *encoding, CONST unsigned char *src,
2805              unsigned_char_dynarr *dst, unsigned int n)
2806 {
2807   struct encoding_stream *str = ENCODING_STREAM_DATA (encoding);
2808
2809   switch (CODING_SYSTEM_TYPE (str->codesys))
2810     {
2811 #ifdef DEBUG_XEMACS
2812     case CODESYS_INTERNAL:
2813       Dynarr_add_many (dst, src, n);
2814       break;
2815 #endif
2816     case CODESYS_AUTODETECT:
2817       /* If we got this far and still haven't decided on the coding
2818          system, then do no conversion. */
2819     case CODESYS_NO_CONVERSION:
2820       encode_coding_no_conversion (encoding, src, dst, n);
2821       break;
2822 #ifdef MULE
2823     case CODESYS_SHIFT_JIS:
2824       encode_coding_sjis (encoding, src, dst, n);
2825       break;
2826     case CODESYS_BIG5:
2827       encode_coding_big5 (encoding, src, dst, n);
2828       break;
2829     case CODESYS_UCS4:
2830       encode_coding_ucs4 (encoding, src, dst, n);
2831       break;
2832     case CODESYS_UTF8:
2833       encode_coding_utf8 (encoding, src, dst, n);
2834       break;
2835     case CODESYS_CCL:
2836       str->ccl.last_block = str->flags & CODING_STATE_END;
2837       ccl_driver (&str->ccl, src, dst, n, 0, CCL_MODE_ENCODING);
2838       break;
2839     case CODESYS_ISO2022:
2840       encode_coding_iso2022 (encoding, src, dst, n);
2841       break;
2842 #endif /* MULE */
2843     default:
2844       abort ();
2845     }
2846 }
2847
2848 DEFUN ("encode-coding-region", Fencode_coding_region, 3, 4, 0, /*
2849 Encode the text between START and END using CODING-SYSTEM.
2850 This will, for example, convert Japanese characters into stuff such as
2851 "^[$B!<!+^[(B" if you use the JIS encoding.  Return length of encoded
2852 text.  BUFFER defaults to the current buffer if unspecified.
2853 */
2854        (start, end, coding_system, buffer))
2855 {
2856   Bufpos b, e;
2857   struct buffer *buf = decode_buffer (buffer, 0);
2858   Lisp_Object instream, lb_outstream, de_outstream, outstream;
2859   Lstream *istr, *ostr;
2860   struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
2861
2862   get_buffer_range_char (buf, start, end, &b, &e, 0);
2863
2864   barf_if_buffer_read_only (buf, b, e);
2865
2866   coding_system = Fget_coding_system (coding_system);
2867   instream  = make_lisp_buffer_input_stream  (buf, b, e, 0);
2868   lb_outstream = make_lisp_buffer_output_stream (buf, b, 0);
2869   de_outstream = make_decoding_output_stream (XLSTREAM (lb_outstream),
2870                                               Fget_coding_system (Qbinary));
2871   outstream = make_encoding_output_stream (XLSTREAM (de_outstream),
2872                                            coding_system);
2873   istr = XLSTREAM (instream);
2874   ostr = XLSTREAM (outstream);
2875   GCPRO4 (instream, outstream, de_outstream, lb_outstream);
2876   /* The chain of streams looks like this:
2877
2878      [BUFFER] <----- send through
2879                      ------> [ENCODE AS SPECIFIED]
2880                              ------> [DECODE AS BINARY]
2881                                      ------> [BUFFER]
2882    */
2883   while (1)
2884     {
2885       char tempbuf[1024]; /* some random amount */
2886       Bufpos newpos, even_newer_pos;
2887       Bufpos oldpos = lisp_buffer_stream_startpos (istr);
2888       ssize_t size_in_bytes = Lstream_read (istr, tempbuf, sizeof (tempbuf));
2889
2890       if (!size_in_bytes)
2891         break;
2892       newpos = lisp_buffer_stream_startpos (istr);
2893       Lstream_write (ostr, tempbuf, size_in_bytes);
2894       even_newer_pos = lisp_buffer_stream_startpos (istr);
2895       buffer_delete_range (buf, even_newer_pos - (newpos - oldpos),
2896                            even_newer_pos, 0);
2897     }
2898
2899   {
2900     Charcount retlen =
2901       lisp_buffer_stream_startpos (XLSTREAM (instream)) - b;
2902     Lstream_close (istr);
2903     Lstream_close (ostr);
2904     UNGCPRO;
2905     Lstream_delete (istr);
2906     Lstream_delete (ostr);
2907     Lstream_delete (XLSTREAM (de_outstream));
2908     Lstream_delete (XLSTREAM (lb_outstream));
2909     return make_int (retlen);
2910   }
2911 }
2912
2913 #ifdef MULE
2914 \f
2915 /************************************************************************/
2916 /*                          Shift-JIS methods                           */
2917 /************************************************************************/
2918
2919 /* Shift-JIS is a coding system encoding three character sets: ASCII, right
2920    half of JISX0201-Kana, and JISX0208.  An ASCII character is encoded
2921    as is.  A character of JISX0201-Kana (DIMENSION1_CHARS94 character set) is
2922    encoded by "position-code + 0x80".  A character of JISX0208
2923    (DIMENSION2_CHARS94 character set) is encoded in 2-byte but two
2924    position-codes are divided and shifted so that it fit in the range
2925    below.
2926
2927    --- CODE RANGE of Shift-JIS ---
2928    (character set)      (range)
2929    ASCII                0x00 .. 0x7F
2930    JISX0201-Kana        0xA0 .. 0xDF
2931    JISX0208 (1st byte)  0x80 .. 0x9F and 0xE0 .. 0xEF
2932             (2nd byte)  0x40 .. 0x7E and 0x80 .. 0xFC
2933    -------------------------------
2934
2935 */
2936
2937 /* Is this the first byte of a Shift-JIS two-byte char? */
2938
2939 #define BYTE_SJIS_TWO_BYTE_1_P(c) \
2940   (((c) >= 0x81 && (c) <= 0x9F) || ((c) >= 0xE0 && (c) <= 0xEF))
2941
2942 /* Is this the second byte of a Shift-JIS two-byte char? */
2943
2944 #define BYTE_SJIS_TWO_BYTE_2_P(c) \
2945   (((c) >= 0x40 && (c) <= 0x7E) || ((c) >= 0x80 && (c) <= 0xFC))
2946
2947 #define BYTE_SJIS_KATAKANA_P(c) \
2948   ((c) >= 0xA1 && (c) <= 0xDF)
2949
2950 static int
2951 detect_coding_sjis (struct detection_state *st, CONST unsigned char *src,
2952                     unsigned int n)
2953 {
2954   int c;
2955
2956   while (n--)
2957     {
2958       c = *src++;
2959       if (c == ISO_CODE_ESC || c == ISO_CODE_SI || c == ISO_CODE_SO)
2960         return 0;
2961       if (st->shift_jis.in_second_byte)
2962         {
2963           st->shift_jis.in_second_byte = 0;
2964           if (c < 0x40)
2965             return 0;
2966         }
2967       else if ((c >= 0x80 && c < 0xA0) || c >= 0xE0)
2968         st->shift_jis.in_second_byte = 1;
2969     }
2970   return CODING_CATEGORY_SHIFT_JIS_MASK;
2971 }
2972
2973 /* Convert Shift-JIS data to internal format. */
2974
2975 static void
2976 decode_coding_sjis (Lstream *decoding, CONST unsigned char *src,
2977                     unsigned_char_dynarr *dst, unsigned int n)
2978 {
2979   unsigned char c;
2980   struct decoding_stream *str = DECODING_STREAM_DATA (decoding);
2981   unsigned int flags  = str->flags;
2982   unsigned int ch     = str->ch;
2983   eol_type_t eol_type = str->eol_type;
2984
2985   while (n--)
2986     {
2987       c = *src++;
2988
2989       if (ch)
2990         {
2991           /* Previous character was first byte of Shift-JIS Kanji char. */
2992           if (BYTE_SJIS_TWO_BYTE_2_P (c))
2993             {
2994               unsigned char e1, e2;
2995
2996               Dynarr_add (dst, LEADING_BYTE_JAPANESE_JISX0208);
2997               DECODE_SJIS (ch, c, e1, e2);
2998               Dynarr_add (dst, e1);
2999               Dynarr_add (dst, e2);
3000             }
3001           else
3002             {
3003               DECODE_ADD_BINARY_CHAR (ch, dst);
3004               DECODE_ADD_BINARY_CHAR (c, dst);
3005             }
3006           ch = 0;
3007         }
3008       else
3009         {
3010           DECODE_HANDLE_EOL_TYPE (eol_type, c, flags, dst);
3011           if (BYTE_SJIS_TWO_BYTE_1_P (c))
3012             ch = c;
3013           else if (BYTE_SJIS_KATAKANA_P (c))
3014             {
3015               Dynarr_add (dst, LEADING_BYTE_KATAKANA_JISX0201);
3016               Dynarr_add (dst, c);
3017             }
3018           else
3019             DECODE_ADD_BINARY_CHAR (c, dst);
3020         }
3021     label_continue_loop:;
3022     }
3023
3024   DECODE_HANDLE_END_OF_CONVERSION (flags, ch, dst);
3025
3026   str->flags = flags;
3027   str->ch    = ch;
3028 }
3029
3030 /* Convert internally-formatted data to Shift-JIS. */
3031
3032 static void
3033 encode_coding_sjis (Lstream *encoding, CONST unsigned char *src,
3034                     unsigned_char_dynarr *dst, unsigned int n)
3035 {
3036   unsigned char c;
3037   struct encoding_stream *str = ENCODING_STREAM_DATA (encoding);
3038   unsigned int flags  = str->flags;
3039   unsigned int ch     = str->ch;
3040   eol_type_t eol_type = CODING_SYSTEM_EOL_TYPE (str->codesys);
3041
3042   while (n--)
3043     {
3044       c = *src++;
3045       if (c == '\n')
3046         {
3047           if (eol_type != EOL_LF && eol_type != EOL_AUTODETECT)
3048             Dynarr_add (dst, '\r');
3049           if (eol_type != EOL_CR)
3050             Dynarr_add (dst, '\n');
3051           ch = 0;
3052         }
3053       else if (BYTE_ASCII_P (c))
3054         {
3055           Dynarr_add (dst, c);
3056           ch = 0;
3057         }
3058       else if (BUFBYTE_LEADING_BYTE_P (c))
3059         ch = (c == LEADING_BYTE_KATAKANA_JISX0201 ||
3060               c == LEADING_BYTE_JAPANESE_JISX0208_1978 ||
3061               c == LEADING_BYTE_JAPANESE_JISX0208) ? c : 0;
3062       else if (ch)
3063         {
3064           if (ch == LEADING_BYTE_KATAKANA_JISX0201)
3065             {
3066               Dynarr_add (dst, c);
3067               ch = 0;
3068             }
3069           else if (ch == LEADING_BYTE_JAPANESE_JISX0208_1978 ||
3070                    ch == LEADING_BYTE_JAPANESE_JISX0208)
3071             ch = c;
3072           else
3073             {
3074               unsigned char j1, j2;
3075               ENCODE_SJIS (ch, c, j1, j2);
3076               Dynarr_add (dst, j1);
3077               Dynarr_add (dst, j2);
3078               ch = 0;
3079             }
3080         }
3081     }
3082
3083   str->flags = flags;
3084   str->ch    = ch;
3085 }
3086
3087 DEFUN ("decode-shift-jis-char", Fdecode_shift_jis_char, 1, 1, 0, /*
3088 Decode a JISX0208 character of Shift-JIS coding-system.
3089 CODE is the character code in Shift-JIS as a cons of type bytes.
3090 Return the corresponding character.
3091 */
3092        (code))
3093 {
3094   unsigned char c1, c2, s1, s2;
3095
3096   CHECK_CONS (code);
3097   CHECK_INT (XCAR (code));
3098   CHECK_INT (XCDR (code));
3099   s1 = XINT (XCAR (code));
3100   s2 = XINT (XCDR (code));
3101   if (BYTE_SJIS_TWO_BYTE_1_P (s1) &&
3102       BYTE_SJIS_TWO_BYTE_2_P (s2))
3103     {
3104       DECODE_SJIS (s1, s2, c1, c2);
3105       return make_char (MAKE_CHAR (Vcharset_japanese_jisx0208,
3106                                    c1 & 0x7F, c2 & 0x7F));
3107     }
3108   else
3109     return Qnil;
3110 }
3111
3112 DEFUN ("encode-shift-jis-char", Fencode_shift_jis_char, 1, 1, 0, /*
3113 Encode a JISX0208 character CHAR to SHIFT-JIS coding-system.
3114 Return the corresponding character code in SHIFT-JIS as a cons of two bytes.
3115 */
3116        (ch))
3117 {
3118   Lisp_Object charset;
3119   int c1, c2, s1, s2;
3120
3121   CHECK_CHAR_COERCE_INT (ch);
3122   BREAKUP_CHAR (XCHAR (ch), charset, c1, c2);
3123   if (EQ (charset, Vcharset_japanese_jisx0208))
3124     {
3125       ENCODE_SJIS (c1 | 0x80, c2 | 0x80, s1, s2);
3126       return Fcons (make_int (s1), make_int (s2));
3127     }
3128   else
3129     return Qnil;
3130 }
3131
3132 \f
3133 /************************************************************************/
3134 /*                            Big5 methods                              */
3135 /************************************************************************/
3136
3137 /* BIG5 is a coding system encoding two character sets: ASCII and
3138    Big5.  An ASCII character is encoded as is.  Big5 is a two-byte
3139    character set and is encoded in two-byte.
3140
3141    --- CODE RANGE of BIG5 ---
3142    (character set)      (range)
3143    ASCII                0x00 .. 0x7F
3144    Big5 (1st byte)      0xA1 .. 0xFE
3145         (2nd byte)      0x40 .. 0x7E and 0xA1 .. 0xFE
3146    --------------------------
3147
3148    Since the number of characters in Big5 is larger than maximum
3149    characters in Emacs' charset (96x96), it can't be handled as one
3150    charset.  So, in Emacs, Big5 is divided into two: `charset-big5-1'
3151    and `charset-big5-2'.  Both <type>s are DIMENSION2_CHARS94.  The former
3152    contains frequently used characters and the latter contains less
3153    frequently used characters.  */
3154
3155 #define BYTE_BIG5_TWO_BYTE_1_P(c) \
3156   ((c) >= 0xA1 && (c) <= 0xFE)
3157
3158 /* Is this the second byte of a Shift-JIS two-byte char? */
3159
3160 #define BYTE_BIG5_TWO_BYTE_2_P(c) \
3161   (((c) >= 0x40 && (c) <= 0x7E) || ((c) >= 0xA1 && (c) <= 0xFE))
3162
3163 /* Number of Big5 characters which have the same code in 1st byte.  */
3164
3165 #define BIG5_SAME_ROW (0xFF - 0xA1 + 0x7F - 0x40)
3166
3167 /* Code conversion macros.  These are macros because they are used in
3168    inner loops during code conversion.
3169
3170    Note that temporary variables in macros introduce the classic
3171    dynamic-scoping problems with variable names.  We use capital-
3172    lettered variables in the assumption that XEmacs does not use
3173    capital letters in variables except in a very formalized way
3174    (e.g. Qstring). */
3175
3176 /* Convert Big5 code (b1, b2) into its internal string representation
3177    (lb, c1, c2). */
3178
3179 /* There is a much simpler way to split the Big5 charset into two.
3180    For the moment I'm going to leave the algorithm as-is because it
3181    claims to separate out the most-used characters into a single
3182    charset, which perhaps will lead to optimizations in various
3183    places.
3184
3185    The way the algorithm works is something like this:
3186
3187    Big5 can be viewed as a 94x157 charset, where the row is
3188    encoded into the bytes 0xA1 .. 0xFE and the column is encoded
3189    into the bytes 0x40 .. 0x7E and 0xA1 .. 0xFE.  As for frequency,
3190    the split between low and high column numbers is apparently
3191    meaningless; ascending rows produce less and less frequent chars.
3192    Therefore, we assign the lower half of rows (0xA1 .. 0xC8) to
3193    the first charset, and the upper half (0xC9 .. 0xFE) to the
3194    second.  To do the conversion, we convert the character into
3195    a single number where 0 .. 156 is the first row, 157 .. 313
3196    is the second, etc.  That way, the characters are ordered by
3197    decreasing frequency.  Then we just chop the space in two
3198    and coerce the result into a 94x94 space.
3199    */
3200
3201 #define DECODE_BIG5(b1, b2, lb, c1, c2) do                              \
3202 {                                                                       \
3203   int B1 = b1, B2 = b2;                                                 \
3204   unsigned int I                                                        \
3205     = (B1 - 0xA1) * BIG5_SAME_ROW + B2 - (B2 < 0x7F ? 0x40 : 0x62);     \
3206                                                                         \
3207   if (B1 < 0xC9)                                                        \
3208     {                                                                   \
3209       lb = LEADING_BYTE_CHINESE_BIG5_1;                                 \
3210     }                                                                   \
3211   else                                                                  \
3212     {                                                                   \
3213       lb = LEADING_BYTE_CHINESE_BIG5_2;                                 \
3214       I -= (BIG5_SAME_ROW) * (0xC9 - 0xA1);                             \
3215     }                                                                   \
3216   c1 = I / (0xFF - 0xA1) + 0xA1;                                        \
3217   c2 = I % (0xFF - 0xA1) + 0xA1;                                        \
3218 } while (0)
3219
3220 /* Convert the internal string representation of a Big5 character
3221    (lb, c1, c2) into Big5 code (b1, b2). */
3222
3223 #define ENCODE_BIG5(lb, c1, c2, b1, b2) do                              \
3224 {                                                                       \
3225   unsigned int I = ((c1) - 0xA1) * (0xFF - 0xA1) + ((c2) - 0xA1);       \
3226                                                                         \
3227   if (lb == LEADING_BYTE_CHINESE_BIG5_2)                                \
3228     {                                                                   \
3229       I += BIG5_SAME_ROW * (0xC9 - 0xA1);                               \
3230     }                                                                   \
3231   b1 = I / BIG5_SAME_ROW + 0xA1;                                        \
3232   b2 = I % BIG5_SAME_ROW;                                               \
3233   b2 += b2 < 0x3F ? 0x40 : 0x62;                                        \
3234 } while (0)
3235
3236 static int
3237 detect_coding_big5 (struct detection_state *st, CONST unsigned char *src,
3238                     unsigned int n)
3239 {
3240   int c;
3241
3242   while (n--)
3243     {
3244       c = *src++;
3245       if (c == ISO_CODE_ESC || c == ISO_CODE_SI || c == ISO_CODE_SO ||
3246           (c >= 0x80 && c <= 0xA0))
3247         return 0;
3248       if (st->big5.in_second_byte)
3249         {
3250           st->big5.in_second_byte = 0;
3251           if (c < 0x40 || (c >= 0x80 && c <= 0xA0))
3252             return 0;
3253         }
3254       else if (c >= 0xA1)
3255         st->big5.in_second_byte = 1;
3256     }
3257   return CODING_CATEGORY_BIG5_MASK;
3258 }
3259
3260 /* Convert Big5 data to internal format. */
3261
3262 static void
3263 decode_coding_big5 (Lstream *decoding, CONST unsigned char *src,
3264                     unsigned_char_dynarr *dst, unsigned int n)
3265 {
3266   unsigned char c;
3267   struct decoding_stream *str = DECODING_STREAM_DATA (decoding);
3268   unsigned int flags  = str->flags;
3269   unsigned int ch     = str->ch;
3270   eol_type_t eol_type = str->eol_type;
3271
3272   while (n--)
3273     {
3274       c = *src++;
3275       if (ch)
3276         {
3277           /* Previous character was first byte of Big5 char. */
3278           if (BYTE_BIG5_TWO_BYTE_2_P (c))
3279             {
3280               unsigned char b1, b2, b3;
3281               DECODE_BIG5 (ch, c, b1, b2, b3);
3282               Dynarr_add (dst, b1);
3283               Dynarr_add (dst, b2);
3284               Dynarr_add (dst, b3);
3285             }
3286           else
3287             {
3288               DECODE_ADD_BINARY_CHAR (ch, dst);
3289               DECODE_ADD_BINARY_CHAR (c, dst);
3290             }
3291           ch = 0;
3292         }
3293       else
3294         {
3295           DECODE_HANDLE_EOL_TYPE (eol_type, c, flags, dst);
3296           if (BYTE_BIG5_TWO_BYTE_1_P (c))
3297             ch = c;
3298           else
3299             DECODE_ADD_BINARY_CHAR (c, dst);
3300         }
3301     label_continue_loop:;
3302     }
3303
3304   DECODE_HANDLE_END_OF_CONVERSION (flags, ch, dst);
3305
3306   str->flags = flags;
3307   str->ch    = ch;
3308 }
3309
3310 /* Convert internally-formatted data to Big5. */
3311
3312 static void
3313 encode_coding_big5 (Lstream *encoding, CONST unsigned char *src,
3314                     unsigned_char_dynarr *dst, unsigned int n)
3315 {
3316   unsigned char c;
3317   struct encoding_stream *str = ENCODING_STREAM_DATA (encoding);
3318   unsigned int flags  = str->flags;
3319   unsigned int ch     = str->ch;
3320   eol_type_t eol_type = CODING_SYSTEM_EOL_TYPE (str->codesys);
3321
3322   while (n--)
3323     {
3324       c = *src++;
3325       if (c == '\n')
3326         {
3327           if (eol_type != EOL_LF && eol_type != EOL_AUTODETECT)
3328             Dynarr_add (dst, '\r');
3329           if (eol_type != EOL_CR)
3330             Dynarr_add (dst, '\n');
3331         }
3332       else if (BYTE_ASCII_P (c))
3333         {
3334           /* ASCII. */
3335           Dynarr_add (dst, c);
3336         }
3337       else if (BUFBYTE_LEADING_BYTE_P (c))
3338         {
3339           if (c == LEADING_BYTE_CHINESE_BIG5_1 ||
3340               c == LEADING_BYTE_CHINESE_BIG5_2)
3341             {
3342               /* A recognized leading byte. */
3343               ch = c;
3344               continue; /* not done with this character. */
3345             }
3346           /* otherwise just ignore this character. */
3347         }
3348       else if (ch == LEADING_BYTE_CHINESE_BIG5_1 ||
3349                ch == LEADING_BYTE_CHINESE_BIG5_2)
3350         {
3351           /* Previous char was a recognized leading byte. */
3352           ch = (ch << 8) | c;
3353           continue; /* not done with this character. */
3354         }
3355       else if (ch)
3356         {
3357           /* Encountering second byte of a Big5 character. */
3358           unsigned char b1, b2;
3359
3360           ENCODE_BIG5 (ch >> 8, ch & 0xFF, c, b1, b2);
3361           Dynarr_add (dst, b1);
3362           Dynarr_add (dst, b2);
3363         }
3364
3365       ch = 0;
3366     }
3367
3368   str->flags = flags;
3369   str->ch    = ch;
3370 }
3371
3372
3373 DEFUN ("decode-big5-char", Fdecode_big5_char, 1, 1, 0, /*
3374 Decode a Big5 character CODE of BIG5 coding-system.
3375 CODE is the character code in BIG5, a cons of two integers.
3376 Return the corresponding character.
3377 */
3378        (code))
3379 {
3380   unsigned char c1, c2, b1, b2;
3381
3382   CHECK_CONS (code);
3383   CHECK_INT (XCAR (code));
3384   CHECK_INT (XCDR (code));
3385   b1 = XINT (XCAR (code));
3386   b2 = XINT (XCDR (code));
3387   if (BYTE_BIG5_TWO_BYTE_1_P (b1) &&
3388       BYTE_BIG5_TWO_BYTE_2_P (b2))
3389     {
3390       int leading_byte;
3391       Lisp_Object charset;
3392       DECODE_BIG5 (b1, b2, leading_byte, c1, c2);
3393       charset = CHARSET_BY_LEADING_BYTE (leading_byte);
3394       return make_char (MAKE_CHAR (charset, c1 & 0x7F, c2 & 0x7F));
3395     }
3396   else
3397     return Qnil;
3398 }
3399
3400 DEFUN ("encode-big5-char", Fencode_big5_char, 1, 1, 0, /*
3401 Encode the Big5 character CH to BIG5 coding-system.
3402 Return the corresponding character code in Big5.
3403 */
3404        (ch))
3405 {
3406   Lisp_Object charset;
3407   int c1, c2, b1, b2;
3408
3409   CHECK_CHAR_COERCE_INT (ch);
3410   BREAKUP_CHAR (XCHAR (ch), charset, c1, c2);
3411   if (EQ (charset, Vcharset_chinese_big5_1) ||
3412       EQ (charset, Vcharset_chinese_big5_2))
3413     {
3414       ENCODE_BIG5 (XCHARSET_LEADING_BYTE (charset), c1 | 0x80, c2 | 0x80,
3415                    b1, b2);
3416       return Fcons (make_int (b1), make_int (b2));
3417     }
3418   else
3419     return Qnil;
3420 }
3421
3422 \f
3423 /************************************************************************/
3424 /*                           UCS-4 methods                              */
3425 /*                                                                      */
3426 /*  UCS-4 character codes are implemented as nonnegative integers.      */
3427 /*                                                                      */
3428 /************************************************************************/
3429
3430
3431 DEFUN ("set-ucs-char", Fset_ucs_char, 2, 2, 0, /*
3432 Map UCS-4 code CODE to Mule character CHARACTER.
3433
3434 Return T on success, NIL on failure.
3435 */
3436        (code, character))
3437 {
3438   unsigned int c;
3439
3440   CHECK_CHAR (character);
3441   CHECK_INT (code);
3442   c = XINT (code);
3443
3444   if (c < sizeof (fcd->ucs_to_mule_table))
3445     {
3446       fcd->ucs_to_mule_table[c] = character;
3447       return Qt;
3448     }
3449   else
3450     return Qnil;
3451 }
3452
3453 static Lisp_Object
3454 ucs_to_char (unsigned long code)
3455 {
3456   if (code < sizeof (fcd->ucs_to_mule_table))
3457     {
3458       return fcd->ucs_to_mule_table[code];
3459     }
3460   else if ((0xe00000 <= code) && (code <= 0xe00000 + 94 * 94 * 14))
3461     {
3462       unsigned int c;
3463
3464       code -= 0xe00000;
3465       c = code % (94 * 94);
3466       return make_char
3467         (MAKE_CHAR (CHARSET_BY_ATTRIBUTES
3468                     (CHARSET_TYPE_94X94, code / (94 * 94) + '@',
3469                      CHARSET_LEFT_TO_RIGHT),
3470                     c / 94 + 33, c % 94 + 33));
3471     }
3472   else
3473     return Qnil;
3474 }
3475
3476 DEFUN ("ucs-char", Fucs_char, 1, 1, 0, /*
3477 Return Mule character corresponding to UCS code CODE (a positive integer).
3478 */
3479        (code))
3480 {
3481   CHECK_NATNUM (code);
3482   return ucs_to_char (XINT (code));
3483 }
3484
3485 DEFUN ("set-char-ucs", Fset_char_ucs, 2, 2, 0, /*
3486 Map Mule character CHARACTER to UCS code CODE (a positive integer).