comparison src/data.c @ 90533:8a8e69664178

Merge from emacs--devo--0 Patches applied: * emacs--devo--0 (patch 343-356) - Update from CVS - Update for ERC 5.1.3. - Merge from gnus--rel--5.10 * gnus--rel--5.10 (patch 113-115) - Merge from emacs--devo--0 - Update from CVS Revision: [e-mail]/emacs--unicode--0--patch-90

90532:e22cf6d2400c

void
circular_list_error (list)
     Lisp_Object list;
{
  Fsignal (Qcircular_list, list);
}


Lisp_Object
wrong_type_argument (predicate, value)
     register Lisp_Object predicate, value;
{
  register Lisp_Object tem;
  do
    {
      /* If VALUE is not even a valid Lisp object, abort here
	 where we can get a backtrace showing where it came from.  */
      if ((unsigned int) XGCTYPE (value) >= Lisp_Type_Limit)
	abort ();

      value = Fsignal (Qwrong_type_argument, Fcons (predicate, Fcons (value, Qnil)));
      tem = call1 (predicate, value);
    }
  while (NILP (tem));
  /* This function is marked as NO_RETURN, gcc would warn if it has a
     return statement or if falls off the function.  Other compilers
     warn if no return statement is present.  */
#ifndef __GNUC__
  return value;
#else
  abort ();
#endif
}

