comparison src/lread.c @ 20609:4bf29951648f

(read_escape): `\ ' stands for nothing at all. (oblookup): Take args SIZE and SIZE_BYTE. Callers changed. (init_obarray, read1, make_symbol): Pass new arg to make_pure_string. (Fintern, oblookup, Fintern_soft, intern): Handle size_byte. (dir_warning): Pass new arg to message_dolog. (read1): PCH is now int *. Declare ch as int. (read0): Declare c as int. (read_list): Declare ch as int. (read0): Use Fmake_string not make_string. (read1): When reading a string, maybe use make_unibyte_string. (Fread_from_string): Convert string indices to/from bytes.

20608:a6cca06d5aaf

	  /* Make the progress messages mention that source is newer.  */
	  newer = 1;

	  /* If we won't print another message, mention this anyway.  */
	  if (! NILP (nomessage))
	    message ("Source file `%s' newer than byte-compiled file",
		     XSTRING (found)->data);
	}
      XSTRING (found)->data[XSTRING (found)->size - 1] = 'c';
    }
  else
    {

    Vpreloaded_file_list = Fcons (file, Vpreloaded_file_list);

  if (NILP (nomessage))
    {
      if (!compiled)
	message ("Loading %s (source)...", XSTRING (file)->data);
      else if (newer)
	message ("Loading %s (compiled; note, source file is newer)...",
		 XSTRING (file)->data);
      else /* The typical case; compiled file newer than source file.  */
	message ("Loading %s...", XSTRING (file)->data);
    }

  GCPRO1 (file);
  lispstream = Fcons (Qnil, Qnil);
  XSETFASTINT (XCONS (lispstream)->car, (EMACS_UINT)stream >> 16);

  saved_doc_string_size = 0;

  if (!noninteractive && NILP (nomessage))
    {
      if (!compiled)
	message ("Loading %s (source)...done", XSTRING (file)->data);
      else if (newer)
	message ("Loading %s (compiled; note, source file is newer)...done",
		 XSTRING (file)->data);
      else /* The typical case; compiled file newer than source file.  */
	message ("Loading %s...done", XSTRING (file)->data);
    }
  return Qt;
}

static Lisp_Object

  Lisp_Object tem;

  CHECK_STRING (string,0);

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

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

  read_from_string_index = startval;

  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. */
static Lisp_Object
read0 (readcharfun)
     Lisp_Object readcharfun;
{
  register Lisp_Object val;
  char c;

  val = read1 (readcharfun, &c, 0);
  if (c)
    Fsignal (Qinvalid_read_syntax, Fcons (make_string (&c, 1), Qnil));

  return val;
}

static int read_buffer_size;

    case 't':
      return '\t';
    case 'v':
      return '\v';
    case '\n':
      return -1;

    case 'M':
      c = READCHAR;
      if (c != '-')

   FIRST_IN_LIST is nonzero if this is the first element of a list.  */

