comparison src/fns.c @ 14091:34911b128a47

(Frandom, Flength, Felt, Fsort, Fchar_table_subtype, Fchar_table_parent, Fset_char_table_parent, Fchar_table_extra_slot, Fset_char_table_extra_slot, Fchar_table_range, Fset_char_table_range, Fmap_char_table, Fmapconcat, Fmapcar): Harmonize arguments with documentation.

14090:24b93860d392

  "Return a pseudo-random number.\n\
All integers representable in Lisp are equally likely.\n\
  On most systems, this is 28 bits' worth.\n\
With positive integer argument N, return random number in interval [0,N).\n\
With argument t, set the random number seed from the current time and pid.")
  (limit)
     Lisp_Object limit;
{
  EMACS_INT val;
  Lisp_Object lispy_val;
  unsigned long denominator;

  if (EQ (limit, Qt))
    seed_random (getpid () + time (NULL));
  if (NATNUMP (limit) && XFASTINT (limit) != 0)
    {
      /* Try to take our random number from the higher bits of VAL,
	 not the lower, since (says Gentzel) the low bits of `random'
	 are less random than the higher ones.  We do this by using the
	 quotient rather than the remainder.  At the high end of the RNG
	 it's possible to get a quotient larger than limit; discarding
	 these values eliminates the bias that would otherwise appear
	 when using a large limit.  */
      denominator = ((unsigned long)1 << VALBITS) / XFASTINT (limit);
      do
	val = get_random () / denominator;
      while (val >= XFASTINT (limit));
    }
  else
    val = get_random ();
  XSETINT (lispy_val, val);
  return lispy_val;

/* Random data-structure functions */

DEFUN ("length", Flength, Slength, 1, 1, 0,
  "Return the length of vector, list or string SEQUENCE.\n\
A byte-code function object is also allowed.")
  (obj)
     register Lisp_Object obj;
{
  register Lisp_Object tail, val;
  register int i;

 retry:
  if (STRINGP (obj))
    XSETFASTINT (val, XSTRING (obj)->size);
  else if (VECTORP (obj))
    XSETFASTINT (val, XVECTOR (obj)->size);
  else if (CHAR_TABLE_P (obj))
    XSETFASTINT (val, CHAR_TABLE_ORDINARY_SLOTS);
  else if (BOOL_VECTOR_P (obj))
    XSETFASTINT (val, XBOOL_VECTOR (obj)->size);
  else if (COMPILEDP (obj))
    XSETFASTINT (val, XVECTOR (obj)->size & PSEUDOVECTOR_SIZE_MASK);
  else if (CONSP (obj))
    {
      for (i = 0, tail = obj; !NILP (tail); i++)
	{
	  QUIT;
	  tail = Fcdr (tail);
	}

      XSETFASTINT (val, i);
    }
  else if (NILP (obj))
    XSETFASTINT (val, 0);
  else
    {
      obj = wrong_type_argument (Qsequencep, obj);
      goto retry;
    }
  return val;
}

  return Fcar (Fnthcdr (n, list));
}

DEFUN ("elt", Felt, Selt, 2, 2, 0,
  "Return element of SEQUENCE at index N.")
  (seq, n)
     register Lisp_Object seq, n;
{
  CHECK_NUMBER (n, 0);
  while (1)
    {
      if (CONSP (seq) || NILP (seq))
	return Fcar (Fnthcdr (n, seq));
      else if (STRINGP (seq) || VECTORP (seq) || BOOL_VECTOR_P (seq)
	       || CHAR_TABLE_P (seq))
	return Faref (seq, n);
      else
	seq = wrong_type_argument (Qsequencep, seq);
    }
}

