fns.c 162 KB
Newer Older
Jim Blandy's avatar
Jim Blandy committed
1
/* Random utility Lisp functions.
2

Paul Eggert's avatar
Paul Eggert committed
3
Copyright (C) 1985-1987, 1993-1995, 1997-2020 Free Software Foundation,
4
Inc.
Jim Blandy's avatar
Jim Blandy committed
5 6 7

This file is part of GNU Emacs.

8
GNU Emacs is free software: you can redistribute it and/or modify
Jim Blandy's avatar
Jim Blandy committed
9
it under the terms of the GNU General Public License as published by
10 11
the Free Software Foundation, either version 3 of the License, or (at
your option) any later version.
Jim Blandy's avatar
Jim Blandy committed
12 13 14 15 16 17 18

GNU Emacs is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
19
along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.  */
Jim Blandy's avatar
Jim Blandy committed
20

21
#include <config.h>
Jim Blandy's avatar
Jim Blandy committed
22

Paul Eggert's avatar
Paul Eggert committed
23
#include <stdlib.h>
Paul Eggert's avatar
Paul Eggert committed
24
#include <sys/random.h>
Andreas Schwab's avatar
Andreas Schwab committed
25
#include <unistd.h>
26
#include <filevercmp.h>
27
#include <intprops.h>
Paul Eggert's avatar
Paul Eggert committed
28
#include <vla.h>
29
#include <errno.h>
30

Jim Blandy's avatar
Jim Blandy committed
31
#include "lisp.h"
Paul Eggert's avatar
Paul Eggert committed
32
#include "bignum.h"
33
#include "character.h"
34
#include "coding.h"
35
#include "composite.h"
Jim Blandy's avatar
Jim Blandy committed
36
#include "buffer.h"
37
#include "intervals.h"
38
#include "window.h"
39
#include "puresize.h"
40
#include "gnutls.h"
Jim Blandy's avatar
Jim Blandy committed
41

Paul Eggert's avatar
Paul Eggert committed
42
static void sort_vector_copy (Lisp_Object, ptrdiff_t,
43
			      Lisp_Object *restrict, Lisp_Object *restrict);
44 45 46
enum equal_kind { EQUAL_NO_QUIT, EQUAL_PLAIN, EQUAL_INCLUDING_PROPERTIES };
static bool internal_equal (Lisp_Object, Lisp_Object,
			    enum equal_kind, int, Lisp_Object);
Paul Eggert's avatar
Paul Eggert committed
47
static EMACS_UINT sxhash_obj (Lisp_Object, int);
48

Paul Eggert's avatar
Paul Eggert committed
49
DEFUN ("identity", Fidentity, Sidentity, 1, 1, 0,
50
       doc: /* Return the ARGUMENT unchanged.  */
51
       attributes: const)
52
  (Lisp_Object argument)
Jim Blandy's avatar
Jim Blandy committed
53
{
54
  return argument;
Jim Blandy's avatar
Jim Blandy committed
55 56 57
}

DEFUN ("random", Frandom, Srandom, 0, 1, 0,
58 59 60
       doc: /* Return a pseudo-random integer.
By default, return a fixnum; all fixnums are equally likely.
With positive fixnum LIMIT, return random integer in interval [0,LIMIT).
61
With argument t, set the random number seed from the system's entropy
62
pool if available, otherwise from less-random volatile data such as the time.
Glenn Morris's avatar
Glenn Morris committed
63 64 65
With a string argument, set the seed based on the string's contents.

See Info node `(elisp)Random Numbers' for more details.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
66
  (Lisp_Object limit)
Jim Blandy's avatar
Jim Blandy committed
67
{
68
  EMACS_INT val;
Jim Blandy's avatar
Jim Blandy committed
69

70
  if (EQ (limit, Qt))
71 72 73
    init_random ();
  else if (STRINGP (limit))
    seed_random (SSDATA (limit), SBYTES (limit));
74

75
  val = get_random ();
Tom Tromey's avatar
Tom Tromey committed
76
  if (FIXNUMP (limit) && 0 < XFIXNUM (limit))
77 78 79 80 81
    while (true)
      {
	/* Return the remainder, except reject the rare case where
	   get_random returns a number so close to INTMASK that the
	   remainder isn't random.  */
Tom Tromey's avatar
Tom Tromey committed
82 83
	EMACS_INT remainder = val % XFIXNUM (limit);
	if (val - remainder <= INTMASK - XFIXNUM (limit) + 1)
84
	  return make_fixnum (remainder);
85 86
	val = get_random ();
      }
87
  return make_ufixnum (val);
Jim Blandy's avatar
Jim Blandy committed
88 89
}

90
/* Random data-structure functions.  */
Jim Blandy's avatar
Jim Blandy committed
91

Paul Eggert's avatar
Paul Eggert committed
92
/* Return LIST's length.  Signal an error if LIST is not a proper list.  */
Paul Eggert's avatar
Paul Eggert committed
93 94 95 96 97 98 99 100

ptrdiff_t
list_length (Lisp_Object list)
{
  intptr_t i = 0;
  FOR_EACH_TAIL (list)
    i++;
  CHECK_LIST_END (list, list);
101
  return i;
Paul Eggert's avatar
Paul Eggert committed
102 103 104
}


