comparison src/lread.c @ 21724:12a826a37249

(read_from_string_index_byte): New variable. (read_from_string_index): Now counts characters. (readchar, unreadchar, Fread_from_string): Changed accordingly. (readchar): Read a multibyte char all at once from a buffer, marker or string. (unreadchar): Unread a multibyte char all at once. (read1): Properly handle non-escaped multibyte chars. They force a string to be multibyte. When reading direct from a file, any multibyte sequence means a multibyte string. Insist on MAX_LENGTH_OF_MULTI_BYTE_FORM bytes when checking for read_buffer full; this way need not check specially for multibyte.

21723:edc95c28d970

/* When nonzero, read conses in pure space */
static int read_pure;

/* For use within read-from-string (this reader is non-reentrant!!)  */
static int read_from_string_index;
static int read_from_string_limit;

/* Number of bytes left to read in the buffer character
   that `readchar' has already advanced over.  */
static int readchar_backlog;

static int
readchar (readcharfun)
     Lisp_Object readcharfun;
{
  Lisp_Object tem;
  register struct buffer *inbuffer;
  register int c, mpos;

  if (BUFFERP (readcharfun))
    {
      inbuffer = XBUFFER (readcharfun);

      if (readchar_backlog == 0)
	{
	  int pt_byte = BUF_PT_BYTE (inbuffer);
	  int orig_pt_byte = pt_byte;

	  if (pt_byte >= BUF_ZV_BYTE (inbuffer))
	    return -1;

	  if (! NILP (inbuffer->enable_multibyte_characters))
	    BUF_INC_POS (inbuffer, pt_byte);
	  else
	    pt_byte++;
	  SET_BUF_PT_BOTH (inbuffer, BUF_PT (inbuffer) + 1, pt_byte);
	  readchar_backlog = pt_byte - orig_pt_byte;
	}

      /* We get the address of the byte just passed,
	 which is the last byte of the character.
	 The other bytes in this character are consecutive with it,
	 because the gap can't be in the middle of a character.  */
      return *(BUF_BYTE_ADDRESS (inbuffer, BUF_PT_BYTE (inbuffer) - 1)
	       - --readchar_backlog);
    }
  if (MARKERP (readcharfun))
    {
      inbuffer = XMARKER (readcharfun)->buffer;

      if (readchar_backlog == 0)
	{
	  int bytepos = marker_byte_position (readcharfun);
	  int orig_bytepos = bytepos;

	  if (bytepos >= BUF_ZV_BYTE (inbuffer))
	    return -1;

	  if (! NILP (inbuffer->enable_multibyte_characters))
	    INC_POS (bytepos);
	  else
	    bytepos++;
	  XMARKER (readcharfun)->bytepos = bytepos;
	  XMARKER (readcharfun)->charpos++;

	  readchar_backlog = bytepos - orig_bytepos;
	}

      /* We get the address of the byte just passed,
	 which is the last byte of the character.
	 The other bytes in this character are consecutive with it,
	 because the gap can't be in the middle of a character.  */
      return *(BUF_BYTE_ADDRESS (inbuffer, XMARKER (readcharfun)->bytepos - 1)
	       - --readchar_backlog);
    }
  if (EQ (readcharfun, Qget_file_char))
    {
      c = getc (instream);
#ifdef EINTR

      return c;
    }

  if (STRINGP (readcharfun))
    {
      register int c;
      /* This used to be return of a conditional expression,
	 but that truncated -1 to a char on VMS.  */
      if (read_from_string_index < read_from_string_limit)
	c = XSTRING (readcharfun)->data[read_from_string_index++];
      else
	c = -1;

      return c;
    }

  tem = call0 (readcharfun);

    /* Don't back up the pointer if we're unreading the end-of-input mark,
       since readchar didn't advance it when we read it.  */
    ;
  else if (BUFFERP (readcharfun))
    {
      if (!SINGLE_BYTE_CHAR_P (c))
	readchar_backlog++;
      else
	{
	  struct buffer *b = XBUFFER (readcharfun);
	  int bytepos = BUF_PT_BYTE (b);

	  BUF_PT (b)--;
	  if (! NILP (b->enable_multibyte_characters))
	    BUF_DEC_POS (b, bytepos);
	  else
	    bytepos--;

	  BUF_PT_BYTE (b) = bytepos;
	}
    }
  else if (MARKERP (readcharfun))
    {
      if (!SINGLE_BYTE_CHAR_P (c))
	readchar_backlog++;
      else
	{
	  struct buffer *b = XMARKER (readcharfun)->buffer;
	  int bytepos = XMARKER (readcharfun)->bytepos;

	  XMARKER (readcharfun)->charpos--;
	  if (! NILP (b->enable_multibyte_characters))
	    BUF_DEC_POS (b, bytepos);
	  else
	    bytepos--;

	  XMARKER (readcharfun)->bytepos = bytepos;
	}
    }
  else if (STRINGP (readcharfun))
    read_from_string_index--;
  else if (EQ (readcharfun, Qget_file_char))
    ungetc (c, instream);
  else
    call1 (readcharfun, make_number (c));
}