DEFUN ("member", Fmember, Smember, 2, 2, 0,
  "Return non-nil if ELT is an element of LIST.  Comparison done with `equal'.\n\

DEFUN ("sort", Fsort, Ssort, 2, 2, 0,
  "Sort LIST, stably, comparing elements using PREDICATE.\n\
Returns the sorted list.  LIST is modified by side effects.\n\
PREDICATE is called with two elements of LIST, and should return T\n\
if the first element is \"less\" than the second.")
  (list, pred)
     Lisp_Object list, pred;
{
  Lisp_Object front, back;
  register Lisp_Object len, tem;
  struct gcpro gcpro1, gcpro2;
  register int length;

  tem = Fnthcdr (len, list);
  back = Fcdr (tem);
  Fsetcdr (tem, Qnil);

  GCPRO2 (front, back);
  front = Fsort (front, pred);
  back = Fsort (back, pred);
  UNGCPRO;
  return merge (front, back, pred);
}

Lisp_Object
merge (org_l1, org_l2, pred)
     Lisp_Object org_l1, org_l2;

}

DEFUN ("char-table-subtype", Fchar_table_subtype, Schar_table_subtype,
       1, 1, 0,
  "Return the subtype of char-table CHAR-TABLE.   The value is a symbol.")
  (chartable)
     Lisp_Object chartable;
{
  CHECK_CHAR_TABLE (chartable, 0);  

  return XCHAR_TABLE (chartable)->purpose;
}

DEFUN ("char-table-parent", Fchar_table_parent, Schar_table_parent,
       1, 1, 0,
  "Return the parent char-table of CHAR-TABLE.\n\
The value is either nil or another char-table.\n\
If CHAR-TABLE holds nil for a given character,\n\
then the actual applicable value is inherited from the parent char-table\n\
\(or from its parents, if necessary).")
  (chartable)
     Lisp_Object chartable;
{
  CHECK_CHAR_TABLE (chartable, 0);  

  return XCHAR_TABLE (chartable)->parent;
}

DEFUN ("set-char-table-parent", Fset_char_table_parent, Sset_char_table_parent,
       2, 2, 0,
  "Set the parent char-table of CHAR-TABLE to PARENT.\n\
PARENT must be either nil or another char-table.")
  (chartable, parent)
     Lisp_Object chartable, parent;
{
  Lisp_Object temp;

  CHECK_CHAR_TABLE (chartable, 0);  

  if (!NILP (parent))
    {
      CHECK_CHAR_TABLE (parent, 0);  

      for (temp = parent; !NILP (temp); temp = XCHAR_TABLE (temp)->parent)
	if (EQ (temp, chartable))
	  error ("Attempt to make a chartable be its own parent");
    }

  XCHAR_TABLE (chartable)->parent = parent;

  return parent;
}

DEFUN ("char-table-extra-slot", Fchar_table_extra_slot, Schar_table_extra_slot,
       2, 2, 0,
  "Return the value in extra-slot number N of char-table CHAR-TABLE.")
  (chartable, n)
     Lisp_Object chartable, n;
{
  CHECK_CHAR_TABLE (chartable, 1);
  CHECK_NUMBER (n, 2);
  if (XINT (n) < 0
      || XINT (n) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (chartable)))
    args_out_of_range (chartable, n);

  return XCHAR_TABLE (chartable)->extras[XINT (n)];
}

DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot,
       Sset_char_table_extra_slot,
       3, 3, 0,
  "Set extra-slot number N of CHAR-TABLE to VALUE.")
  (chartable, n, value)
     Lisp_Object chartable, n, value;
{
  CHECK_CHAR_TABLE (chartable, 1);
  CHECK_NUMBER (n, 2);
  if (XINT (n) < 0
      || XINT (n) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (chartable)))
    args_out_of_range (chartable, n);

  return XCHAR_TABLE (chartable)->extras[XINT (n)] = value;
}

DEFUN ("char-table-range", Fchar_table_range, Schar_table_range,
       2, 2, 0,
  "Return the value in CHARTABLE for a range of characters RANGE.\n\
RANGE should be t (for all characters), nil (for the default value)\n\
a vector which identifies a character set or a row of a character set,\n\
or a character code.")
  (chartable, range)
     Lisp_Object chartable, range;
{
  int i;

  CHECK_CHAR_TABLE (chartable, 0);
  
  if (EQ (range, Qnil))
    return XCHAR_TABLE (chartable)->defalt;
  else if (INTEGERP (range))
    return Faref (chartable, range);
  else if (VECTORP (range))
    {
      for (i = 0; i < XVECTOR (range)->size - 1; i++)
	chartable = Faref (chartable, XVECTOR (range)->contents[i]);

      if (EQ (XVECTOR (range)->contents[i], Qnil))
	return XCHAR_TABLE (chartable)->defalt;
      else
	return Faref (chartable, XVECTOR (range)->contents[i]);
    }
  else
    error ("Invalid RANGE argument to `char-table-range'");
}