Paul Eggert's avatar
Paul Eggert committed
105
DEFUN ("length", Flength, Slength, 1, 1, 0,
106
       doc: /* Return the length of vector, list or string SEQUENCE.
Gerd Moellmann's avatar
Gerd Moellmann committed
107
A byte-code function object is also allowed.
John Paul Wallington's avatar
John Paul Wallington committed
108
If the string contains multibyte characters, this is not necessarily
Gerd Moellmann's avatar
Gerd Moellmann committed
109
the number of bytes in the string; it is the number of characters.
110
To get the number of bytes, use `string-bytes'.  */)
Paul Eggert's avatar
Paul Eggert committed
111
  (Lisp_Object sequence)
Jim Blandy's avatar
Jim Blandy committed
112
{
Paul Eggert's avatar
Paul Eggert committed
113
  EMACS_INT val;
Jim Blandy's avatar
Jim Blandy committed
114

115
  if (STRINGP (sequence))
Paul Eggert's avatar
Paul Eggert committed
116
    val = SCHARS (sequence);
117
  else if (VECTORP (sequence))
Paul Eggert's avatar
Paul Eggert committed
118
    val = ASIZE (sequence);
119
  else if (CHAR_TABLE_P (sequence))
Paul Eggert's avatar
Paul Eggert committed
120
    val = MAX_CHAR;
121
  else if (BOOL_VECTOR_P (sequence))
Paul Eggert's avatar
Paul Eggert committed
122
    val = bool_vector_size (sequence);
123
  else if (COMPILEDP (sequence) || RECORDP (sequence))
Paul Eggert's avatar
Paul Eggert committed
124
    val = PVSIZE (sequence);
125
  else if (CONSP (sequence))
Paul Eggert's avatar
Paul Eggert committed
126
    val = list_length (sequence);
127
  else if (NILP (sequence))
Paul Eggert's avatar
Paul Eggert committed
128
    val = 0;
Jim Blandy's avatar
Jim Blandy committed
129
  else
130
    wrong_type_argument (Qsequencep, sequence);
131

Paul Eggert's avatar
Paul Eggert committed
132
  return make_fixnum (val);
Jim Blandy's avatar
Jim Blandy committed
133 134
}

135
DEFUN ("safe-length", Fsafe_length, Ssafe_length, 1, 1, 0,
136
       doc: /* Return the length of a list, but avoid error or infinite loop.
Gerd Moellmann's avatar
Gerd Moellmann committed
137
This function never gets an error.  If LIST is not really a list,
138
it returns 0.  If LIST is circular, it returns an integer that is at
139
least the number of distinct elements.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
140
  (Lisp_Object list)
141
{
142 143 144
  intptr_t len = 0;
  FOR_EACH_TAIL_SAFE (list)
    len++;
145
  return make_fixnum (len);
146 147
}

Paul Eggert's avatar
Paul Eggert committed
148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164
DEFUN ("proper-list-p", Fproper_list_p, Sproper_list_p, 1, 1, 0,
       doc: /* Return OBJECT's length if it is a proper list, nil otherwise.
A proper list is neither circular nor dotted (i.e., its last cdr is nil).  */
       attributes: const)
  (Lisp_Object object)
{
  intptr_t len = 0;
  Lisp_Object last_tail = object;
  Lisp_Object tail = object;
  FOR_EACH_TAIL_SAFE (tail)
    {
      len++;
      rarely_quit (len);
      last_tail = XCDR (tail);
    }
  if (!NILP (last_tail))
    return Qnil;
165
  return make_fixnum (len);
Paul Eggert's avatar
Paul Eggert committed
166 167
}

168
DEFUN ("string-bytes", Fstring_bytes, Sstring_bytes, 1, 1, 0,
169
       doc: /* Return the number of bytes in STRING.
Miles Bader's avatar
Miles Bader committed
170
If STRING is multibyte, this may be greater than the length of STRING.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
171
  (Lisp_Object string)
172
{
173
  CHECK_STRING (string);
174
  return make_fixnum (SBYTES (string));
175 176
}

Chen Bin's avatar
Chen Bin committed
177 178
DEFUN ("string-distance", Fstring_distance, Sstring_distance, 2, 3, 0,
       doc: /* Return Levenshtein distance between STRING1 and STRING2.
179 180 181 182 183
The distance is the number of deletions, insertions, and substitutions
required to transform STRING1 into STRING2.
If BYTECOMPARE is nil or omitted, compute distance in terms of characters.
If BYTECOMPARE is non-nil, compute distance in terms of bytes.
Letter-case is significant, but text properties are ignored. */)
Chen Bin's avatar
Chen Bin committed
184 185 186 187 188 189
  (Lisp_Object string1, Lisp_Object string2, Lisp_Object bytecompare)