static Lisp_Object
read1 (readcharfun, pch, first_in_list)
     register Lisp_Object readcharfun;
     char *pch;
     int first_in_list;
{
  register int c;
  int uninterned_symbol = 0;

#ifdef USE_TEXT_PROPERTIES
      if (c == '(')
	{
	  Lisp_Object tmp;
	  struct gcpro gcpro1;
	  char ch;

	  /* Read the string itself.  */
	  tmp = read1 (readcharfun, &ch, 0);
	  if (ch != 0 || !STRINGP (tmp))
	    Fsignal (Qinvalid_read_syntax, Fcons (make_string ("#", 1), Qnil));

	   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 (read_pure)
	  return make_pure_string (read_buffer, p - read_buffer);
	else
	  return make_string (read_buffer, p - read_buffer);
      }

    case '.':
      {
#ifdef LISP_FLOAT_TYPE

  val = Qnil;
  tail = Qnil;

  while (1)
    {
      char ch;
      GCPRO2 (val, tail);
      elt = read1 (readcharfun, &ch, first_in_list);
      UNGCPRO;

      first_in_list = 0;

  Lisp_Object obarray;

  obarray = Vobarray;
  if (!VECTORP (obarray) || XVECTOR (obarray)->size == 0)
    obarray = check_obarray (obarray);
  tem = oblookup (obarray, str, len);
  if (SYMBOLP (tem))
    return tem;
  return Fintern (make_string (str, len), obarray);
}

     char *str;
{
  int len = strlen (str);

  return Fmake_symbol ((!NILP (Vpurify_flag)
			? make_pure_string (str, len)
			: make_string (str, len)));
}

DEFUN ("intern", Fintern, Sintern, 1, 2, 0,
  "Return the canonical symbol whose name is STRING.\n\

  if (NILP (obarray)) obarray = Vobarray;
  obarray = check_obarray (obarray);

  CHECK_STRING (string, 0);

  tem = oblookup (obarray, XSTRING (string)->data, XSTRING (string)->size);
  if (!INTEGERP (tem))
    return tem;

  if (!NILP (Vpurify_flag))
    string = Fpurecopy (string);

  if (NILP (obarray)) obarray = Vobarray;
  obarray = check_obarray (obarray);

  CHECK_STRING (string, 0);

  tem = oblookup (obarray, XSTRING (string)->data, XSTRING (string)->size);
  if (!INTEGERP (tem))
    return tem;
  return Qnil;
}


    {
      CHECK_STRING (name, 0);
      string = name;
    }

  tem = oblookup (obarray, XSTRING (string)->data, XSTRING (string)->size);
  if (INTEGERP (tem))
    return Qnil;
  /* If arg was a symbol, don't delete anything but that symbol itself.  */
  if (SYMBOLP (name) && !EQ (name, tem))
    return Qnil;

  return Qt;
}

/* Return the symbol in OBARRAY whose names matches the string
   of SIZE characters at PTR.  If there is no such symbol in OBARRAY,
   return nil.

   Also store the bucket number in oblookup_last_bucket_number.  */

Lisp_Object
oblookup (obarray, ptr, size)
     Lisp_Object obarray;
     register char *ptr;
     register int size;
{
  int hash;
  int obsize;
  register Lisp_Object tail;
  Lisp_Object bucket, tem;

      obsize = XVECTOR (obarray)->size;
    }
  /* This is sometimes needed in the middle of GC.  */
  obsize &= ~ARRAY_MARK_FLAG;
  /* Combining next two lines breaks VMS C 2.3.  */
  hash = hash_string (ptr, size);
  hash %= obsize;
  bucket = XVECTOR (obarray)->contents[hash];
  oblookup_last_bucket_number = hash;
  if (XFASTINT (bucket) == 0)
    ;
  else if (!SYMBOLP (bucket))
    error ("Bad data in guts of obarray"); /* Like CADR error message */
  else
    for (tail = bucket; ; XSETSYMBOL (tail, XSYMBOL (tail)->next))
      {
	if (XSYMBOL (tail)->name->size == size
	    && !bcmp (XSYMBOL (tail)->name->data, ptr, size))
	  return tail;
	else if (XSYMBOL (tail)->next == 0)
	  break;
      }
  XSETINT (tem, hash);

  int hash;
  Lisp_Object *tem;

  XSETFASTINT (oblength, OBARRAY_SIZE);

  Qnil = Fmake_symbol (make_pure_string ("nil", 3));
  Vobarray = Fmake_vector (oblength, make_number (0));
  initial_obarray = Vobarray;
  staticpro (&initial_obarray);
  /* Intern nil in the obarray */
  XSYMBOL (Qnil)->obarray = Vobarray;

  /* Separate statement here to avoid VAXC bug. */
  hash %= OBARRAY_SIZE;
  tem = &XVECTOR (Vobarray)->contents[hash];
  *tem = Qnil;

  Qunbound = Fmake_symbol (make_pure_string ("unbound", 7));
  XSYMBOL (Qnil)->function = Qunbound;
  XSYMBOL (Qunbound)->value = Qunbound;
  XSYMBOL (Qunbound)->function = Qunbound;

  Qt = intern ("t");

  char *buffer
    = (char *) alloca (XSTRING (dirname)->size + strlen (format) + 5);

  fprintf (stderr, format, XSTRING (dirname)->data);
  sprintf (buffer, format, XSTRING (dirname)->data);
  message_dolog (buffer, strlen (buffer), 0);
}