static Lisp_Object read0 (), read1 (), read_list (), read_vector ();
static int read_multibyte ();

/* get a character from the tty */

extern Lisp_Object read_char ();

/* Read input events until we get one that's acceptable for our purposes.

  Lisp_Object tem;

  CHECK_STRING (string,0);

  if (NILP (end))
    endval = STRING_BYTES (XSTRING (string));
  else
    {
      CHECK_NUMBER (end, 2);
      endval = string_char_to_byte (string, XINT (end));
      if (endval < 0 || endval > STRING_BYTES (XSTRING (string)))
	args_out_of_range (string, end);
    }

  if (NILP (start))
    startval = 0;
  else
    {
      CHECK_NUMBER (start, 1);
      startval = string_char_to_byte (string, XINT (start));
      if (startval < 0 || startval > endval)
	args_out_of_range (string, start);
    }

  read_from_string_index = startval;
  read_from_string_limit = endval;

  new_backquote_flag = 0;
  read_objects = Qnil;

  tem = read0 (string);
  endval = string_byte_to_char (string,
				read_from_string_index);
  return Fcons (tem, make_number (endval));
}

/* Use this for recursive reads, in contexts where internal tokens
   are not allowed. */

	int nchars;

	while ((c = READCHAR) >= 0
	       && c != '\"')
	  {
	    if (p == end)
	      {
		char *new = (char *) xrealloc (read_buffer, read_buffer_size *= 2);
		p += new - read_buffer;
		read_buffer += new - read_buffer;
		end = read_buffer + read_buffer_size;
	      }
	    if (c == '\\')
	      {
		c = read_escape (readcharfun, 1);
		if (! SINGLE_BYTE_CHAR_P ((c & ~CHAR_META)))
		  {
		    unsigned char workbuf[4];
		    unsigned char *str = workbuf;
		    int length;

		    length = non_ascii_char_to_string (c, workbuf, &str);
		    if (length > 1)
		      force_multibyte = 1;

		    if (p + length > end)
		      {
			char *new = (char *) xrealloc (read_buffer, read_buffer_size *= 2);
			p += new - read_buffer;
			read_buffer += new - read_buffer;
			end = read_buffer + read_buffer_size;
		      }
 
		    bcopy (str, p, length);
		    p += length;
		    continue;
		  }
		/* If an escape specifies a non-ASCII single-byte character,
		   this must be a unibyte string.  */
		else if (! ASCII_BYTE_P (c))
		  force_singlebyte = 1;
	      }

	    /* c is -1 if \ newline has just been seen */
	    if (c == -1)
	      {
		if (p == read_buffer)
		  cancel = 1;
	      }
	    else
	      {
		/* Allow `\C- ' and `\C-?'.  */
		if (c == (CHAR_CTL | ' '))

	   that we are really going to find in etc/DOC.nn.nn  */
	if (!NILP (Vpurify_flag) && NILP (Vdoc_file_name) && cancel)
	  return make_number (0);

	if (force_singlebyte && force_multibyte)
	  error ("Multibyte and single-byte escapes in one string constant");

	if (force_singlebyte)
	  nchars = p - read_buffer;
	else if (force_multibyte)
	  nchars = multibyte_chars_in_text (read_buffer, p - read_buffer);

		string = make_multibyte_string (read_buffer, nchars,
						p - read_buffer);
		return Fstring_make_unibyte (string);
	      }
	  }
	else
	  nchars = p - read_buffer;

	if (read_pure)
	  return make_pure_string (read_buffer, nchars, p - read_buffer,
				   (force_multibyte

		      || c =='.'
#endif /* not LISP_FLOAT_TYPE */
		      || c == '[' || c == ']' || c == '#'
		      ))
	    {
	      if (p == end)
		{
		  register char *new = (char *) xrealloc (read_buffer, read_buffer_size *= 2);
		  p += new - read_buffer;
		  read_buffer += new - read_buffer;
		  end = read_buffer + read_buffer_size;

		{
		  c = READCHAR;
		  quoted = 1;
		}

	      *p++ = c;

	      c = READCHAR;
	    }

	  if (p == end)

  Vpurify_flag = Qt;

  Qvariable_documentation = intern ("variable-documentation");
  staticpro (&Qvariable_documentation);

  read_buffer_size = 100;
  read_buffer = (char *) malloc (read_buffer_size);
}