{
  CHECK_STRING (string1);
  CHECK_STRING (string2);

190 191
  bool use_byte_compare =
    !NILP (bytecompare)
Chen Bin's avatar
Chen Bin committed
192
    || (!STRING_MULTIBYTE (string1) && !STRING_MULTIBYTE (string2));
193 194
  ptrdiff_t len1 = use_byte_compare ? SBYTES (string1) : SCHARS (string1);
  ptrdiff_t len2 = use_byte_compare ? SBYTES (string2) : SCHARS (string2);
Chen Bin's avatar
Chen Bin committed
195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212
  ptrdiff_t x, y, lastdiag, olddiag;

  USE_SAFE_ALLOCA;
  ptrdiff_t *column = SAFE_ALLOCA ((len1 + 1) * sizeof (ptrdiff_t));
  for (y = 1; y <= len1; y++)
    column[y] = y;

  if (use_byte_compare)
    {
      char *s1 = SSDATA (string1);
      char *s2 = SSDATA (string2);

      for (x = 1; x <= len2; x++)
        {
          column[0] = x;
          for (y = 1, lastdiag = x - 1; y <= len1; y++)
            {
              olddiag = column[y];
213 214
              column[y] = min (min (column[y] + 1, column[y-1] + 1),
			       lastdiag + (s1[y-1] == s2[x-1] ? 0 : 1));
Chen Bin's avatar
Chen Bin committed
215 216 217 218 219 220 221 222 223 224 225
              lastdiag = olddiag;
            }
        }
    }
  else
    {
      int c1, c2;
      ptrdiff_t i1, i1_byte, i2 = 0, i2_byte = 0;
      for (x = 1; x <= len2; x++)
        {
          column[0] = x;
226
          c2 = fetch_string_char_advance (string2, &i2, &i2_byte);
Chen Bin's avatar
Chen Bin committed
227 228 229 230
          i1 = i1_byte = 0;
          for (y = 1, lastdiag = x - 1; y <= len1; y++)
            {
              olddiag = column[y];
231
              c1 = fetch_string_char_advance (string1, &i1, &i1_byte);
232 233
              column[y] = min (min (column[y] + 1, column[y-1] + 1),
			       lastdiag + (c1 == c2 ? 0 : 1));
Chen Bin's avatar
Chen Bin committed
234 235 236 237 238 239
              lastdiag = olddiag;
            }
        }
    }

  SAFE_FREE ();
240
  return make_fixnum (column[len1]);
Chen Bin's avatar
Chen Bin committed
241 242
}

Paul Eggert's avatar
Paul Eggert committed
243
DEFUN ("string-equal", Fstring_equal, Sstring_equal, 2, 2, 0,
244
       doc: /* Return t if two strings have identical contents.
Gerd Moellmann's avatar
Gerd Moellmann committed
245
Case is significant, but text properties are ignored.
246
Symbols are also allowed; their print names are used instead.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
247
  (register Lisp_Object s1, Lisp_Object s2)
Jim Blandy's avatar
Jim Blandy committed
248
{
249
  if (SYMBOLP (s1))
250
    s1 = SYMBOL_NAME (s1);
251
  if (SYMBOLP (s2))
252
    s2 = SYMBOL_NAME (s2);
253 254
  CHECK_STRING (s1);
  CHECK_STRING (s2);
Jim Blandy's avatar
Jim Blandy committed
255

256 257
  if (SCHARS (s1) != SCHARS (s2)
      || SBYTES (s1) != SBYTES (s2)
258
      || memcmp (SDATA (s1), SDATA (s2), SBYTES (s1)))
Jim Blandy's avatar
Jim Blandy committed
259 260 261 262
    return Qnil;
  return Qt;
}

Paul Eggert's avatar
Paul Eggert committed
263
DEFUN ("compare-strings", Fcompare_strings, Scompare_strings, 6, 7, 0,
Juanma Barranquero's avatar
Juanma Barranquero committed
264
       doc: /* Compare the contents of two strings, converting to multibyte if needed.
265 266 267
The arguments START1, END1, START2, and END2, if non-nil, are
positions specifying which parts of STR1 or STR2 to compare.  In
string STR1, compare the part between START1 (inclusive) and END1
268
\(exclusive).  If START1 is nil, it defaults to 0, the beginning of
269 270
the string; if END1 is nil, it defaults to the length of the string.
Likewise, in string STR2, compare the part between START2 and END2.
271
Like in `substring', negative values are counted from the end.
272 273 274 275

The strings are compared by the numeric values of their characters.
For instance, STR1 is "less than" STR2 if its first differing
character has a smaller numeric value.  If IGNORE-CASE is non-nil,
276
characters are converted to upper-case before comparing them.  Unibyte
277
strings are converted to multibyte for comparison.
Gerd Moellmann's avatar
Gerd Moellmann committed
278 279 280 281 282

The value is t if the strings (or specified portions) match.
If string STR1 is less, the value is a negative number N;
  - 1 - N is the number of characters that match at the beginning.
If string STR1 is greater, the value is a positive number N;
283
  N - 1 is the number of characters that match at the beginning.  */)
284 285
  (Lisp_Object str1, Lisp_Object start1, Lisp_Object end1, Lisp_Object str2,
   Lisp_Object start2, Lisp_Object end2, Lisp_Object ignore_case)
286
{
287
  ptrdiff_t from1, to1, from2, to2, i1, i1_byte, i2, i2_byte;
288

289 290
  CHECK_STRING (str1);
  CHECK_STRING (str2);
291

292 293
  /* For backward compatibility, silently bring too-large positive end
     values into range.  */
Tom Tromey's avatar
Tom Tromey committed
294
  if (FIXNUMP (end1) && SCHARS (str1) < XFIXNUM (end1))
295
    end1 = make_fixnum (SCHARS (str1));
Tom Tromey's avatar
Tom Tromey committed
296
  if (FIXNUMP (end2) && SCHARS (str2) < XFIXNUM (end2))
297
    end2 = make_fixnum (SCHARS (str2));
298

299 300 301 302 303
  validate_subarray (str1, start1, end1, SCHARS (str1), &from1, &to1);
  validate_subarray (str2, start2, end2, SCHARS (str2), &from2, &to2);

  i1 = from1;
  i2 = from2;
304 305 306

  i1_byte = string_char_to_byte (str1, i1);
  i2_byte = string_char_to_byte (str2, i2);
307

308
  while (i1 < to1 && i2 < to2)
309 310 311
    {
      /* When we find a mismatch, we must compare the
	 characters, not just the bytes.  */
312 313
      int c1 = fetch_string_char_as_multibyte_advance (str1, &i1, &i1_byte);
      int c2 = fetch_string_char_as_multibyte_advance (str2, &i2, &i2_byte);
314 315 316 317 318 319

      if (c1 == c2)
	continue;

      if (! NILP (ignore_case))
	{
Tom Tromey's avatar
Tom Tromey committed
320 321
	  c1 = XFIXNUM (Fupcase (make_fixnum (c1)));
	  c2 = XFIXNUM (Fupcase (make_fixnum (c2)));
322 323 324 325 326 327 328 329 330
	}

      if (c1 == c2)
	continue;

      /* Note that I1 has already been incremented
	 past the character that we are comparing;
	 hence we don't add or subtract 1 here.  */
      if (c1 < c2)
331
	return make_fixnum (- i1 + from1);
332
      else
333
	return make_fixnum (i1 - from1);
334 335
    }

336
  if (i1 < to1)
337
    return make_fixnum (i1 - from1 + 1);
338
  if (i2 < to2)
339
    return make_fixnum (- i1 + from1 - 1);
340 341 342 343

  return Qt;
}

