Function: define-coding-system-internal

define-coding-system-internal is a function defined in coding.c.

Signature

(define-coding-system-internal ...)

Documentation

For internal use only.

Source Code

// Defined in /usr/src/emacs/src/coding.c
// Skipping highlighting due to helpful-max-highlight.
{
  enum coding_category category;
  int max_charset_id = 0;

  if (nargs < coding_arg_max)
    goto short_args;

  Lisp_Object attrs = make_nil_vector (coding_attr_last_index);

  Lisp_Object name = args[coding_arg_name];
  CHECK_SYMBOL (name);
  ASET (attrs, coding_attr_base_name, name);

  Lisp_Object val = args[coding_arg_mnemonic];
  /* decode_mode_spec_coding assumes the mnemonic is a single character.  */
  if (STRINGP (val))
    val = make_fixnum (STRING_CHAR (SDATA (val)));
  else
    CHECK_CHARACTER (val);
  ASET (attrs, coding_attr_mnemonic, val);

  Lisp_Object coding_type = args[coding_arg_coding_type];
  CHECK_SYMBOL (coding_type);
  ASET (attrs, coding_attr_type, coding_type);

  Lisp_Object charset_list = args[coding_arg_charset_list];
  if (SYMBOLP (charset_list))
    {
      if (EQ (charset_list, Qiso_2022))
	{
	  if (! EQ (coding_type, Qiso_2022))
	    error ("Invalid charset-list");
	  charset_list = Viso_2022_charset_list;
	}
      else if (EQ (charset_list, Qemacs_mule))
	{
	  if (! EQ (coding_type, Qemacs_mule))
	    error ("Invalid charset-list");
	  charset_list = Vemacs_mule_charset_list;
	}
      for (Lisp_Object tail = charset_list; CONSP (tail); tail = XCDR (tail))
	{
	  if (! RANGED_FIXNUMP (0, XCAR (tail), INT_MAX - 1))
	    error ("Invalid charset-list");
	  if (max_charset_id < XFIXNAT (XCAR (tail)))
	    max_charset_id = XFIXNAT (XCAR (tail));
	}
    }
  else
    {
      charset_list = Fcopy_sequence (charset_list);
      for (Lisp_Object tail = charset_list; CONSP (tail); tail = XCDR (tail))
	{
	  struct charset *charset;

	  val = XCAR (tail);
	  CHECK_CHARSET_GET_CHARSET (val, charset);
	  if (EQ (coding_type, Qiso_2022)
	      ? CHARSET_ISO_FINAL (charset) < 0
	      : EQ (coding_type, Qemacs_mule)
	      ? CHARSET_EMACS_MULE_ID (charset) < 0
	      : 0)
	    error ("Can't handle charset `%s'",
		   SDATA (SYMBOL_NAME (CHARSET_NAME (charset))));

	  XSETCAR (tail, make_fixnum (charset->id));
	  if (max_charset_id < charset->id)
	    max_charset_id = charset->id;
	}
    }
  ASET (attrs, coding_attr_charset_list, charset_list);

  Lisp_Object safe_charsets = make_uninit_string (max_charset_id + 1);
  memset (SDATA (safe_charsets), 255, max_charset_id + 1);
  for (Lisp_Object tail = charset_list; CONSP (tail); tail = XCDR (tail))
    SSET (safe_charsets, XFIXNAT (XCAR (tail)), 0);
  ASET (attrs, coding_attr_safe_charsets, safe_charsets);

  ASET (attrs, coding_attr_ascii_compat, args[coding_arg_ascii_compatible_p]);

  val = args[coding_arg_decode_translation_table];
  if (! CHAR_TABLE_P (val) && ! CONSP (val))
    CHECK_SYMBOL (val);
  ASET (attrs, coding_attr_decode_tbl, val);

  val = args[coding_arg_encode_translation_table];
  if (! CHAR_TABLE_P (val) && ! CONSP (val))
    CHECK_SYMBOL (val);
  ASET (attrs, coding_attr_encode_tbl, val);

  val = args[coding_arg_post_read_conversion];
  CHECK_SYMBOL (val);
  ASET (attrs, coding_attr_post_read, val);

  val = args[coding_arg_pre_write_conversion];
  CHECK_SYMBOL (val);
  ASET (attrs, coding_attr_pre_write, val);

  val = args[coding_arg_default_char];
  if (NILP (val))
    ASET (attrs, coding_attr_default_char, make_fixnum (' '));
  else
    {
      CHECK_CHARACTER (val);
      ASET (attrs, coding_attr_default_char, val);
    }

  val = args[coding_arg_for_unibyte];
  ASET (attrs, coding_attr_for_unibyte, NILP (val) ? Qnil : Qt);

  val = args[coding_arg_plist];
  CHECK_LIST (val);
  ASET (attrs, coding_attr_plist, val);

  if (EQ (coding_type, Qcharset))
    {
      /* Generate a lisp vector of 256 elements.  Each element is nil,
	 integer, or a list of charset IDs.

	 If Nth element is nil, the byte code N is invalid in this
	 coding system.

	 If Nth element is a number NUM, N is the first byte of a
	 charset whose ID is NUM.

	 If Nth element is a list of charset IDs, N is the first byte
	 of one of them.  The list is sorted by dimensions of the
	 charsets.  A charset of smaller dimension comes first. */
      val = make_nil_vector (256);

      for (Lisp_Object tail = charset_list; CONSP (tail); tail = XCDR (tail))
	{
	  struct charset *charset = CHARSET_FROM_ID (XFIXNAT (XCAR (tail)));
	  int dim = CHARSET_DIMENSION (charset);
	  int idx = (dim - 1) * 4;

	  if (CHARSET_ASCII_COMPATIBLE_P (charset))
	    ASET (attrs, coding_attr_ascii_compat, Qt);

	  for (int i = charset->code_space[idx];
	       i <= charset->code_space[idx + 1]; i++)
	    {
	      Lisp_Object tmp, tmp2;
	      int dim2;

	      tmp = AREF (val, i);
	      if (NILP (tmp))
		tmp = XCAR (tail);
	      else if (FIXNATP (tmp))
		{
		  dim2 = CHARSET_DIMENSION (CHARSET_FROM_ID (XFIXNAT (tmp)));
		  if (dim < dim2)
		    tmp = list2 (XCAR (tail), tmp);
		  else
		    tmp = list2 (tmp, XCAR (tail));
		}
	      else
		{
		  for (tmp2 = tmp; CONSP (tmp2); tmp2 = XCDR (tmp2))
		    {
		      dim2 = CHARSET_DIMENSION (CHARSET_FROM_ID (XFIXNAT (XCAR (tmp2))));
		      if (dim < dim2)
			break;
		    }
		  if (NILP (tmp2))
		    tmp = nconc2 (tmp, list1 (XCAR (tail)));
		  else
		    {
		      XSETCDR (tmp2, Fcons (XCAR (tmp2), XCDR (tmp2)));
		      XSETCAR (tmp2, XCAR (tail));
		    }
		}
	      ASET (val, i, tmp);
	    }
	}
      ASET (attrs, coding_attr_charset_valids, val);
      category = coding_category_charset;
    }
  else if (EQ (coding_type, Qccl))
    {
      Lisp_Object valids;

      if (nargs < coding_arg_ccl_max)
	goto short_args;

      val = args[coding_arg_ccl_decoder];
      CHECK_CCL_PROGRAM (val);
      if (VECTORP (val))
	val = Fcopy_sequence (val);
      ASET (attrs, coding_attr_ccl_decoder, val);

      val = args[coding_arg_ccl_encoder];
      CHECK_CCL_PROGRAM (val);
      if (VECTORP (val))
	val = Fcopy_sequence (val);
      ASET (attrs, coding_attr_ccl_encoder, val);

      val = args[coding_arg_ccl_valids];
      valids = Fmake_string (make_fixnum (256), make_fixnum (0), Qnil);
      for (Lisp_Object tail = val; CONSP (tail); tail = XCDR (tail))
	{
	  int from, to;

	  val = XCAR (tail);
	  if (FIXNUMP (val))
	    {
	      if (! (0 <= XFIXNUM (val) && XFIXNUM (val) <= 255))
		args_out_of_range_3 (val, make_fixnum (0), make_fixnum (255));
	      from = to = XFIXNUM (val);
	    }
	  else
	    {
	      CHECK_CONS (val);
	      from = check_integer_range (XCAR (val), 0, 255);
	      to = check_integer_range (XCDR (val), from, 255);
	    }
	  for (int i = from; i <= to; i++)
	    SSET (valids, i, 1);
	}
      ASET (attrs, coding_attr_ccl_valids, valids);

      category = coding_category_ccl;
    }
  else if (EQ (coding_type, Qutf_16))
    {
      Lisp_Object bom, endian;

      ASET (attrs, coding_attr_ascii_compat, Qnil);

      if (nargs < coding_arg_utf16_max)
	goto short_args;

      bom = args[coding_arg_utf16_bom];
      if (! NILP (bom) && ! EQ (bom, Qt))
	{
	  CHECK_CONS (bom);
	  val = XCAR (bom);
	  CHECK_CODING_SYSTEM (val);
	  val = XCDR (bom);
	  CHECK_CODING_SYSTEM (val);
	}
      ASET (attrs, coding_attr_utf_bom, bom);

      endian = args[coding_arg_utf16_endian];
      CHECK_SYMBOL (endian);
      if (NILP (endian))
	endian = Qbig;
      else if (! EQ (endian, Qbig) && ! EQ (endian, Qlittle))
	error ("Invalid endian: %s", SDATA (SYMBOL_NAME (endian)));
      ASET (attrs, coding_attr_utf_16_endian, endian);

      category = (CONSP (bom)
		  ? coding_category_utf_16_auto
		  : NILP (bom)
		  ? (EQ (endian, Qbig)
		     ? coding_category_utf_16_be_nosig
		     : coding_category_utf_16_le_nosig)
		  : (EQ (endian, Qbig)
		     ? coding_category_utf_16_be
		     : coding_category_utf_16_le));
    }
  else if (EQ (coding_type, Qiso_2022))
    {
      Lisp_Object initial, reg_usage, request, flags;

      if (nargs < coding_arg_iso2022_max)
	goto short_args;

      initial = Fcopy_sequence (args[coding_arg_iso2022_initial]);
      CHECK_VECTOR (initial);
      for (int i = 0; i < 4; i++)
	{
	  val = AREF (initial, i);
	  if (! NILP (val))
	    {
	      struct charset *charset;

	      CHECK_CHARSET_GET_CHARSET (val, charset);
	      ASET (initial, i, make_fixnum (CHARSET_ID (charset)));
	      if (i == 0 && CHARSET_ASCII_COMPATIBLE_P (charset))
		ASET (attrs, coding_attr_ascii_compat, Qt);
	    }
	  else
	    ASET (initial, i, make_fixnum (-1));
	}

      reg_usage = args[coding_arg_iso2022_reg_usage];
      CHECK_CONS (reg_usage);
      CHECK_FIXNUM (XCAR (reg_usage));
      CHECK_FIXNUM (XCDR (reg_usage));

      request = Fcopy_sequence (args[coding_arg_iso2022_request]);
      for (Lisp_Object tail = request; CONSP (tail); tail = XCDR (tail))
	{
	  int id;

	  val = XCAR (tail);
	  CHECK_CONS (val);
	  CHECK_CHARSET_GET_ID (XCAR (val), id);
	  check_integer_range (XCDR (val), 0, 3);
	  XSETCAR (val, make_fixnum (id));
	}

      flags = args[coding_arg_iso2022_flags];
      CHECK_FIXNAT (flags);
      int i = XFIXNUM (flags) & INT_MAX;
      if (EQ (args[coding_arg_charset_list], Qiso_2022))
	i |= CODING_ISO_FLAG_FULL_SUPPORT;
      flags = make_fixnum (i);

      ASET (attrs, coding_attr_iso_initial, initial);
      ASET (attrs, coding_attr_iso_usage, reg_usage);
      ASET (attrs, coding_attr_iso_request, request);
      ASET (attrs, coding_attr_iso_flags, flags);
      setup_iso_safe_charsets (attrs);

      if (i & CODING_ISO_FLAG_SEVEN_BITS)
	category = ((i & (CODING_ISO_FLAG_LOCKING_SHIFT
			  | CODING_ISO_FLAG_SINGLE_SHIFT))
		    ? coding_category_iso_7_else
		    : EQ (args[coding_arg_charset_list], Qiso_2022)
		    ? coding_category_iso_7
		    : coding_category_iso_7_tight);
      else
	{
	  int id = XFIXNUM (AREF (initial, 1));

	  category = (((i & CODING_ISO_FLAG_LOCKING_SHIFT)
		       || EQ (args[coding_arg_charset_list], Qiso_2022)
		       || id < 0)
		      ? coding_category_iso_8_else
		      : (CHARSET_DIMENSION (CHARSET_FROM_ID (id)) == 1)
		      ? coding_category_iso_8_1
		      : coding_category_iso_8_2);
	}
      if (category != coding_category_iso_8_1
	  && category != coding_category_iso_8_2)
	ASET (attrs, coding_attr_ascii_compat, Qnil);
    }
  else if (EQ (coding_type, Qemacs_mule))
    {
      if (EQ (args[coding_arg_charset_list], Qemacs_mule))
	ASET (attrs, coding_attr_emacs_mule_full, Qt);
      ASET (attrs, coding_attr_ascii_compat, Qt);
      category = coding_category_emacs_mule;
    }
  else if (EQ (coding_type, Qshift_jis))
    {
      ptrdiff_t charset_list_len = list_length (charset_list);
      if (charset_list_len != 3 && charset_list_len != 4)
	error ("There should be three or four charsets");

      struct charset *charset = CHARSET_FROM_ID (XFIXNUM (XCAR (charset_list)));
      if (CHARSET_DIMENSION (charset) != 1)
	error ("Dimension of charset %s is not one",
	       SDATA (SYMBOL_NAME (CHARSET_NAME (charset))));
      if (CHARSET_ASCII_COMPATIBLE_P (charset))
	ASET (attrs, coding_attr_ascii_compat, Qt);

      charset_list = XCDR (charset_list);
      charset = CHARSET_FROM_ID (XFIXNUM (XCAR (charset_list)));
      if (CHARSET_DIMENSION (charset) != 1)
	error ("Dimension of charset %s is not one",
	       SDATA (SYMBOL_NAME (CHARSET_NAME (charset))));

      charset_list = XCDR (charset_list);
      charset = CHARSET_FROM_ID (XFIXNUM (XCAR (charset_list)));
      if (CHARSET_DIMENSION (charset) != 2)
	error ("Dimension of charset %s is not two",
	       SDATA (SYMBOL_NAME (CHARSET_NAME (charset))));

      charset_list = XCDR (charset_list);
      if (! NILP (charset_list))
	{
	  charset = CHARSET_FROM_ID (XFIXNUM (XCAR (charset_list)));
	  if (CHARSET_DIMENSION (charset) != 2)
	    error ("Dimension of charset %s is not two",
		   SDATA (SYMBOL_NAME (CHARSET_NAME (charset))));
	}

      category = coding_category_sjis;
      Vsjis_coding_system = name;
    }
  else if (EQ (coding_type, Qbig5))
    {
      struct charset *charset;

      if (list_length (charset_list) != 2)
	error ("There should be just two charsets");

      charset = CHARSET_FROM_ID (XFIXNUM (XCAR (charset_list)));
      if (CHARSET_DIMENSION (charset) != 1)
	error ("Dimension of charset %s is not one",
	       SDATA (SYMBOL_NAME (CHARSET_NAME (charset))));
      if (CHARSET_ASCII_COMPATIBLE_P (charset))
	ASET (attrs, coding_attr_ascii_compat, Qt);

      charset_list = XCDR (charset_list);
      charset = CHARSET_FROM_ID (XFIXNUM (XCAR (charset_list)));
      if (CHARSET_DIMENSION (charset) != 2)
	error ("Dimension of charset %s is not two",
	       SDATA (SYMBOL_NAME (CHARSET_NAME (charset))));

      category = coding_category_big5;
      Vbig5_coding_system = name;
    }
  else if (EQ (coding_type, Qraw_text))
    {
      category = coding_category_raw_text;
      ASET (attrs, coding_attr_ascii_compat, Qt);
    }
  else if (EQ (coding_type, Qutf_8))
    {
      Lisp_Object bom;

      if (nargs < coding_arg_utf8_max)
	goto short_args;

      bom = args[coding_arg_utf8_bom];
      if (! NILP (bom) && ! EQ (bom, Qt))
	{
	  CHECK_CONS (bom);
	  val = XCAR (bom);
	  CHECK_CODING_SYSTEM (val);
	  val = XCDR (bom);
	  CHECK_CODING_SYSTEM (val);
	}
      ASET (attrs, coding_attr_utf_bom, bom);
      if (NILP (bom))
	ASET (attrs, coding_attr_ascii_compat, Qt);

      category = (CONSP (bom) ? coding_category_utf_8_auto
		  : NILP (bom) ? coding_category_utf_8_nosig
		  : coding_category_utf_8_sig);
    }
  else if (EQ (coding_type, Qundecided))
    {
      if (nargs < coding_arg_undecided_max)
	goto short_args;
      ASET (attrs, coding_attr_undecided_inhibit_null_byte_detection,
	    args[coding_arg_undecided_inhibit_null_byte_detection]);
      ASET (attrs, coding_attr_undecided_inhibit_iso_escape_detection,
	    args[coding_arg_undecided_inhibit_iso_escape_detection]);
      ASET (attrs, coding_attr_undecided_prefer_utf_8,
	    args[coding_arg_undecided_prefer_utf_8]);
      category = coding_category_undecided;
    }
  else
    error ("Invalid coding system type: %s",
	   SDATA (SYMBOL_NAME (coding_type)));

  ASET (attrs, coding_attr_category, make_fixnum (category));
  ASET (attrs, coding_attr_plist,
	Fcons (QCcategory,
	       Fcons (AREF (Vcoding_category_table, category),
		      CODING_ATTR_PLIST (attrs))));
  ASET (attrs, coding_attr_plist,
	Fcons (QCascii_compatible_p,
	       Fcons (CODING_ATTR_ASCII_COMPAT (attrs),
		      CODING_ATTR_PLIST (attrs))));

  Lisp_Object eol_type = args[coding_arg_eol_type];
  if (! NILP (eol_type)
      && ! EQ (eol_type, Qunix)
      && ! EQ (eol_type, Qdos)
      && ! EQ (eol_type, Qmac))
    error ("Invalid eol-type");

  Lisp_Object aliases = list1 (name);

  if (NILP (eol_type))
    {
      eol_type = make_subsidiaries (name);
      for (int i = 0; i < 3; i++)
	{
	  Lisp_Object this_spec, this_name, this_aliases, this_eol_type;

	  this_name = AREF (eol_type, i);
	  this_aliases = list1 (this_name);
	  this_eol_type = (i == 0 ? Qunix : i == 1 ? Qdos : Qmac);
	  this_spec = make_uninit_vector (3);
	  ASET (this_spec, 0, attrs);
	  ASET (this_spec, 1, this_aliases);
	  ASET (this_spec, 2, this_eol_type);
	  Fputhash (this_name, this_spec, Vcoding_system_hash_table);
	  Vcoding_system_list = Fcons (this_name, Vcoding_system_list);
	  val = Fassoc (Fsymbol_name (this_name), Vcoding_system_alist, Qnil);
	  if (NILP (val))
	    Vcoding_system_alist
	      = Fcons (Fcons (Fsymbol_name (this_name), Qnil),
		       Vcoding_system_alist);
	}
    }

  Lisp_Object spec_vec = make_uninit_vector (3);
  ASET (spec_vec, 0, attrs);
  ASET (spec_vec, 1, aliases);
  ASET (spec_vec, 2, eol_type);

  Fputhash (name, spec_vec, Vcoding_system_hash_table);
  Vcoding_system_list = Fcons (name, Vcoding_system_list);
  val = Fassoc (Fsymbol_name (name), Vcoding_system_alist, Qnil);
  if (NILP (val))
    Vcoding_system_alist = Fcons (Fcons (Fsymbol_name (name), Qnil),
				  Vcoding_system_alist);

  int id = coding_categories[category].id;
  if (id < 0 || EQ (name, CODING_ID_NAME (id)))
      setup_coding_system (name, &coding_categories[category]);

  return Qnil;

 short_args:
  Fsignal (Qwrong_number_of_arguments,
	   Fcons (intern ("define-coding-system-internal"),
		  make_fixnum (nargs)));
}