void
syms_of_lread ()
{

20609:4bf29951648f

	  /* Make the progress messages mention that source is newer.  */
	  newer = 1;

	  /* If we won't print another message, mention this anyway.  */
	  if (! NILP (nomessage))
	    message_with_string ("Source file `%s' newer than byte-compiled file",
				 found, 1);
	}
      XSTRING (found)->data[XSTRING (found)->size - 1] = 'c';
    }
  else
    {

    Vpreloaded_file_list = Fcons (file, Vpreloaded_file_list);

  if (NILP (nomessage))
    {
      if (!compiled)
	message_with_string ("Loading %s (source)...", file, 1);
      else if (newer)
	message_with_string ("Loading %s (compiled; note, source file is newer)...",
		 file, 1);
      else /* The typical case; compiled file newer than source file.  */
	message_with_string ("Loading %s...", file, 1);
    }

  GCPRO1 (file);
  lispstream = Fcons (Qnil, Qnil);
  XSETFASTINT (XCONS (lispstream)->car, (EMACS_UINT)stream >> 16);

  saved_doc_string_size = 0;

  if (!noninteractive && NILP (nomessage))
    {
      if (!compiled)
	message_with_string ("Loading %s (source)...done", file, 1);
      else if (newer)
	message_with_string ("Loading %s (compiled; note, source file is newer)...done",
		 file, 1);
      else /* The typical case; compiled file newer than source file.  */
	message_with_string ("Loading %s...done", file, 1);
    }
  return Qt;
}