void
defsubr (sname)

21724:12a826a37249

/* When nonzero, read conses in pure space */
static int read_pure;

/* For use within read-from-string (this reader is non-reentrant!!)  */
static int read_from_string_index;
static int read_from_string_index_byte;
static int read_from_string_limit;

/* Number of bytes left to read in the buffer character
   that `readchar' has already advanced over.  */
static int readchar_backlog;

static int
readchar (readcharfun)
     Lisp_Object readcharfun;
{
  Lisp_Object tem;
  register int c, mpos;

  if (BUFFERP (readcharfun))
    {
      register struct buffer *inbuffer = XBUFFER (readcharfun);

      int pt_byte = BUF_PT_BYTE (inbuffer);
      int orig_pt_byte = pt_byte;

      if (pt_byte >= BUF_ZV_BYTE (inbuffer))
	return -1;

      if (! NILP (inbuffer->enable_multibyte_characters))
	{
	  unsigned char *p = BUF_BYTE_ADDRESS (inbuffer, pt_byte);
	  BUF_INC_POS (inbuffer, pt_byte);
	  c = STRING_CHAR (p, pt_byte - orig_pt_byte);
	}
      else
	{
	  c = BUF_FETCH_BYTE (inbuffer, pt_byte);
	  pt_byte++;
	}
      SET_BUF_PT_BOTH (inbuffer, BUF_PT (inbuffer) + 1, pt_byte);

      return c;
    }
  if (MARKERP (readcharfun))
    {
      register struct buffer *inbuffer = XMARKER (readcharfun)->buffer;

      int bytepos = marker_byte_position (readcharfun);
      int orig_bytepos = bytepos;

      if (bytepos >= BUF_ZV_BYTE (inbuffer))
	return -1;

      if (! NILP (inbuffer->enable_multibyte_characters))
	{
	  unsigned char *p = BUF_BYTE_ADDRESS (inbuffer, bytepos);
	  BUF_INC_POS (inbuffer, bytepos);
	  c = STRING_CHAR (p, bytepos - orig_bytepos);
	}
      else
	{
	  c = BUF_FETCH_BYTE (inbuffer, bytepos);
	  bytepos++;
	}

      XMARKER (readcharfun)->bytepos = bytepos;
      XMARKER (readcharfun)->charpos++;

      return c;
    }
  if (EQ (readcharfun, Qget_file_char))
    {
      c = getc (instream);
#ifdef EINTR

      return c;
    }

  if (STRINGP (readcharfun))
    {
      if (read_from_string_index >= read_from_string_limit)
	c = -1;
      else if (STRING_MULTIBYTE (readcharfun))
	FETCH_STRING_CHAR_ADVANCE (c, readcharfun,
				   read_from_string_index,
				   read_from_string_index_byte);
      else
	c = XSTRING (readcharfun)->data[read_from_string_index++];

      return c;
    }

  tem = call0 (readcharfun);

    /* Don't back up the pointer if we're unreading the end-of-input mark,
       since readchar didn't advance it when we read it.  */
    ;
  else if (BUFFERP (readcharfun))
    {
      struct buffer *b = XBUFFER (readcharfun);
      int bytepos = BUF_PT_BYTE (b);

      BUF_PT (b)--;
      if (! NILP (b->enable_multibyte_characters))
	BUF_DEC_POS (b, bytepos);
      else
	bytepos--;

      BUF_PT_BYTE (b) = bytepos;
    }
  else if (MARKERP (readcharfun))
    {
      struct buffer *b = XMARKER (readcharfun)->buffer;
      int bytepos = XMARKER (readcharfun)->bytepos;

      XMARKER (readcharfun)->charpos--;
      if (! NILP (b->enable_multibyte_characters))
	BUF_DEC_POS (b, bytepos);
      else
	bytepos--;

      XMARKER (readcharfun)->bytepos = bytepos;
    }
  else if (STRINGP (readcharfun))
    {
      read_from_string_index--;
      read_from_string_index_byte
	= string_char_to_byte (readcharfun, read_from_string_index);
    }
  else if (EQ (readcharfun, Qget_file_char))
    ungetc (c, instream);
  else
    call1 (readcharfun, make_number (c));
}

static Lisp_Object read0 (), read1 (), read_list (), read_vector ();
static int read_multibyte ();

/* Get a character from the tty.  */

extern Lisp_Object read_char ();