Paul Eggert's avatar
Paul Eggert committed
344
DEFUN ("string-lessp", Fstring_lessp, Sstring_lessp, 2, 2, 0,
345
       doc: /* Return non-nil if STRING1 is less than STRING2 in lexicographic order.
Gerd Moellmann's avatar
Gerd Moellmann committed
346
Case is significant.
347
Symbols are also allowed; their print names are used instead.  */)
348
  (Lisp_Object string1, Lisp_Object string2)
Jim Blandy's avatar
Jim Blandy committed
349
{
350 351 352 353 354 355
  if (SYMBOLP (string1))
    string1 = SYMBOL_NAME (string1);
  if (SYMBOLP (string2))
    string2 = SYMBOL_NAME (string2);
  CHECK_STRING (string1);
  CHECK_STRING (string2);
Jim Blandy's avatar
Jim Blandy committed
356

357 358
  ptrdiff_t i1 = 0, i1_byte = 0, i2 = 0, i2_byte = 0;
  ptrdiff_t end = min (SCHARS (string1), SCHARS (string2));
Jim Blandy's avatar
Jim Blandy committed
359

360
  while (i1 < end)
Jim Blandy's avatar
Jim Blandy committed
361
    {
362 363
      /* When we find a mismatch, we must compare the
	 characters, not just the bytes.  */
364 365
      int c1 = fetch_string_char_advance (string1, &i1, &i1_byte);
      int c2 = fetch_string_char_advance (string2, &i2, &i2_byte);
366 367
      if (c1 != c2)
	return c1 < c2 ? Qt : Qnil;
Jim Blandy's avatar
Jim Blandy committed
368
    }
369
  return i1 < SCHARS (string2) ? Qt : Qnil;
Jim Blandy's avatar
Jim Blandy committed
370
}
Michael Albinus's avatar
Michael Albinus committed
371

372 373 374 375 376 377 378 379 380
DEFUN ("string-version-lessp", Fstring_version_lessp,
       Sstring_version_lessp, 2, 2, 0,
       doc: /* Return non-nil if S1 is less than S2, as version strings.

This function compares version strings S1 and S2:
   1) By prefix lexicographically.
   2) Then by version (similarly to version comparison of Debian's dpkg).
      Leading zeros in version numbers are ignored.
   3) If both prefix and version are equal, compare as ordinary strings.
381

382
For example, \"foo2.png\" compares less than \"foo12.png\".
383 384
Case is significant.
Symbols are also allowed; their print names are used instead.  */)
385
  (Lisp_Object string1, Lisp_Object string2)
386 387 388 389 390 391 392
{
  if (SYMBOLP (string1))
    string1 = SYMBOL_NAME (string1);
  if (SYMBOLP (string2))
    string2 = SYMBOL_NAME (string2);
  CHECK_STRING (string1);
  CHECK_STRING (string2);
393 394
  return string_version_cmp (string1, string2) < 0 ? Qt : Qnil;
}
395

396 397 398 399 400
/* Return negative, 0, positive if STRING1 is <, =, > STRING2 as per
   string-version-lessp.  */
int
string_version_cmp (Lisp_Object string1, Lisp_Object string2)
{
401 402 403 404 405
  char *p1 = SSDATA (string1);
  char *p2 = SSDATA (string2);
  char *lim1 = p1 + SBYTES (string1);
  char *lim2 = p2 + SBYTES (string2);
  int cmp;
406

407
  while ((cmp = filevercmp (p1, p2)) == 0)
408
    {
409
      /* If the strings are identical through their first NUL bytes,
410 411
	 skip past identical prefixes and try again.  */
      ptrdiff_t size = strlen (p1) + 1;
412
      eassert (size == strlen (p2) + 1);
413 414
      p1 += size;
      p2 += size;
415 416 417 418 419 420
      bool more1 = p1 <= lim1;
      bool more2 = p2 <= lim2;
      if (!more1)
	return more2;
      if (!more2)
	return -1;
421
    }
422

423
  return cmp;
424 425
}