void
pure_write_error ()
{

void
args_out_of_range (a1, a2)
     Lisp_Object a1, a2;
{
  while (1)
    Fsignal (Qargs_out_of_range, Fcons (a1, Fcons (a2, Qnil)));
}

void
args_out_of_range_3 (a1, a2, a3)
     Lisp_Object a1, a2, a3;
{
  while (1)
    Fsignal (Qargs_out_of_range, Fcons (a1, Fcons (a2, Fcons (a3, Qnil))));
}

/* On some machines, XINT needs a temporary location.
   Here it is, in case it is needed.  */

DEFUN ("arrayp", Farrayp, Sarrayp, 1, 1, 0,
       doc: /* Return t if OBJECT is an array (string or vector).  */)
     (object)
     Lisp_Object object;
{
  if (VECTORP (object) || STRINGP (object)
      || CHAR_TABLE_P (object) || BOOL_VECTOR_P (object))
    return Qt;
  return Qnil;
}

DEFUN ("sequencep", Fsequencep, Ssequencep, 1, 1, 0,
       doc: /* Return t if OBJECT is a sequence (list or array).  */)
     (object)
     register Lisp_Object object;
{
  if (CONSP (object) || NILP (object) || VECTORP (object) || STRINGP (object)
      || CHAR_TABLE_P (object) || BOOL_VECTOR_P (object))
    return Qt;
  return Qnil;
}

DEFUN ("bufferp", Fbufferp, Sbufferp, 1, 1, 0,

See Info node `(elisp)Cons Cells' for a discussion of related basic
Lisp concepts such as car, cdr, cons cell and list.  */)
     (list)
     register Lisp_Object list;
{
  while (1)
    {
      if (CONSP (list))
	return XCAR (list);
      else if (EQ (list, Qnil))
	return Qnil;
      else
	list = wrong_type_argument (Qlistp, list);
    }
}

DEFUN ("car-safe", Fcar_safe, Scar_safe, 1, 1, 0,
       doc: /* Return the car of OBJECT if it is a cons cell, or else nil.  */)
     (object)
     Lisp_Object object;
{
  if (CONSP (object))
    return XCAR (object);
  else
    return Qnil;
}

DEFUN ("cdr", Fcdr, Scdr, 1, 1, 0,
       doc: /* Return the cdr of LIST.  If arg is nil, return nil.
Error if arg is not nil and not a cons cell.  See also `cdr-safe'.

See Info node `(elisp)Cons Cells' for a discussion of related basic
Lisp concepts such as cdr, car, cons cell and list.  */)
     (list)
     register Lisp_Object list;
{
  while (1)
    {
      if (CONSP (list))
	return XCDR (list);
      else if (EQ (list, Qnil))
	return Qnil;
      else
	list = wrong_type_argument (Qlistp, list);
    }
}

DEFUN ("cdr-safe", Fcdr_safe, Scdr_safe, 1, 1, 0,
       doc: /* Return the cdr of OBJECT if it is a cons cell, or else nil.  */)
     (object)
     Lisp_Object object;
{
  if (CONSP (object))
    return XCDR (object);
  else
    return Qnil;
}

DEFUN ("setcar", Fsetcar, Ssetcar, 2, 2, 0,
       doc: /* Set the car of CELL to be NEWCAR.  Returns NEWCAR.  */)
     (cell, newcar)
     register Lisp_Object cell, newcar;
{
  if (!CONSP (cell))
    cell = wrong_type_argument (Qconsp, cell);

  CHECK_IMPURE (cell);
  XSETCAR (cell, newcar);
  return newcar;
}

DEFUN ("setcdr", Fsetcdr, Ssetcdr, 2, 2, 0,
       doc: /* Set the cdr of CELL to be NEWCDR.  Returns NEWCDR.  */)
     (cell, newcdr)
     register Lisp_Object cell, newcdr;
{
  if (!CONSP (cell))
    cell = wrong_type_argument (Qconsp, cell);

  CHECK_IMPURE (cell);
  XSETCDR (cell, newcdr);
  return newcdr;
}


     (symbol)
     register Lisp_Object symbol;
{
  CHECK_SYMBOL (symbol);
  if (XSYMBOL (symbol)->constant)
    return Fsignal (Qsetting_constant, Fcons (symbol, Qnil));
  Fset (symbol, Qunbound);
  return symbol;
}

DEFUN ("fmakunbound", Ffmakunbound, Sfmakunbound, 1, 1, 0,

     (symbol)
     register Lisp_Object symbol;
{
  CHECK_SYMBOL (symbol);
  if (NILP (symbol) || EQ (symbol, Qt))
    return Fsignal (Qsetting_constant, Fcons (symbol, Qnil));
  XSYMBOL (symbol)->function = Qunbound;
  return symbol;
}

DEFUN ("symbol-function", Fsymbol_function, Ssymbol_function, 1, 1, 0,
       doc: /* Return SYMBOL's function definition.  Error if that is void.  */)
     (symbol)
     register Lisp_Object symbol;
{
  CHECK_SYMBOL (symbol);
  if (EQ (XSYMBOL (symbol)->function, Qunbound))
    return Fsignal (Qvoid_function, Fcons (symbol, Qnil));
  return XSYMBOL (symbol)->function;
}

DEFUN ("symbol-plist", Fsymbol_plist, Ssymbol_plist, 1, 1, 0,
       doc: /* Return SYMBOL's property list.  */)
     (symbol)

     (symbol, definition)
     register Lisp_Object symbol, definition;
{
  CHECK_SYMBOL (symbol);
  if (NILP (symbol) || EQ (symbol, Qt))
    return Fsignal (Qsetting_constant, Fcons (symbol, Qnil));
  if (!NILP (Vautoload_queue) && !EQ (XSYMBOL (symbol)->function, Qunbound))
    Vautoload_queue = Fcons (Fcons (symbol, XSYMBOL (symbol)->function),
			     Vautoload_queue);
  XSYMBOL (symbol)->function = definition;
  /* Handle automatic advice activation */

function with `&rest' args, or `unevalled' for a special form.  */)
     (subr)
     Lisp_Object subr;
{
  short minargs, maxargs;
  if (!SUBRP (subr))
    wrong_type_argument (Qsubrp, subr);
  minargs = XSUBR (subr)->min_args;
  maxargs = XSUBR (subr)->max_args;
  if (maxargs == MANY)
    return Fcons (make_number (minargs), Qmany);
  else if (maxargs == UNEVALLED)

SUBR must be a built-in function.  */)
     (subr)
     Lisp_Object subr;
{
  const char *name;
  if (!SUBRP (subr))
    wrong_type_argument (Qsubrp, subr);
  name = XSUBR (subr)->symbol_name;
  return make_string (name, strlen (name));
}

DEFUN ("interactive-form", Finteractive_form, Sinteractive_form, 1, 1, 0,

      hare = XSYMBOL (hare)->value;
      tortoise = XSYMBOL (tortoise)->value;

      if (EQ (hare, tortoise))
	Fsignal (Qcyclic_variable_indirection, Fcons (symbol, Qnil));
    }

  return hare;
}

     Lisp_Object symbol;
{
  Lisp_Object val;

  val = find_symbol_value (symbol);
  if (EQ (val, Qunbound))
    return Fsignal (Qvoid_variable, Fcons (symbol, Qnil));
  else
    return val;
}