DEFUN ("set-char-table-range", Fset_char_table_range, Sset_char_table_range,
       3, 3, 0,
  "Set the value in CHARTABLE for a range of characters RANGE to VALUE.\n\
RANGE should be t (for all characters), nil (for the default value)\n\
a vector which identifies a character set or a row of a character set,\n\
or a character code.")
  (chartable, range, value)
     Lisp_Object chartable, range, value;
{
  int i;

  CHECK_CHAR_TABLE (chartable, 0);
  
  if (EQ (range, Qt))
    for (i = 0; i < CHAR_TABLE_ORDINARY_SLOTS; i++)
      XCHAR_TABLE (chartable)->contents[i] = value;
  else if (EQ (range, Qnil))
    XCHAR_TABLE (chartable)->defalt = value;
  else if (INTEGERP (range))
    Faset (chartable, range, value);
  else if (VECTORP (range))
    {
      for (i = 0; i < XVECTOR (range)->size - 1; i++)
	chartable = Faref (chartable, XVECTOR (range)->contents[i]);

      if (EQ (XVECTOR (range)->contents[i], Qnil))
	XCHAR_TABLE (chartable)->defalt = value;
      else
	Faset (chartable, XVECTOR (range)->contents[i], value);
    }
  else
    error ("Invalid RANGE argument to `set-char-table-range'");

  return value;

    }
}

DEFUN ("map-char-table", Fmap_char_table, Smap_char_table,
  2, 2, 0,
  "Call FUNCTION for each range of like characters in CHARTABLE.\n\
FUNCTION is called with two arguments--a key and a value.\n\
The key is always a possible RANGE argument to `set-char-table-range'.")
  (function, chartable)
     Lisp_Object function, chartable;
{
  Lisp_Object keyvec;
  Lisp_Object *indices = (Lisp_Object *) alloca (10 * sizeof (Lisp_Object));

  map_char_table (NULL, function, chartable, 0, indices);
  return Qnil;
}

/* ARGSUSED */
Lisp_Object

  UNGCPRO;
}

DEFUN ("mapconcat", Fmapconcat, Smapconcat, 3, 3, 0,
  "Apply FN to each element of SEQ, and concat the results as strings.\n\
In between each pair of results, stick in SEP.\n\
Thus, \" \" as SEP results in spaces between the values returned by FN.")
  (fn, seq, sep)
     Lisp_Object fn, seq, sep;
{
  Lisp_Object len;
  register int leni;
  int nargs;
  register Lisp_Object *args;
  register int i;
  struct gcpro gcpro1;

  len = Flength (seq);
  leni = XINT (len);
  nargs = leni + leni - 1;
  if (nargs < 0) return build_string ("");

  args = (Lisp_Object *) alloca (nargs * sizeof (Lisp_Object));

  GCPRO1 (sep);
  mapcar1 (leni, args, fn, seq);
  UNGCPRO;

  for (i = leni - 1; i >= 0; i--)
    args[i + i] = args[i];
      
  for (i = 1; i < nargs; i += 2)
    args[i] = sep;

  return Fconcat (nargs, args);
}

DEFUN ("mapcar", Fmapcar, Smapcar, 2, 2, 0,
  "Apply FUNCTION to each element of SEQUENCE, and make a list of the results.\n\
The result is a list just as long as SEQUENCE.\n\
SEQUENCE may be a list, a vector or a string.")
  (fn, seq)
     Lisp_Object fn, seq;
{
  register Lisp_Object len;
  register int leni;
  register Lisp_Object *args;

  len = Flength (seq);
  leni = XFASTINT (len);
  args = (Lisp_Object *) alloca (leni * sizeof (Lisp_Object));

  mapcar1 (leni, args, fn, seq);

  return Flist (leni, args);
}