426
DEFUN ("string-collate-lessp", Fstring_collate_lessp, Sstring_collate_lessp, 2, 4, 0,
Michael Albinus's avatar
Michael Albinus committed
427
       doc: /* Return t if first arg string is less than second in collation order.
428
Symbols are also allowed; their print names are used instead.
Michael Albinus's avatar
Michael Albinus committed
429 430 431

This function obeys the conventions for collation order in your
locale settings.  For example, punctuation and whitespace characters
432
might be considered less significant for sorting:
Michael Albinus's avatar
Michael Albinus committed
433

434
\(sort \\='("11" "12" "1 1" "1 2" "1.1" "1.2") \\='string-collate-lessp)
435
  => ("11" "1 1" "1.1" "12" "1 2" "1.2")
Michael Albinus's avatar
Michael Albinus committed
436

437 438 439
The optional argument LOCALE, a string, overrides the setting of your
current locale identifier for collation.  The value is system
dependent; a LOCALE \"en_US.UTF-8\" is applicable on POSIX systems,
440
while it would be, e.g., \"enu_USA.1252\" on MS-Windows systems.
Michael Albinus's avatar
Michael Albinus committed
441

442 443 444
If IGNORE-CASE is non-nil, characters are converted to lower-case
before comparing them.

445 446 447 448
To emulate Unicode-compliant collation on MS-Windows systems,
bind `w32-collate-ignore-punctuation' to a non-nil value, since
the codeset part of the locale cannot be \"UTF-8\" on MS-Windows.

449 450 451
If your system does not support a locale environment, this function
behaves like `string-lessp'.  */)
  (Lisp_Object s1, Lisp_Object s2, Lisp_Object locale, Lisp_Object ignore_case)
Michael Albinus's avatar
Michael Albinus committed
452
{
453
#if defined __STDC_ISO_10646__ || defined WINDOWSNT
Michael Albinus's avatar
Michael Albinus committed
454 455 456 457 458 459 460
  /* Check parameters.  */
  if (SYMBOLP (s1))
    s1 = SYMBOL_NAME (s1);
  if (SYMBOLP (s2))
    s2 = SYMBOL_NAME (s2);
  CHECK_STRING (s1);
  CHECK_STRING (s2);
461 462
  if (!NILP (locale))
    CHECK_STRING (locale);
Michael Albinus's avatar
Michael Albinus committed
463

464
  return (str_collate (s1, s2, locale, ignore_case) < 0) ? Qt : Qnil;
Michael Albinus's avatar
Michael Albinus committed
465

466
#else  /* !__STDC_ISO_10646__, !WINDOWSNT */
Michael Albinus's avatar
Michael Albinus committed
467
  return Fstring_lessp (s1, s2);
468
#endif /* !__STDC_ISO_10646__, !WINDOWSNT */
Michael Albinus's avatar
Michael Albinus committed
469 470
}

471
DEFUN ("string-collate-equalp", Fstring_collate_equalp, Sstring_collate_equalp, 2, 4, 0,
Michael Albinus's avatar
Michael Albinus committed
472
       doc: /* Return t if two strings have identical contents.
473
Symbols are also allowed; their print names are used instead.
Michael Albinus's avatar
Michael Albinus committed
474 475 476

This function obeys the conventions for collation order in your locale
settings.  For example, characters with different coding points but
477 478
the same meaning might be considered as equal, like different grave
accent Unicode characters:
Michael Albinus's avatar
Michael Albinus committed
479

480
\(string-collate-equalp (string ?\\uFF40) (string ?\\u1FEF))
Michael Albinus's avatar
Michael Albinus committed
481 482
  => t

483 484 485
The optional argument LOCALE, a string, overrides the setting of your
current locale identifier for collation.  The value is system
dependent; a LOCALE \"en_US.UTF-8\" is applicable on POSIX systems,
486
while it would be \"enu_USA.1252\" on MS Windows systems.
Michael Albinus's avatar
Michael Albinus committed
487

488 489 490
If IGNORE-CASE is non-nil, characters are converted to lower-case
before comparing them.

491 492 493 494
To emulate Unicode-compliant collation on MS-Windows systems,
bind `w32-collate-ignore-punctuation' to a non-nil value, since
the codeset part of the locale cannot be \"UTF-8\" on MS-Windows.

495
If your system does not support a locale environment, this function
496 497
behaves like `string-equal'.

498
Do NOT use this function to compare file names for equality.  */)
499
  (Lisp_Object s1, Lisp_Object s2, Lisp_Object locale, Lisp_Object ignore_case)
Michael Albinus's avatar
Michael Albinus committed
500
{
501
#if defined __STDC_ISO_10646__ || defined WINDOWSNT
Michael Albinus's avatar
Michael Albinus committed
502 503 504 505 506 507 508
  /* Check parameters.  */
  if (SYMBOLP (s1))
    s1 = SYMBOL_NAME (s1);
  if (SYMBOLP (s2))
    s2 = SYMBOL_NAME (s2);
  CHECK_STRING (s1);
  CHECK_STRING (s2);
509 510
  if (!NILP (locale))
    CHECK_STRING (locale);
Michael Albinus's avatar
Michael Albinus committed
511

512
  return (str_collate (s1, s2, locale, ignore_case) == 0) ? Qt : Qnil;
Michael Albinus's avatar
Michael Albinus committed
513

514
#else  /* !__STDC_ISO_10646__, !WINDOWSNT */
Michael Albinus's avatar
Michael Albinus committed
515
  return Fstring_equal (s1, s2);
516
#endif /* !__STDC_ISO_10646__, !WINDOWSNT */
Michael Albinus's avatar
Michael Albinus committed
517
}
Jim Blandy's avatar
Jim Blandy committed
518

519
static Lisp_Object concat (ptrdiff_t nargs, Lisp_Object *args,
520
			   enum Lisp_Type target_type, bool last_special);
Jim Blandy's avatar
Jim Blandy committed
521 522

Lisp_Object
523
concat2 (Lisp_Object s1, Lisp_Object s2)
Jim Blandy's avatar
Jim Blandy committed
524
{
525
  return concat (2, ((Lisp_Object []) {s1, s2}), Lisp_String, 0);
Jim Blandy's avatar
Jim Blandy committed
526 527
}