DEFUN ("set", Fset, Sset, 2, 2, 0,
       doc: /* Set SYMBOL's value to NEWVAL, and return NEWVAL.  */)
     (symbol, newval)

  CHECK_SYMBOL (symbol);
  if (SYMBOL_CONSTANT_P (symbol)
      && (NILP (Fkeywordp (symbol))
	  || !EQ (newval, SYMBOL_VALUE (symbol))))
    return Fsignal (Qsetting_constant, Fcons (symbol, Qnil));

  innercontents = valcontents = SYMBOL_VALUE (symbol);

  if (BUFFER_OBJFWDP (valcontents))
    {

     Lisp_Object symbol;
{
  register Lisp_Object value;

  value = default_value (symbol);
  if (EQ (value, Qunbound))
    return Fsignal (Qvoid_variable, Fcons (symbol, Qnil));
  return value;
}

DEFUN ("set-default", Fset_default, Sset_default, 2, 2, 0,
       doc: /* Set SYMBOL's default value to VALUE.  SYMBOL and VALUE are evaluated.
The default value is seen in buffers that do not have their own values

      hare = XSYMBOL (hare)->function;

      tortoise = XSYMBOL (tortoise)->function;

      if (EQ (hare, tortoise))
	Fsignal (Qcyclic_function_indirection, Fcons (object, Qnil));
    }

  return hare;
}

     register Lisp_Object object;
     Lisp_Object noerror;
{
  Lisp_Object result;

  result = indirect_function (object);

  if (EQ (result, Qunbound))
    return (NILP (noerror)
	    ? Fsignal (Qvoid_function, Fcons (object, Qnil))
	    : Qnil);
  return result;
}

/* Extract and set vector and string elements */

DEFUN ("aref", Faref, Saref, 2, 2, 0,

{
  register int idxval;

  CHECK_NUMBER (idx);
  idxval = XINT (idx);
  if (!VECTORP (array) && !STRINGP (array) && !BOOL_VECTOR_P (array)
      && ! CHAR_TABLE_P (array))
    array = wrong_type_argument (Qarrayp, array);
  CHECK_IMPURE (array);

  if (VECTORP (array))
    {
      if (idxval < 0 || idxval >= XVECTOR (array)->size)

  else
    {
      CHECK_NUMBER (base);
      b = XINT (base);
      if (b < 2 || b > 16)
	Fsignal (Qargs_out_of_range, Fcons (base, Qnil));
    }

  /* Skip any whitespace at the front of the number.  Some versions of
     atoi do this anyway, so we might as well make Emacs lisp consistent.  */
  p = SDATA (string);

	  if (!argnum)
	    accum = next;
	  else
	    {
	      if (next == 0)
		Fsignal (Qarith_error, Qnil);
	      accum /= next;
	    }
	  break;
	case Alogand:
	  accum &= next;

	  if (!argnum)
	    accum = next;
	  else
	    {
	      if (! IEEE_FLOATING_POINT && next == 0)
		Fsignal (Qarith_error, Qnil);
	      accum /= next;
	    }
	  break;
	case Alogand:
	case Alogior:

  CHECK_NUMBER_COERCE_MARKER (x);
  CHECK_NUMBER_COERCE_MARKER (y);

  if (XFASTINT (y) == 0)
    Fsignal (Qarith_error, Qnil);

  XSETINT (val, XINT (x) % XINT (y));
  return val;
}

  i1 = XINT (x);
  i2 = XINT (y);

  if (i2 == 0)
    Fsignal (Qarith_error, Qnil);

  i1 %= i2;

  /* If the "remainder" comes out with the wrong sign, fix it.  */
  if (i2 < 0 ? i1 > 0 : i1 < 0)

#else /* not BSD4_1 */
  sigsetmask (SIGEMPTYMASK);
#endif /* not BSD4_1 */

  SIGNAL_THREAD_CHECK (signo);
  Fsignal (Qarith_error, Qnil);
}

void
init_data ()
{

90533:8a8e69664178

void
circular_list_error (list)
     Lisp_Object list;
{
  xsignal (Qcircular_list, list);
}


Lisp_Object
wrong_type_argument (predicate, value)
     register Lisp_Object predicate, value;
{
  /* If VALUE is not even a valid Lisp object, abort here
     where we can get a backtrace showing where it came from.  */
  if ((unsigned int) XGCTYPE (value) >= Lisp_Type_Limit)
    abort ();

  xsignal2 (Qwrong_type_argument, predicate, value);
}

void
pure_write_error ()
{

void
args_out_of_range (a1, a2)
     Lisp_Object a1, a2;
{
  xsignal2 (Qargs_out_of_range, a1, a2);
}

void
args_out_of_range_3 (a1, a2, a3)
     Lisp_Object a1, a2, a3;
{
  xsignal3 (Qargs_out_of_range, a1, a2, a3);
}

/* On some machines, XINT needs a temporary location.
   Here it is, in case it is needed.  */

DEFUN ("arrayp", Farrayp, Sarrayp, 1, 1, 0,
       doc: /* Return t if OBJECT is an array (string or vector).  */)
     (object)
     Lisp_Object object;
{
  if (ARRAYP (object))
    return Qt;
  return Qnil;
}

DEFUN ("sequencep", Fsequencep, Ssequencep, 1, 1, 0,
       doc: /* Return t if OBJECT is a sequence (list or array).  */)
     (object)
     register Lisp_Object object;
{
  if (CONSP (object) || NILP (object) || ARRAYP (object))
    return Qt;
  return Qnil;
}

DEFUN ("bufferp", Fbufferp, Sbufferp, 1, 1, 0,

See Info node `(elisp)Cons Cells' for a discussion of related basic
Lisp concepts such as car, cdr, cons cell and list.  */)
     (list)
     register Lisp_Object list;
{
  return CAR (list);
}

DEFUN ("car-safe", Fcar_safe, Scar_safe, 1, 1, 0,
       doc: /* Return the car of OBJECT if it is a cons cell, or else nil.  */)
     (object)
     Lisp_Object object;
{
  return CAR_SAFE (object);
}

DEFUN ("cdr", Fcdr, Scdr, 1, 1, 0,
       doc: /* Return the cdr of LIST.  If arg is nil, return nil.
Error if arg is not nil and not a cons cell.  See also `cdr-safe'.

See Info node `(elisp)Cons Cells' for a discussion of related basic
Lisp concepts such as cdr, car, cons cell and list.  */)
     (list)
     register Lisp_Object list;
{
  return CDR (list);
}

DEFUN ("cdr-safe", Fcdr_safe, Scdr_safe, 1, 1, 0,
       doc: /* Return the cdr of OBJECT if it is a cons cell, or else nil.  */)
     (object)
     Lisp_Object object;
{
  return CDR_SAFE (object);
}

DEFUN ("setcar", Fsetcar, Ssetcar, 2, 2, 0,
       doc: /* Set the car of CELL to be NEWCAR.  Returns NEWCAR.  */)
     (cell, newcar)
     register Lisp_Object cell, newcar;
{
  CHECK_CONS (cell);
  CHECK_IMPURE (cell);
  XSETCAR (cell, newcar);
  return newcar;
}

DEFUN ("setcdr", Fsetcdr, Ssetcdr, 2, 2, 0,
       doc: /* Set the cdr of CELL to be NEWCDR.  Returns NEWCDR.  */)
     (cell, newcdr)
     register Lisp_Object cell, newcdr;
{
  CHECK_CONS (cell);
  CHECK_IMPURE (cell);
  XSETCDR (cell, newcdr);
  return newcdr;
}


     (symbol)
     register Lisp_Object symbol;
{
  CHECK_SYMBOL (symbol);
  if (XSYMBOL (symbol)->constant)
    xsignal1 (Qsetting_constant, symbol);
  Fset (symbol, Qunbound);
  return symbol;
}

DEFUN ("fmakunbound", Ffmakunbound, Sfmakunbound, 1, 1, 0,

     (symbol)
     register Lisp_Object symbol;
{
  CHECK_SYMBOL (symbol);
  if (NILP (symbol) || EQ (symbol, Qt))
    xsignal1 (Qsetting_constant, symbol);
  XSYMBOL (symbol)->function = Qunbound;
  return symbol;
}

DEFUN ("symbol-function", Fsymbol_function, Ssymbol_function, 1, 1, 0,
       doc: /* Return SYMBOL's function definition.  Error if that is void.  */)
     (symbol)
     register Lisp_Object symbol;
{
  CHECK_SYMBOL (symbol);
  if (!EQ (XSYMBOL (symbol)->function, Qunbound))
    return XSYMBOL (symbol)->function;
  xsignal1 (Qvoid_function, symbol);
}

DEFUN ("symbol-plist", Fsymbol_plist, Ssymbol_plist, 1, 1, 0,
       doc: /* Return SYMBOL's property list.  */)
     (symbol)

     (symbol, definition)
     register Lisp_Object symbol, definition;
{
  CHECK_SYMBOL (symbol);
  if (NILP (symbol) || EQ (symbol, Qt))
    xsignal1 (Qsetting_constant, symbol);
  if (!NILP (Vautoload_queue) && !EQ (XSYMBOL (symbol)->function, Qunbound))
    Vautoload_queue = Fcons (Fcons (symbol, XSYMBOL (symbol)->function),
			     Vautoload_queue);
  XSYMBOL (symbol)->function = definition;
  /* Handle automatic advice activation */

function with `&rest' args, or `unevalled' for a special form.  */)
     (subr)
     Lisp_Object subr;
{
  short minargs, maxargs;
  CHECK_SUBR (subr);
  minargs = XSUBR (subr)->min_args;
  maxargs = XSUBR (subr)->max_args;
  if (maxargs == MANY)
    return Fcons (make_number (minargs), Qmany);
  else if (maxargs == UNEVALLED)

SUBR must be a built-in function.  */)
     (subr)
     Lisp_Object subr;
{
  const char *name;
  CHECK_SUBR (subr);
  name = XSUBR (subr)->symbol_name;
  return make_string (name, strlen (name));
}

DEFUN ("interactive-form", Finteractive_form, Sinteractive_form, 1, 1, 0,

      hare = XSYMBOL (hare)->value;
      tortoise = XSYMBOL (tortoise)->value;

      if (EQ (hare, tortoise))
	xsignal1 (Qcyclic_variable_indirection, symbol);
    }

  return hare;
}

     Lisp_Object symbol;
{
  Lisp_Object val;

  val = find_symbol_value (symbol);
  if (!EQ (val, Qunbound))
    return val;

  xsignal1 (Qvoid_variable, symbol);
}

DEFUN ("set", Fset, Sset, 2, 2, 0,
       doc: /* Set SYMBOL's value to NEWVAL, and return NEWVAL.  */)
     (symbol, newval)

  CHECK_SYMBOL (symbol);
  if (SYMBOL_CONSTANT_P (symbol)
      && (NILP (Fkeywordp (symbol))
	  || !EQ (newval, SYMBOL_VALUE (symbol))))
    xsignal1 (Qsetting_constant, symbol);

  innercontents = valcontents = SYMBOL_VALUE (symbol);

  if (BUFFER_OBJFWDP (valcontents))
    {

     Lisp_Object symbol;
{
  register Lisp_Object value;

  value = default_value (symbol);
  if (!EQ (value, Qunbound))
    return value;

  xsignal1 (Qvoid_variable, symbol);
}

DEFUN ("set-default", Fset_default, Sset_default, 2, 2, 0,
       doc: /* Set SYMBOL's default value to VALUE.  SYMBOL and VALUE are evaluated.
The default value is seen in buffers that do not have their own values

      hare = XSYMBOL (hare)->function;

      tortoise = XSYMBOL (tortoise)->function;

      if (EQ (hare, tortoise))
	xsignal1 (Qcyclic_function_indirection, object);
    }

  return hare;
}

     register Lisp_Object object;
     Lisp_Object noerror;
{
  Lisp_Object result;

  /* Optimize for no indirection.  */
  result = object;
  if (SYMBOLP (result) && !EQ (result, Qunbound)
      && (result = XSYMBOL (result)->function, SYMBOLP (result)))
    result = indirect_function (result);
  if (!EQ (result, Qunbound))
    return result;

  if (NILP (noerror))
    xsignal1 (Qvoid_function, object);

  return Qnil;
}

/* Extract and set vector and string elements */

DEFUN ("aref", Faref, Saref, 2, 2, 0,

{
  register int idxval;

  CHECK_NUMBER (idx);
  idxval = XINT (idx);
  CHECK_ARRAY (array, Qarrayp);
  CHECK_IMPURE (array);

  if (VECTORP (array))
    {
      if (idxval < 0 || idxval >= XVECTOR (array)->size)

  else
    {
      CHECK_NUMBER (base);
      b = XINT (base);
      if (b < 2 || b > 16)
	xsignal1 (Qargs_out_of_range, base);
    }

  /* Skip any whitespace at the front of the number.  Some versions of
     atoi do this anyway, so we might as well make Emacs lisp consistent.  */
  p = SDATA (string);

	  if (!argnum)
	    accum = next;
	  else
	    {
	      if (next == 0)
		xsignal0 (Qarith_error);
	      accum /= next;
	    }
	  break;
	case Alogand:
	  accum &= next;

	  if (!argnum)
	    accum = next;
	  else
	    {
	      if (! IEEE_FLOATING_POINT && next == 0)
		xsignal0 (Qarith_error);
	      accum /= next;
	    }
	  break;
	case Alogand:
	case Alogior:

  CHECK_NUMBER_COERCE_MARKER (x);
  CHECK_NUMBER_COERCE_MARKER (y);

  if (XFASTINT (y) == 0)
    xsignal0 (Qarith_error);

  XSETINT (val, XINT (x) % XINT (y));
  return val;
}

  i1 = XINT (x);
  i2 = XINT (y);

  if (i2 == 0)
    xsignal0 (Qarith_error);

  i1 %= i2;

  /* If the "remainder" comes out with the wrong sign, fix it.  */
  if (i2 < 0 ? i1 > 0 : i1 < 0)

#else /* not BSD4_1 */
  sigsetmask (SIGEMPTYMASK);
#endif /* not BSD4_1 */

  SIGNAL_THREAD_CHECK (signo);
  xsignal0 (Qarith_error);
}

void
init_data ()
{