/* Anything that calls this function must protect from GC!  */

14091:34911b128a47

  "Return a pseudo-random number.\n\
All integers representable in Lisp are equally likely.\n\
  On most systems, this is 28 bits' worth.\n\
With positive integer argument N, return random number in interval [0,N).\n\
With argument t, set the random number seed from the current time and pid.")
  (n)
     Lisp_Object n;
{
  EMACS_INT val;
  Lisp_Object lispy_val;
  unsigned long denominator;

  if (EQ (n, Qt))
    seed_random (getpid () + time (NULL));
  if (NATNUMP (n) && XFASTINT (n) != 0)
    {
      /* Try to take our random number from the higher bits of VAL,
	 not the lower, since (says Gentzel) the low bits of `random'
	 are less random than the higher ones.  We do this by using the
	 quotient rather than the remainder.  At the high end of the RNG
	 it's possible to get a quotient larger than n; discarding
	 these values eliminates the bias that would otherwise appear
	 when using a large n.  */
      denominator = ((unsigned long)1 << VALBITS) / XFASTINT (n);
      do
	val = get_random () / denominator;
      while (val >= XFASTINT (n));
    }
  else
    val = get_random ();
  XSETINT (lispy_val, val);
  return lispy_val;

/* Random data-structure functions */

DEFUN ("length", Flength, Slength, 1, 1, 0,
  "Return the length of vector, list or string SEQUENCE.\n\
A byte-code function object is also allowed.")
  (sequence)
     register Lisp_Object sequence;
{
  register Lisp_Object tail, val;
  register int i;

 retry:
  if (STRINGP (sequence))
    XSETFASTINT (val, XSTRING (sequence)->size);
  else if (VECTORP (sequence))
    XSETFASTINT (val, XVECTOR (sequence)->size);
  else if (CHAR_TABLE_P (sequence))
    XSETFASTINT (val, CHAR_TABLE_ORDINARY_SLOTS);
  else if (BOOL_VECTOR_P (sequence))
    XSETFASTINT (val, XBOOL_VECTOR (sequence)->size);
  else if (COMPILEDP (sequence))
    XSETFASTINT (val, XVECTOR (sequence)->size & PSEUDOVECTOR_SIZE_MASK);
  else if (CONSP (sequence))
    {
      for (i = 0, tail = sequence; !NILP (tail); i++)
	{
	  QUIT;
	  tail = Fcdr (tail);
	}

      XSETFASTINT (val, i);
    }
  else if (NILP (sequence))
    XSETFASTINT (val, 0);
  else
    {
      sequence = wrong_type_argument (Qsequencep, sequence);
      goto retry;
    }
  return val;
}

  return Fcar (Fnthcdr (n, list));
}

DEFUN ("elt", Felt, Selt, 2, 2, 0,
  "Return element of SEQUENCE at index N.")
  (sequence, n)
     register Lisp_Object sequence, n;
{
  CHECK_NUMBER (n, 0);
  while (1)
    {
      if (CONSP (sequence) || NILP (sequence))
	return Fcar (Fnthcdr (n, sequence));
      else if (STRINGP (sequence) || VECTORP (sequence)
	       || BOOL_VECTOR_P (sequence) || CHAR_TABLE_P (sequence))
	return Faref (sequence, n);
      else
	sequence = wrong_type_argument (Qsequencep, sequence);
    }
}

DEFUN ("member", Fmember, Smember, 2, 2, 0,
  "Return non-nil if ELT is an element of LIST.  Comparison done with `equal'.\n\

DEFUN ("sort", Fsort, Ssort, 2, 2, 0,
  "Sort LIST, stably, comparing elements using PREDICATE.\n\
Returns the sorted list.  LIST is modified by side effects.\n\
PREDICATE is called with two elements of LIST, and should return T\n\
if the first element is \"less\" than the second.")
  (list, predicate)
     Lisp_Object list, predicate;
{
  Lisp_Object front, back;
  register Lisp_Object len, tem;
  struct gcpro gcpro1, gcpro2;
  register int length;

  tem = Fnthcdr (len, list);
  back = Fcdr (tem);
  Fsetcdr (tem, Qnil);

  GCPRO2 (front, back);
  front = Fsort (front, predicate);
  back = Fsort (back, predicate);
  UNGCPRO;
  return merge (front, back, predicate);
}

Lisp_Object
merge (org_l1, org_l2, pred)
     Lisp_Object org_l1, org_l2;

}