Richard M. Stallman's avatar
Richard M. Stallman committed
528
Lisp_Object
529
concat3 (Lisp_Object s1, Lisp_Object s2, Lisp_Object s3)
Richard M. Stallman's avatar
Richard M. Stallman committed
530
{
531
  return concat (3, ((Lisp_Object []) {s1, s2, s3}), Lisp_String, 0);
Richard M. Stallman's avatar
Richard M. Stallman committed
532 533
}

Paul Eggert's avatar
Paul Eggert committed
534
DEFUN ("append", Fappend, Sappend, 0, MANY, 0,
535
       doc: /* Concatenate all the arguments and make the result a list.
Gerd Moellmann's avatar
Gerd Moellmann committed
536 537
The result is a list whose elements are the elements of all the arguments.
Each argument may be a list, vector or string.
538 539
The last argument is not copied, just used as the tail of the new list.
usage: (append &rest SEQUENCES)  */)
540
  (ptrdiff_t nargs, Lisp_Object *args)
Jim Blandy's avatar
Jim Blandy committed
541 542 543 544
{
  return concat (nargs, args, Lisp_Cons, 1);
}

Paul Eggert's avatar
Paul Eggert committed
545
DEFUN ("concat", Fconcat, Sconcat, 0, MANY, 0,
546
       doc: /* Concatenate all the arguments and make the result a string.
Gerd Moellmann's avatar
Gerd Moellmann committed
547
The result is a string whose elements are the elements of all the arguments.
548 549
Each argument may be a string or a list or vector of characters (integers).
usage: (concat &rest SEQUENCES)  */)
550
  (ptrdiff_t nargs, Lisp_Object *args)
Jim Blandy's avatar
Jim Blandy committed
551 552 553 554
{
  return concat (nargs, args, Lisp_String, 0);
}

Paul Eggert's avatar
Paul Eggert committed
555
DEFUN ("vconcat", Fvconcat, Svconcat, 0, MANY, 0,
556
       doc: /* Concatenate all the arguments and make the result a vector.
Gerd Moellmann's avatar
Gerd Moellmann committed
557
The result is a vector whose elements are the elements of all the arguments.
558 559
Each argument may be a list, vector or string.
usage: (vconcat &rest SEQUENCES)   */)
560
  (ptrdiff_t nargs, Lisp_Object *args)
Jim Blandy's avatar
Jim Blandy committed
561
{
562
  return concat (nargs, args, Lisp_Vectorlike, 0);
Jim Blandy's avatar
Jim Blandy committed
563 564
}

565

Paul Eggert's avatar
Paul Eggert committed
566
DEFUN ("copy-sequence", Fcopy_sequence, Scopy_sequence, 1, 1, 0,
567 568
       doc: /* Return a copy of a list, vector, string, char-table or record.
The elements of a list, vector or record are not copied; they are
569 570 571
shared with the original.
If the original sequence is empty, this function may return
the same empty object instead of its copy.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
572
  (Lisp_Object arg)
Jim Blandy's avatar
Jim Blandy committed
573
{
Jim Blandy's avatar
Jim Blandy committed
574
  if (NILP (arg)) return arg;
575

576 577
  if (RECORDP (arg))
    {
578
      return Frecord (PVSIZE (arg), XVECTOR (arg)->contents);
579 580
    }

581 582
  if (CHAR_TABLE_P (arg))
    {
583
      return copy_char_table (arg);
584 585 586 587
    }

  if (BOOL_VECTOR_P (arg))
    {
588 589 590 591
      EMACS_INT nbits = bool_vector_size (arg);
      ptrdiff_t nbytes = bool_vector_bytes (nbits);
      Lisp_Object val = make_uninit_bool_vector (nbits);
      memcpy (bool_vector_data (val), bool_vector_data (arg), nbytes);
592 593 594
      return val;
    }

595
  if (!CONSP (arg) && !VECTORP (arg) && !STRINGP (arg))
596 597
    wrong_type_argument (Qsequencep, arg);

598
  return concat (1, &arg, XTYPE (arg), 0);
Jim Blandy's avatar
Jim Blandy committed
599 600
}

601 602
/* This structure holds information of an argument of `concat' that is
   a string and has text properties to be copied.  */
Kenichi Handa's avatar
Kenichi Handa committed
603
struct textprop_rec
604
{
605
  ptrdiff_t argnum;		/* refer to ARGS (arguments of `concat') */
606 607
  ptrdiff_t from;		/* refer to ARGS[argnum] (argument string) */
  ptrdiff_t to;			/* refer to VAL (the target string) */
608 609
};

Jim Blandy's avatar
Jim Blandy committed
610
static Lisp_Object
611
concat (ptrdiff_t nargs, Lisp_Object *args,
612
	enum Lisp_Type target_type, bool last_special)
Jim Blandy's avatar
Jim Blandy committed
613 614
{
  Lisp_Object val;
615 616
  Lisp_Object tail;
  Lisp_Object this;
617 618
  ptrdiff_t toindex;
  ptrdiff_t toindex_byte = 0;
619 620
  EMACS_INT result_len;
  EMACS_INT result_len_byte;
621
  ptrdiff_t argnum;
Jim Blandy's avatar
Jim Blandy committed
622 623
  Lisp_Object last_tail;
  Lisp_Object prev;
624
  bool some_multibyte;
625
  /* When we make a multibyte string, we can't copy text properties
Paul Eggert's avatar
Paul Eggert committed
626 627
     while concatenating each string because the length of resulting
     string can't be decided until we finish the whole concatenation.
628
     So, we record strings that have text properties to be copied
Paul Eggert's avatar
Paul Eggert committed
629
     here, and copy the text properties after the concatenation.  */
630
  struct textprop_rec  *textprops = NULL;
Juanma Barranquero's avatar
Juanma Barranquero committed
631
  /* Number of elements in textprops.  */
632
  ptrdiff_t num_textprops = 0;
Kim F. Storm's avatar
Kim F. Storm committed
633
  USE_SAFE_ALLOCA;
Jim Blandy's avatar
Jim Blandy committed
634

635 636
  tail = Qnil;

Jim Blandy's avatar
Jim Blandy committed
637 638 639 640 641 642 643 644 645
  /* In append, the last arg isn't treated like the others */
  if (last_special && nargs > 0)
    {
      nargs--;
      last_tail = args[nargs];
    }
  else
    last_tail = Qnil;

646
  /* Check each argument.  */
Jim Blandy's avatar
Jim Blandy committed
647 648 649
  for (argnum = 0; argnum < nargs; argnum++)
    {
      this = args[argnum];
650
      if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
Stefan Monnier's avatar
Stefan Monnier committed
651
	    || COMPILEDP (this) || BOOL_VECTOR_P (this)))
652
	wrong_type_argument (Qsequencep, this);
Jim Blandy's avatar
Jim Blandy committed
653 654
    }