/* Read input events until we get one that's acceptable for our purposes.

  Lisp_Object tem;

  CHECK_STRING (string,0);

  if (NILP (end))
    endval = XSTRING (string)->size;
  else
    {
      CHECK_NUMBER (end, 2);
      if (endval < 0 || endval > XSTRING (string)->size)
	args_out_of_range (string, end);
    }

  if (NILP (start))
    startval = 0;
  else
    {
      CHECK_NUMBER (start, 1);
      if (startval < 0 || startval > endval)
	args_out_of_range (string, start);
    }

  read_from_string_index = startval;
  read_from_string_index_byte = string_char_to_byte (string, startval);
  read_from_string_limit = endval;

  new_backquote_flag = 0;
  read_objects = Qnil;

  tem = read0 (string);
  return Fcons (tem, make_number (read_from_string_index));
}

/* Use this for recursive reads, in contexts where internal tokens
   are not allowed. */

	int nchars;

	while ((c = READCHAR) >= 0
	       && c != '\"')
	  {
	    if (end - p < MAX_LENGTH_OF_MULTI_BYTE_FORM)
	      {
		char *new = (char *) xrealloc (read_buffer, read_buffer_size *= 2);
		p += new - read_buffer;
		read_buffer += new - read_buffer;
		end = read_buffer + read_buffer_size;
	      }

	    if (c == '\\')
	      {
		c = read_escape (readcharfun, 1);

		/* C is -1 if \ newline has just been seen */
		if (c == -1)
		  {
		    if (p == read_buffer)
		      cancel = 1;
		    continue;
		  }

		/* If an escape specifies a non-ASCII single-byte character,
		   this must be a unibyte string.  */
		if (SINGLE_BYTE_CHAR_P ((c & ~CHAR_META))
		    && ! ASCII_BYTE_P (c))
		  force_singlebyte = 1;
	      }

	    if (! SINGLE_BYTE_CHAR_P ((c & ~CHAR_META)))
	      {
		unsigned char workbuf[4];
		unsigned char *str = workbuf;
		int length;

		length = non_ascii_char_to_string (c, workbuf, &str);
		if (length > 1)
		  force_multibyte = 1;

		bcopy (str, p, length);
		p += length;
	      }
	    else
	      {
		/* Allow `\C- ' and `\C-?'.  */
		if (c == (CHAR_CTL | ' '))

	   that we are really going to find in etc/DOC.nn.nn  */
	if (!NILP (Vpurify_flag) && NILP (Vdoc_file_name) && cancel)
	  return make_number (0);

	if (force_singlebyte && force_multibyte)
	  error ("Multibyte and unibyte characters in one string constant");

	if (force_singlebyte)
	  nchars = p - read_buffer;
	else if (force_multibyte)
	  nchars = multibyte_chars_in_text (read_buffer, p - read_buffer);

		string = make_multibyte_string (read_buffer, nchars,
						p - read_buffer);
		return Fstring_make_unibyte (string);
	      }
	  }
	else if (EQ (readcharfun, Qget_file_char))
	  /* Nowadays, reading directly from a file
	     is used only for compiled Emacs Lisp files,
	     and those always use the Emacs internal encoding.  */
	  nchars = multibyte_chars_in_text (read_buffer, p - read_buffer);
	else
	  /* In all other cases, if we read these bytes as
	     separate characters, treat them as separate characters now.  */
	  nchars = p - read_buffer;

	if (read_pure)
	  return make_pure_string (read_buffer, nchars, p - read_buffer,
				   (force_multibyte

		      || c =='.'
#endif /* not LISP_FLOAT_TYPE */
		      || c == '[' || c == ']' || c == '#'
		      ))
	    {
	      if (end - p < MAX_LENGTH_OF_MULTI_BYTE_FORM)
		{
		  register char *new = (char *) xrealloc (read_buffer, read_buffer_size *= 2);
		  p += new - read_buffer;
		  read_buffer += new - read_buffer;
		  end = read_buffer + read_buffer_size;

		{
		  c = READCHAR;
		  quoted = 1;
		}

	      if (! SINGLE_BYTE_CHAR_P (c))
		{
		  unsigned char workbuf[4];
		  unsigned char *str = workbuf;
		  int length;

		  length = non_ascii_char_to_string (c, workbuf, &str);

		  bcopy (str, p, length);
		  p += length;
		}
	      else
		*p++ = c;

	      c = READCHAR;
	    }

	  if (p == end)

  Vpurify_flag = Qt;

  Qvariable_documentation = intern ("variable-documentation");
  staticpro (&Qvariable_documentation);

  read_buffer_size = 100 + MAX_LENGTH_OF_MULTI_BYTE_FORM;
  read_buffer = (char *) malloc (read_buffer_size);
}

void
defsubr (sname)