DEFUN ("char-table-subtype", Fchar_table_subtype, Schar_table_subtype,
       1, 1, 0,
  "Return the subtype of char-table CHAR-TABLE.   The value is a symbol.")
  (char_table)
     Lisp_Object char_table;
{
  CHECK_CHAR_TABLE (char_table, 0);  

  return XCHAR_TABLE (char_table)->purpose;
}

DEFUN ("char-table-parent", Fchar_table_parent, Schar_table_parent,
       1, 1, 0,
  "Return the parent char-table of CHAR-TABLE.\n\
The value is either nil or another char-table.\n\
If CHAR-TABLE holds nil for a given character,\n\
then the actual applicable value is inherited from the parent char-table\n\
\(or from its parents, if necessary).")
  (char_table)
     Lisp_Object char_table;
{
  CHECK_CHAR_TABLE (char_table, 0);  

  return XCHAR_TABLE (char_table)->parent;
}

DEFUN ("set-char-table-parent", Fset_char_table_parent, Sset_char_table_parent,
       2, 2, 0,
  "Set the parent char-table of CHAR-TABLE to PARENT.\n\
PARENT must be either nil or another char-table.")
  (char_table, parent)
     Lisp_Object char_table, parent;
{
  Lisp_Object temp;

  CHECK_CHAR_TABLE (char_table, 0);  

  if (!NILP (parent))
    {
      CHECK_CHAR_TABLE (parent, 0);  

      for (temp = parent; !NILP (temp); temp = XCHAR_TABLE (temp)->parent)
	if (EQ (temp, chartable))
	  error ("Attempt to make a chartable be its own parent");
    }

  XCHAR_TABLE (char_table)->parent = parent;

  return parent;
}

DEFUN ("char-table-extra-slot", Fchar_table_extra_slot, Schar_table_extra_slot,
       2, 2, 0,
  "Return the value in extra-slot number N of char-table CHAR-TABLE.")
  (char_table, n)
     Lisp_Object char_table, n;
{
  CHECK_CHAR_TABLE (char_table, 1);
  CHECK_NUMBER (n, 2);
  if (XINT (n) < 0
      || XINT (n) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table)))
    args_out_of_range (char_table, n);

  return XCHAR_TABLE (char_table)->extras[XINT (n)];
}

DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot,
       Sset_char_table_extra_slot,
       3, 3, 0,
  "Set extra-slot number N of CHAR-TABLE to VALUE.")
  (char_table, n, value)
     Lisp_Object char_table, n, value;
{
  CHECK_CHAR_TABLE (char_table, 1);
  CHECK_NUMBER (n, 2);
  if (XINT (n) < 0
      || XINT (n) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table)))
    args_out_of_range (char_table, n);

  return XCHAR_TABLE (char_table)->extras[XINT (n)] = value;
}

DEFUN ("char-table-range", Fchar_table_range, Schar_table_range,
       2, 2, 0,
  "Return the value in CHAR-TABLE for a range of characters RANGE.\n\
RANGE should be t (for all characters), nil (for the default value)\n\
a vector which identifies a character set or a row of a character set,\n\
or a character code.")
  (char_table, range)
     Lisp_Object char_table, range;
{
  int i;

  CHECK_CHAR_TABLE (char_table, 0);
  
  if (EQ (range, Qnil))
    return XCHAR_TABLE (char_table)->defalt;
  else if (INTEGERP (range))
    return Faref (char_table, range);
  else if (VECTORP (range))
    {
      for (i = 0; i < XVECTOR (range)->size - 1; i++)
	char_table = Faref (char_table, XVECTOR (range)->contents[i]);

      if (EQ (XVECTOR (range)->contents[i], Qnil))
	return XCHAR_TABLE (char_table)->defalt;
      else
	return Faref (char_table, XVECTOR (range)->contents[i]);
    }
  else
    error ("Invalid RANGE argument to `char-table-range'");
}