655 656 657 658 659 660 661 662
  /* Compute total length in chars of arguments in RESULT_LEN.
     If desired output is a string, also compute length in bytes
     in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
     whether the result should be a multibyte string.  */
  result_len_byte = 0;
  result_len = 0;
  some_multibyte = 0;
  for (argnum = 0; argnum < nargs; argnum++)
Jim Blandy's avatar
Jim Blandy committed
663
    {
664
      EMACS_INT len;
Jim Blandy's avatar
Jim Blandy committed
665
      this = args[argnum];
Tom Tromey's avatar
Tom Tromey committed
666
      len = XFIXNAT (Flength (this));
667
      if (target_type == Lisp_String)
668
	{
669 670
	  /* We must count the number of bytes needed in the string
	     as well as the number of characters.  */
671
	  ptrdiff_t i;
672
	  Lisp_Object ch;
673
	  int c;
674
	  ptrdiff_t this_len_byte;
675

Stefan Monnier's avatar
Stefan Monnier committed
676
	  if (VECTORP (this) || COMPILEDP (this))
677
	    for (i = 0; i < len; i++)
678
	      {
Stefan Monnier's avatar
Stefan Monnier committed
679
		ch = AREF (this, i);
Miles Bader's avatar
Miles Bader committed
680
		CHECK_CHARACTER (ch);
Tom Tromey's avatar
Tom Tromey committed
681
		c = XFIXNAT (ch);
682
		this_len_byte = CHAR_BYTES (c);
683 684
		if (STRING_BYTES_BOUND - result_len_byte < this_len_byte)
		  string_overflow ();
685
		result_len_byte += this_len_byte;
686
		if (! ASCII_CHAR_P (c) && ! CHAR_BYTE8_P (c))
687
		  some_multibyte = 1;
688
	      }
689
	  else if (BOOL_VECTOR_P (this) && bool_vector_size (this) > 0)
690
	    wrong_type_argument (Qintegerp, Faref (this, make_fixnum (0)));
691
	  else if (CONSP (this))
692
	    for (; CONSP (this); this = XCDR (this))
693
	      {
694
		ch = XCAR (this);
Miles Bader's avatar
Miles Bader committed
695
		CHECK_CHARACTER (ch);
Tom Tromey's avatar
Tom Tromey committed
696
		c = XFIXNAT (ch);
697
		this_len_byte = CHAR_BYTES (c);
698 699
		if (STRING_BYTES_BOUND - result_len_byte < this_len_byte)
		  string_overflow ();
700
		result_len_byte += this_len_byte;
701
		if (! ASCII_CHAR_P (c) && ! CHAR_BYTE8_P (c))
702
		  some_multibyte = 1;
703
	      }
704
	  else if (STRINGP (this))
705
	    {
706
	      if (STRING_MULTIBYTE (this))
707 708
		{
		  some_multibyte = 1;
709
		  this_len_byte = SBYTES (this);
710 711
		}
	      else
712 713 714 715 716
		this_len_byte = count_size_as_multibyte (SDATA (this),
							 SCHARS (this));
	      if (STRING_BYTES_BOUND - result_len_byte < this_len_byte)
		string_overflow ();
	      result_len_byte += this_len_byte;
717
	    }
718
	}
719 720

      result_len += len;
721 722
      if (MOST_POSITIVE_FIXNUM < result_len)
	memory_full (SIZE_MAX);
Jim Blandy's avatar
Jim Blandy committed
723 724
    }

725 726
  if (! some_multibyte)
    result_len_byte = result_len;
Jim Blandy's avatar
Jim Blandy committed
727

728
  /* Create the output object.  */
Jim Blandy's avatar
Jim Blandy committed
729
  if (target_type == Lisp_Cons)
730
    val = Fmake_list (make_fixnum (result_len), Qnil);
731
  else if (target_type == Lisp_Vectorlike)
732
    val = make_nil_vector (result_len);
733
  else if (some_multibyte)
734
    val = make_uninit_multibyte_string (result_len, result_len_byte);
735 736
  else
    val = make_uninit_string (result_len);
Jim Blandy's avatar
Jim Blandy committed
737

738
  /* In `append', if all but last arg are nil, return last arg.  */
Paul Eggert's avatar
Paul Eggert committed
739
  if (target_type == Lisp_Cons && NILP (val))