static Lisp_Object

  Lisp_Object tem;

  CHECK_STRING (string,0);

  if (NILP (end))
    endval = XSTRING (string)->size_byte;
  else
    {
      CHECK_NUMBER (end, 2);
      endval = string_char_to_byte (string, XINT (end));
      if (endval < 0 || endval > XSTRING (string)->size_byte)
	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;

  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. */

static Lisp_Object
read0 (readcharfun)
     Lisp_Object readcharfun;
{
  register Lisp_Object val;
  int c;

  val = read1 (readcharfun, &c, 0);
  if (c)
    Fsignal (Qinvalid_read_syntax, Fcons (Fmake_string (make_number (c),
							make_number (1)),
					  Qnil));

  return val;
}

static int read_buffer_size;

    case 't':
      return '\t';
    case 'v':
      return '\v';
    case '\n':
      return -1;
    case ' ':
      return -1;

    case 'M':
      c = READCHAR;
      if (c != '-')

   FIRST_IN_LIST is nonzero if this is the first element of a list.  */

static Lisp_Object
read1 (readcharfun, pch, first_in_list)
     register Lisp_Object readcharfun;
     int *pch;
     int first_in_list;
{
  register int c;
  int uninterned_symbol = 0;

#ifdef USE_TEXT_PROPERTIES
      if (c == '(')
	{
	  Lisp_Object tmp;
	  struct gcpro gcpro1;
	  int ch;

	  /* Read the string itself.  */
	  tmp = read1 (readcharfun, &ch, 0);
	  if (ch != 0 || !STRINGP (tmp))
	    Fsignal (Qinvalid_read_syntax, Fcons (make_string ("#", 1), Qnil));

	   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 (read_pure)
	  return make_pure_string (read_buffer, p - read_buffer,
				   p - read_buffer);
	else if (! NILP (current_buffer->enable_multibyte_characters))
	  return make_string (read_buffer, p - read_buffer);
	else
	  return make_unibyte_string (read_buffer, p - read_buffer);
      }

    case '.':
      {
#ifdef LISP_FLOAT_TYPE

  val = Qnil;
  tail = Qnil;

  while (1)
    {
      int ch;
      GCPRO2 (val, tail);
      elt = read1 (readcharfun, &ch, first_in_list);
      UNGCPRO;

      first_in_list = 0;

  Lisp_Object obarray;

  obarray = Vobarray;
  if (!VECTORP (obarray) || XVECTOR (obarray)->size == 0)
    obarray = check_obarray (obarray);
  tem = oblookup (obarray, str, len, len);
  if (SYMBOLP (tem))
    return tem;
  return Fintern (make_string (str, len), obarray);
}

     char *str;
{
  int len = strlen (str);

  return Fmake_symbol ((!NILP (Vpurify_flag)
			? make_pure_string (str, len, len)
			: make_string (str, len)));
}

DEFUN ("intern", Fintern, Sintern, 1, 2, 0,
  "Return the canonical symbol whose name is STRING.\n\

  if (NILP (obarray)) obarray = Vobarray;
  obarray = check_obarray (obarray);

  CHECK_STRING (string, 0);

  tem = oblookup (obarray, XSTRING (string)->data,
		  XSTRING (string)->size,
		  XSTRING (string)->size_byte);
  if (!INTEGERP (tem))
    return tem;

  if (!NILP (Vpurify_flag))
    string = Fpurecopy (string);

  if (NILP (obarray)) obarray = Vobarray;
  obarray = check_obarray (obarray);

  CHECK_STRING (string, 0);

  tem = oblookup (obarray, XSTRING (string)->data,
		  XSTRING (string)->size,
		  XSTRING (string)->size_byte);
  if (!INTEGERP (tem))
    return tem;
  return Qnil;
}


    {
      CHECK_STRING (name, 0);
      string = name;
    }

  tem = oblookup (obarray, XSTRING (string)->data,
		  XSTRING (string)->size,
		  XSTRING (string)->size_byte);
  if (INTEGERP (tem))
    return Qnil;
  /* If arg was a symbol, don't delete anything but that symbol itself.  */
  if (SYMBOLP (name) && !EQ (name, tem))
    return Qnil;

  return Qt;
}

/* Return the symbol in OBARRAY whose names matches the string
   of SIZE characters (SIZE_BYTE bytes) at PTR.
   If there is no such symbol in OBARRAY, return nil.

   Also store the bucket number in oblookup_last_bucket_number.  */

Lisp_Object
oblookup (obarray, ptr, size, size_byte)
     Lisp_Object obarray;
     register char *ptr;
     int size, size_byte;
{
  int hash;
  int obsize;
  register Lisp_Object tail;
  Lisp_Object bucket, tem;

      obsize = XVECTOR (obarray)->size;
    }
  /* This is sometimes needed in the middle of GC.  */
  obsize &= ~ARRAY_MARK_FLAG;
  /* Combining next two lines breaks VMS C 2.3.  */
  hash = hash_string (ptr, size_byte);
  hash %= obsize;
  bucket = XVECTOR (obarray)->contents[hash];
  oblookup_last_bucket_number = hash;
  if (XFASTINT (bucket) == 0)
    ;
  else if (!SYMBOLP (bucket))
    error ("Bad data in guts of obarray"); /* Like CADR error message */
  else
    for (tail = bucket; ; XSETSYMBOL (tail, XSYMBOL (tail)->next))
      {
	if (XSYMBOL (tail)->name->size_byte == size_byte
	    && XSYMBOL (tail)->name->size == size
	    && !bcmp (XSYMBOL (tail)->name->data, ptr, size_byte))
	  return tail;
	else if (XSYMBOL (tail)->next == 0)
	  break;
      }
  XSETINT (tem, hash);

  int hash;
  Lisp_Object *tem;

  XSETFASTINT (oblength, OBARRAY_SIZE);

  Qnil = Fmake_symbol (make_pure_string ("nil", 3, 3));
  Vobarray = Fmake_vector (oblength, make_number (0));
  initial_obarray = Vobarray;
  staticpro (&initial_obarray);
  /* Intern nil in the obarray */
  XSYMBOL (Qnil)->obarray = Vobarray;

  /* Separate statement here to avoid VAXC bug. */
  hash %= OBARRAY_SIZE;
  tem = &XVECTOR (Vobarray)->contents[hash];
  *tem = Qnil;

  Qunbound = Fmake_symbol (make_pure_string ("unbound", 7, 7));
  XSYMBOL (Qnil)->function = Qunbound;
  XSYMBOL (Qunbound)->value = Qunbound;
  XSYMBOL (Qunbound)->function = Qunbound;

  Qt = intern ("t");

  char *buffer
    = (char *) alloca (XSTRING (dirname)->size + strlen (format) + 5);

  fprintf (stderr, format, XSTRING (dirname)->data);
  sprintf (buffer, format, XSTRING (dirname)->data);
  message_dolog (buffer, strlen (buffer), 0, STRING_MULTIBYTE (dirname));
}

void
syms_of_lread ()
{