DEFUN ("set-char-table-range", Fset_char_table_range, Sset_char_table_range,
       3, 3, 0,
  "Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.\n\
RANGE should be t (for all characters), nil (for the default value)\n\
a vector which identifies a character set or a row of a character set,\n\
or a character code.")
  (char_table, range, value)
     Lisp_Object char_table, range, value;
{
  int i;

  CHECK_CHAR_TABLE (char_table, 0);
  
  if (EQ (range, Qt))
    for (i = 0; i < CHAR_TABLE_ORDINARY_SLOTS; i++)
      XCHAR_TABLE (char_table)->contents[i] = value;
  else if (EQ (range, Qnil))
    XCHAR_TABLE (char_table)->defalt = value;
  else if (INTEGERP (range))
    Faset (char_table, range, value);
  else if (VECTORP (range))
    {
      for (i = 0; i < XVECTOR (range)->size - 1; i++)
	char_table = Faref (char_table, XVECTOR (range)->contents[i]);

      if (EQ (XVECTOR (range)->contents[i], Qnil))
	XCHAR_TABLE (char_table)->defalt = value;
      else
	Faset (char_table, XVECTOR (range)->contents[i], value);
    }
  else
    error ("Invalid RANGE argument to `set-char-table-range'");

  return value;

    }
}

DEFUN ("map-char-table", Fmap_char_table, Smap_char_table,
  2, 2, 0,
  "Call FUNCTION for each range of like characters in CHAR-TABLE.\n\
FUNCTION is called with two arguments--a key and a value.\n\
The key is always a possible RANGE argument to `set-char-table-range'.")
  (function, char_table)
     Lisp_Object function, char_table;
{
  Lisp_Object keyvec;
  Lisp_Object *indices = (Lisp_Object *) alloca (10 * sizeof (Lisp_Object));

  map_char_table (NULL, function, char_table, 0, indices);
  return Qnil;
}

/* ARGSUSED */
Lisp_Object

  UNGCPRO;
}

DEFUN ("mapconcat", Fmapconcat, Smapconcat, 3, 3, 0,
  "Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.\n\
In between each pair of results, stick in SEPARATOR.  Thus, \" \" as\n\
SEPARATOR results in spaces between the values returned by FUNCTION.")
  (function, sequence, separator)
     Lisp_Object function, sequence, separator;
{
  Lisp_Object len;
  register int leni;
  int nargs;
  register Lisp_Object *args;
  register int i;
  struct gcpro gcpro1;

  len = Flength (sequence);
  leni = XINT (len);
  nargs = leni + leni - 1;
  if (nargs < 0) return build_string ("");

  args = (Lisp_Object *) alloca (nargs * sizeof (Lisp_Object));

  GCPRO1 (separator);
  mapcar1 (leni, args, function, sequence);
  UNGCPRO;

  for (i = leni - 1; i >= 0; i--)
    args[i + i] = args[i];
      
  for (i = 1; i < nargs; i += 2)
    args[i] = separator;

  return Fconcat (nargs, args);
}

DEFUN ("mapcar", Fmapcar, Smapcar, 2, 2, 0,
  "Apply FUNCTION to each element of SEQUENCE, and make a list of the results.\n\
The result is a list just as long as SEQUENCE.\n\
SEQUENCE may be a list, a vector or a string.")
  (function, sequence)
     Lisp_Object function, sequence;
{
  register Lisp_Object len;
  register int leni;
  register Lisp_Object *args;

  len = Flength (sequence);
  leni = XFASTINT (len);
  args = (Lisp_Object *) alloca (leni * sizeof (Lisp_Object));

  mapcar1 (leni, args, function, sequence);

  return Flist (leni, args);
}

/* Anything that calls this function must protect from GC!  */