740
    return last_tail;
Jim Blandy's avatar
Jim Blandy committed
741

742
  /* Copy the contents of the args into the result.  */
Jim Blandy's avatar
Jim Blandy committed
743
  if (CONSP (val))
744
    tail = val, toindex = -1; /* -1 in toindex is flag we are making a list */
Jim Blandy's avatar
Jim Blandy committed
745
  else
746
    toindex = 0, toindex_byte = 0;
Jim Blandy's avatar
Jim Blandy committed
747 748

  prev = Qnil;
749
  if (STRINGP (val))
750
    SAFE_NALLOCA (textprops, 1, nargs);
Jim Blandy's avatar
Jim Blandy committed
751 752 753 754

  for (argnum = 0; argnum < nargs; argnum++)
    {
      Lisp_Object thislen;
755
      ptrdiff_t thisleni = 0;
756 757
      ptrdiff_t thisindex = 0;
      ptrdiff_t thisindex_byte = 0;
Jim Blandy's avatar
Jim Blandy committed
758 759 760

      this = args[argnum];
      if (!CONSP (this))
Tom Tromey's avatar
Tom Tromey committed
761
	thislen = Flength (this), thisleni = XFIXNUM (thislen);
Jim Blandy's avatar
Jim Blandy committed
762

763 764 765
      /* Between strings of the same kind, copy fast.  */
      if (STRINGP (this) && STRINGP (val)
	  && STRING_MULTIBYTE (this) == some_multibyte)
Jim Blandy's avatar
Jim Blandy committed
766
	{
767
	  ptrdiff_t thislen_byte = SBYTES (this);
768

769
	  memcpy (SDATA (val) + toindex_byte, SDATA (this), SBYTES (this));
770
	  if (string_intervals (this))
771
	    {
Kenichi Handa's avatar
Kenichi Handa committed
772
	      textprops[num_textprops].argnum = argnum;
773
	      textprops[num_textprops].from = 0;
Kenichi Handa's avatar
Kenichi Handa committed
774
	      textprops[num_textprops++].to = toindex;
775
	    }
776
	  toindex_byte += thislen_byte;
777
	  toindex += thisleni;
778
	}
779 780 781
      /* Copy a single-byte string to a multibyte string.  */
      else if (STRINGP (this) && STRINGP (val))
	{
782
	  if (string_intervals (this))
783
	    {
Kenichi Handa's avatar
Kenichi Handa committed
784 785 786
	      textprops[num_textprops].argnum = argnum;
	      textprops[num_textprops].from = 0;
	      textprops[num_textprops++].to = toindex;
787
	    }
788 789 790
	  toindex_byte += copy_text (SDATA (this),
				     SDATA (val) + toindex_byte,
				     SCHARS (this), 0, 1);
791 792
	  toindex += thisleni;
	}
793 794 795 796 797 798 799 800 801 802
      else
	/* Copy element by element.  */
	while (1)
	  {
	    register Lisp_Object elt;

	    /* Fetch next element of `this' arg into `elt', or break if
	       `this' is exhausted. */
	    if (NILP (this)) break;
	    if (CONSP (this))
803
	      elt = XCAR (this), this = XCDR (this);
804 805 806
	    else if (thisindex >= thisleni)
	      break;
	    else if (STRINGP (this))
807
	      {
808
		int c;
809
		if (STRING_MULTIBYTE (this))
810 811
		  c = fetch_string_char_advance_no_check (this, &thisindex,
							  &thisindex_byte);
812
		else
813
		  {
814 815 816
		    c = SREF (this, thisindex); thisindex++;
		    if (some_multibyte && !ASCII_CHAR_P (c))
		      c = BYTE8_TO_CHAR (c);
817
		  }
818
		XSETFASTINT (elt, c);
819 820 821
	      }
	    else if (BOOL_VECTOR_P (this))
	      {
822
		elt = bool_vector_ref (this, thisindex);
823
		thisindex++;
824
	      }
825
	    else
826 827 828 829
	      {
		elt = AREF (this, thisindex);
		thisindex++;
	      }
Jim Blandy's avatar
Jim Blandy committed
830

831 832
	    /* Store this element into the result.  */
	    if (toindex < 0)
Jim Blandy's avatar
Jim Blandy committed
833
	      {
834
		XSETCAR (tail, elt);
835
		prev = tail;
836
		tail = XCDR (tail);
Jim Blandy's avatar
Jim Blandy committed
837
	      }
838
	    else if (VECTORP (val))
839 840 841 842
	      {
		ASET (val, toindex, elt);
		toindex++;
	      }
843 844
	    else
	      {
845 846
		int c;
		CHECK_CHARACTER (elt);
Tom Tromey's avatar
Tom Tromey committed
847
		c = XFIXNAT (elt);
848
		if (some_multibyte)
849
		  toindex_byte += CHAR_STRING (c, SDATA (val) + toindex_byte);
850
		else
851
		  SSET (val, toindex_byte++, c);
852
		toindex++;
853 854
	      }
	  }
Jim Blandy's avatar
Jim Blandy committed
855
    }
Jim Blandy's avatar
Jim Blandy committed
856
  if (!NILP (prev))
857
    XSETCDR (prev, last_tail);
Jim Blandy's avatar
Jim Blandy committed
858

Kenichi Handa's avatar
Kenichi Handa committed
859
  if (num_textprops > 0)
860
    {
861
      Lisp_Object props;
862
      ptrdiff_t last_to_end = -1;
863

Kenichi Handa's avatar
Kenichi Handa committed
864
      for (argnum = 0; argnum < num_textprops; argnum++)
865
	{