fns.c 141 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-2016 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 <http://www.gnu.org/licenses/>.  */
Jim Blandy's avatar
Jim Blandy committed
20

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

Andreas Schwab's avatar
Andreas Schwab committed
23
#include <unistd.h>
24
#include <intprops.h>
Paul Eggert's avatar
Paul Eggert committed
25
#include <vla.h>
26

Jim Blandy's avatar
Jim Blandy committed
27
#include "lisp.h"
28
#include "character.h"
29
#include "coding.h"
30
#include "composite.h"
Jim Blandy's avatar
Jim Blandy committed
31
#include "buffer.h"
32
#include "intervals.h"
33
#include "window.h"
Jim Blandy's avatar
Jim Blandy committed
34

Paul Eggert's avatar
Paul Eggert committed
35
static void sort_vector_copy (Lisp_Object, ptrdiff_t,
36
			      Lisp_Object *restrict, Lisp_Object *restrict);
37
static bool internal_equal (Lisp_Object, Lisp_Object, int, bool, Lisp_Object);
38

Paul Eggert's avatar
Paul Eggert committed
39
DEFUN ("identity", Fidentity, Sidentity, 1, 1, 0,
40 41
       doc: /* Return the argument unchanged.  */
       attributes: const)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
42
  (Lisp_Object arg)
Jim Blandy's avatar
Jim Blandy committed
43 44 45 46 47
{
  return arg;
}

DEFUN ("random", Frandom, Srandom, 0, 1, 0,
48
       doc: /* Return a pseudo-random number.
49 50 51
All integers representable in Lisp, i.e. between `most-negative-fixnum'
and `most-positive-fixnum', inclusive, are equally likely.

52
With positive integer LIMIT, return random number in interval [0,LIMIT).
53
With argument t, set the random number seed from the system's entropy
54
pool if available, otherwise from less-random volatile data such as the time.
Glenn Morris's avatar
Glenn Morris committed
55 56 57 58
With a string argument, set the seed based on the string's contents.
Other values of LIMIT are ignored.

See Info node `(elisp)Random Numbers' for more details.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
59
  (Lisp_Object limit)
Jim Blandy's avatar
Jim Blandy committed
60
{
61
  EMACS_INT val;
Jim Blandy's avatar
Jim Blandy committed
62

63
  if (EQ (limit, Qt))
64 65 66
    init_random ();
  else if (STRINGP (limit))
    seed_random (SSDATA (limit), SBYTES (limit));
67

68
  val = get_random ();
69 70 71 72 73 74 75 76 77 78 79
  if (INTEGERP (limit) && 0 < XINT (limit))
    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.  */
	EMACS_INT remainder = val % XINT (limit);
	if (val - remainder <= INTMASK - XINT (limit) + 1)
	  return make_number (remainder);
	val = get_random ();
      }
80
  return make_number (val);
Jim Blandy's avatar
Jim Blandy committed
81 82
}

83 84 85 86
/* Heuristic on how many iterations of a tight loop can be safely done
   before it's time to do a QUIT.  This must be a power of 2.  */
enum { QUIT_COUNT_HEURISTIC = 1 << 16 };

87
/* Random data-structure functions.  */
Jim Blandy's avatar
Jim Blandy committed
88

89 90 91 92 93 94
static void
CHECK_LIST_END (Lisp_Object x, Lisp_Object y)
{
  CHECK_TYPE (NILP (x), Qlistp, y);
}

Paul Eggert's avatar
Paul Eggert committed
95
DEFUN ("length", Flength, Slength, 1, 1, 0,
96
       doc: /* Return the length of vector, list or string SEQUENCE.
Gerd Moellmann's avatar
Gerd Moellmann committed
97
A byte-code function object is also allowed.
John Paul Wallington's avatar
John Paul Wallington committed
98
If the string contains multibyte characters, this is not necessarily
Gerd Moellmann's avatar
Gerd Moellmann committed
99
the number of bytes in the string; it is the number of characters.
100
To get the number of bytes, use `string-bytes'.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
101
  (register Lisp_Object sequence)
Jim Blandy's avatar
Jim Blandy committed
102
{
103
  register Lisp_Object val;
Jim Blandy's avatar
Jim Blandy committed
104

105
  if (STRINGP (sequence))
106
    XSETFASTINT (val, SCHARS (sequence));
107
  else if (VECTORP (sequence))
Stefan Monnier's avatar
Stefan Monnier committed
108
    XSETFASTINT (val, ASIZE (sequence));
109
  else if (CHAR_TABLE_P (sequence))
110
    XSETFASTINT (val, MAX_CHAR);
111
  else if (BOOL_VECTOR_P (sequence))
112
    XSETFASTINT (val, bool_vector_size (sequence));
Stefan Monnier's avatar
Stefan Monnier committed
113 114
  else if (COMPILEDP (sequence))
    XSETFASTINT (val, ASIZE (sequence) & PSEUDOVECTOR_SIZE_MASK);
115
  else if (CONSP (sequence))
Jim Blandy's avatar
Jim Blandy committed
116
    {
117 118 119
      EMACS_INT i = 0;

      do
Jim Blandy's avatar
Jim Blandy committed
120
	{
121
	  ++i;
122
	  if ((i & (QUIT_COUNT_HEURISTIC - 1)) == 0)
123 124 125 126 127
	    {
	      if (MOST_POSITIVE_FIXNUM < i)
		error ("List too long");
	      QUIT;
	    }
128
	  sequence = XCDR (sequence);
Jim Blandy's avatar
Jim Blandy committed
129
	}
130
      while (CONSP (sequence));
Jim Blandy's avatar
Jim Blandy committed
131

132
      CHECK_LIST_END (sequence, sequence);
133 134

      val = make_number (i);
Jim Blandy's avatar
Jim Blandy committed
135
    }
136
  else if (NILP (sequence))
137
    XSETFASTINT (val, 0);
Jim Blandy's avatar
Jim Blandy committed
138
  else
139
    wrong_type_argument (Qsequencep, sequence);
140

141
  return val;
Jim Blandy's avatar
Jim Blandy committed
142 143
}

144
DEFUN ("safe-length", Fsafe_length, Ssafe_length, 1, 1, 0,
145
       doc: /* Return the length of a list, but avoid error or infinite loop.
Gerd Moellmann's avatar
Gerd Moellmann committed
146 147
This function never gets an error.  If LIST is not really a list,
it returns 0.  If LIST is circular, it returns a finite value
148
which is at least the number of distinct elements.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
149
  (Lisp_Object list)
150
{
151 152 153 154 155
  Lisp_Object tail, halftail;
  double hilen = 0;
  uintmax_t lolen = 1;

  if (! CONSP (list))
156
    return make_number (0);
157 158

  /* halftail is used to detect circular lists.  */
159
  for (tail = halftail = list; ; )
160
    {
161 162
      tail = XCDR (tail);
      if (! CONSP (tail))
163
	break;
164 165 166 167 168 169 170 171 172 173 174 175 176
      if (EQ (tail, halftail))
	break;
      lolen++;
      if ((lolen & 1) == 0)
	{
	  halftail = XCDR (halftail);
	  if ((lolen & (QUIT_COUNT_HEURISTIC - 1)) == 0)
	    {
	      QUIT;
	      if (lolen == 0)
		hilen += UINTMAX_MAX + 1.0;
	    }
	}
177 178
    }

179 180 181 182
  /* If the length does not fit into a fixnum, return a float.
     On all known practical machines this returns an upper bound on
     the true length.  */
  return hilen ? make_float (hilen + lolen) : make_fixnum_or_float (lolen);
183 184
}

185
DEFUN ("string-bytes", Fstring_bytes, Sstring_bytes, 1, 1, 0,
186
       doc: /* Return the number of bytes in STRING.
Miles Bader's avatar
Miles Bader committed
187
If STRING is multibyte, this may be greater than the length of STRING.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
188
  (Lisp_Object string)
189
{
190
  CHECK_STRING (string);
191
  return make_number (SBYTES (string));
192 193
}

Paul Eggert's avatar
Paul Eggert committed
194
DEFUN ("string-equal", Fstring_equal, Sstring_equal, 2, 2, 0,
195
       doc: /* Return t if two strings have identical contents.
Gerd Moellmann's avatar
Gerd Moellmann committed
196
Case is significant, but text properties are ignored.
197
Symbols are also allowed; their print names are used instead.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
198
  (register Lisp_Object s1, Lisp_Object s2)
Jim Blandy's avatar
Jim Blandy committed
199
{
200
  if (SYMBOLP (s1))
201
    s1 = SYMBOL_NAME (s1);
202
  if (SYMBOLP (s2))
203
    s2 = SYMBOL_NAME (s2);
204 205
  CHECK_STRING (s1);
  CHECK_STRING (s2);
Jim Blandy's avatar
Jim Blandy committed
206

207 208
  if (SCHARS (s1) != SCHARS (s2)
      || SBYTES (s1) != SBYTES (s2)
209
      || memcmp (SDATA (s1), SDATA (s2), SBYTES (s1)))
Jim Blandy's avatar
Jim Blandy committed
210 211 212 213
    return Qnil;
  return Qt;
}

Paul Eggert's avatar
Paul Eggert committed
214
DEFUN ("compare-strings", Fcompare_strings, Scompare_strings, 6, 7, 0,
Juanma Barranquero's avatar
Juanma Barranquero committed
215
       doc: /* Compare the contents of two strings, converting to multibyte if needed.
216 217 218
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
219
\(exclusive).  If START1 is nil, it defaults to 0, the beginning of
220 221
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.
222
Like in `substring', negative values are counted from the end.
223 224 225 226

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,
227
characters are converted to upper-case before comparing them.  Unibyte
228
strings are converted to multibyte for comparison.
Gerd Moellmann's avatar
Gerd Moellmann committed
229 230 231 232 233

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;
234
  N - 1 is the number of characters that match at the beginning.  */)
235 236
  (Lisp_Object str1, Lisp_Object start1, Lisp_Object end1, Lisp_Object str2,
   Lisp_Object start2, Lisp_Object end2, Lisp_Object ignore_case)
237
{
238
  ptrdiff_t from1, to1, from2, to2, i1, i1_byte, i2, i2_byte;
239

240 241
  CHECK_STRING (str1);
  CHECK_STRING (str2);
242

243 244 245 246 247 248 249
  /* For backward compatibility, silently bring too-large positive end
     values into range.  */
  if (INTEGERP (end1) && SCHARS (str1) < XINT (end1))
    end1 = make_number (SCHARS (str1));
  if (INTEGERP (end2) && SCHARS (str2) < XINT (end2))
    end2 = make_number (SCHARS (str2));

250 251 252 253 254
  validate_subarray (str1, start1, end1, SCHARS (str1), &from1, &to1);
  validate_subarray (str2, start2, end2, SCHARS (str2), &from2, &to2);

  i1 = from1;
  i2 = from2;
255 256 257

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

259
  while (i1 < to1 && i2 < to2)
260 261 262 263 264
    {
      /* When we find a mismatch, we must compare the
	 characters, not just the bytes.  */
      int c1, c2;

265 266
      FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c1, str1, i1, i1_byte);
      FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c2, str2, i2, i2_byte);
267 268 269 270 271 272

      if (c1 == c2)
	continue;

      if (! NILP (ignore_case))
	{
273 274
	  c1 = XINT (Fupcase (make_number (c1)));
	  c2 = XINT (Fupcase (make_number (c2)));
275 276 277 278 279 280 281 282 283
	}

      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)
284
	return make_number (- i1 + from1);
285
      else
286
	return make_number (i1 - from1);
287 288
    }

289 290 291 292
  if (i1 < to1)
    return make_number (i1 - from1 + 1);
  if (i2 < to2)
    return make_number (- i1 + from1 - 1);
293 294 295 296

  return Qt;
}

Paul Eggert's avatar
Paul Eggert committed
297
DEFUN ("string-lessp", Fstring_lessp, Sstring_lessp, 2, 2, 0,
298
       doc: /* Return non-nil if STRING1 is less than STRING2 in lexicographic order.
Gerd Moellmann's avatar
Gerd Moellmann committed
299
Case is significant.
300
Symbols are also allowed; their print names are used instead.  */)
301
  (register Lisp_Object string1, Lisp_Object string2)
Jim Blandy's avatar
Jim Blandy committed
302
{
303 304
  register ptrdiff_t end;
  register ptrdiff_t i1, i1_byte, i2, i2_byte;
Jim Blandy's avatar
Jim Blandy committed
305

306 307 308 309 310 311
  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
312

313 314
  i1 = i1_byte = i2 = i2_byte = 0;

315 316 317
  end = SCHARS (string1);
  if (end > SCHARS (string2))
    end = SCHARS (string2);
Jim Blandy's avatar
Jim Blandy committed
318

319
  while (i1 < end)
Jim Blandy's avatar
Jim Blandy committed
320
    {
321 322 323 324
      /* When we find a mismatch, we must compare the
	 characters, not just the bytes.  */
      int c1, c2;

325 326
      FETCH_STRING_CHAR_ADVANCE (c1, string1, i1, i1_byte);
      FETCH_STRING_CHAR_ADVANCE (c2, string2, i2, i2_byte);
327 328 329

      if (c1 != c2)
	return c1 < c2 ? Qt : Qnil;
Jim Blandy's avatar
Jim Blandy committed
330
    }
331
  return i1 < SCHARS (string2) ? Qt : Qnil;
Jim Blandy's avatar
Jim Blandy committed
332
}
Michael Albinus's avatar
Michael Albinus committed
333

334
DEFUN ("string-collate-lessp", Fstring_collate_lessp, Sstring_collate_lessp, 2, 4, 0,
Michael Albinus's avatar
Michael Albinus committed
335
       doc: /* Return t if first arg string is less than second in collation order.
336
Symbols are also allowed; their print names are used instead.
Michael Albinus's avatar
Michael Albinus committed
337 338 339

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

342
\(sort \\='("11" "12" "1 1" "1 2" "1.1" "1.2") \\='string-collate-lessp)
343
  => ("11" "1 1" "1.1" "12" "1 2" "1.2")
Michael Albinus's avatar
Michael Albinus committed
344

345 346 347
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,
348
while it would be, e.g., \"enu_USA.1252\" on MS-Windows systems.
Michael Albinus's avatar
Michael Albinus committed
349

350 351 352
If IGNORE-CASE is non-nil, characters are converted to lower-case
before comparing them.

353 354 355 356
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.

357 358 359
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
360
{
361
#if defined __STDC_ISO_10646__ || defined WINDOWSNT
Michael Albinus's avatar
Michael Albinus committed
362 363 364 365 366 367 368
  /* Check parameters.  */
  if (SYMBOLP (s1))
    s1 = SYMBOL_NAME (s1);
  if (SYMBOLP (s2))
    s2 = SYMBOL_NAME (s2);
  CHECK_STRING (s1);
  CHECK_STRING (s2);
369 370
  if (!NILP (locale))
    CHECK_STRING (locale);
Michael Albinus's avatar
Michael Albinus committed
371

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

374
#else  /* !__STDC_ISO_10646__, !WINDOWSNT */
Michael Albinus's avatar
Michael Albinus committed
375
  return Fstring_lessp (s1, s2);
376
#endif /* !__STDC_ISO_10646__, !WINDOWSNT */
Michael Albinus's avatar
Michael Albinus committed
377 378
}

379
DEFUN ("string-collate-equalp", Fstring_collate_equalp, Sstring_collate_equalp, 2, 4, 0,
Michael Albinus's avatar
Michael Albinus committed
380
       doc: /* Return t if two strings have identical contents.
381
Symbols are also allowed; their print names are used instead.
Michael Albinus's avatar
Michael Albinus committed
382 383 384

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

388
\(string-collate-equalp (string ?\\uFF40) (string ?\\u1FEF))
Michael Albinus's avatar
Michael Albinus committed
389 390
  => t

391 392 393
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,
394
while it would be \"enu_USA.1252\" on MS Windows systems.
Michael Albinus's avatar
Michael Albinus committed
395

396 397 398
If IGNORE-CASE is non-nil, characters are converted to lower-case
before comparing them.

399 400 401 402
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.

403
If your system does not support a locale environment, this function
404 405
behaves like `string-equal'.

406
Do NOT use this function to compare file names for equality.  */)
407
  (Lisp_Object s1, Lisp_Object s2, Lisp_Object locale, Lisp_Object ignore_case)
Michael Albinus's avatar
Michael Albinus committed
408
{
409
#if defined __STDC_ISO_10646__ || defined WINDOWSNT
Michael Albinus's avatar
Michael Albinus committed
410 411 412 413 414 415 416
  /* Check parameters.  */
  if (SYMBOLP (s1))
    s1 = SYMBOL_NAME (s1);
  if (SYMBOLP (s2))
    s2 = SYMBOL_NAME (s2);
  CHECK_STRING (s1);
  CHECK_STRING (s2);
417 418
  if (!NILP (locale))
    CHECK_STRING (locale);
Michael Albinus's avatar
Michael Albinus committed
419

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

422
#else  /* !__STDC_ISO_10646__, !WINDOWSNT */
Michael Albinus's avatar
Michael Albinus committed
423
  return Fstring_equal (s1, s2);
424
#endif /* !__STDC_ISO_10646__, !WINDOWSNT */
Michael Albinus's avatar
Michael Albinus committed
425
}
Jim Blandy's avatar
Jim Blandy committed
426

427
static Lisp_Object concat (ptrdiff_t nargs, Lisp_Object *args,
428
			   enum Lisp_Type target_type, bool last_special);
Jim Blandy's avatar
Jim Blandy committed
429 430 431

/* ARGSUSED */
Lisp_Object
432
concat2 (Lisp_Object s1, Lisp_Object s2)
Jim Blandy's avatar
Jim Blandy committed
433
{
434
  return concat (2, ((Lisp_Object []) {s1, s2}), Lisp_String, 0);
Jim Blandy's avatar
Jim Blandy committed
435 436
}

Richard M. Stallman's avatar
Richard M. Stallman committed
437 438
/* ARGSUSED */
Lisp_Object
439
concat3 (Lisp_Object s1, Lisp_Object s2, Lisp_Object s3)
Richard M. Stallman's avatar
Richard M. Stallman committed
440
{
441
  return concat (3, ((Lisp_Object []) {s1, s2, s3}), Lisp_String, 0);
Richard M. Stallman's avatar
Richard M. Stallman committed
442 443
}

Paul Eggert's avatar
Paul Eggert committed
444
DEFUN ("append", Fappend, Sappend, 0, MANY, 0,
445
       doc: /* Concatenate all the arguments and make the result a list.
Gerd Moellmann's avatar
Gerd Moellmann committed
446 447
The result is a list whose elements are the elements of all the arguments.
Each argument may be a list, vector or string.
448 449
The last argument is not copied, just used as the tail of the new list.
usage: (append &rest SEQUENCES)  */)
450
  (ptrdiff_t nargs, Lisp_Object *args)
Jim Blandy's avatar
Jim Blandy committed
451 452 453 454
{
  return concat (nargs, args, Lisp_Cons, 1);
}

Paul Eggert's avatar
Paul Eggert committed
455
DEFUN ("concat", Fconcat, Sconcat, 0, MANY, 0,
456
       doc: /* Concatenate all the arguments and make the result a string.
Gerd Moellmann's avatar
Gerd Moellmann committed
457
The result is a string whose elements are the elements of all the arguments.
458 459
Each argument may be a string or a list or vector of characters (integers).
usage: (concat &rest SEQUENCES)  */)
460
  (ptrdiff_t nargs, Lisp_Object *args)
Jim Blandy's avatar
Jim Blandy committed
461 462 463 464
{
  return concat (nargs, args, Lisp_String, 0);
}

Paul Eggert's avatar
Paul Eggert committed
465
DEFUN ("vconcat", Fvconcat, Svconcat, 0, MANY, 0,
466
       doc: /* Concatenate all the arguments and make the result a vector.
Gerd Moellmann's avatar
Gerd Moellmann committed
467
The result is a vector whose elements are the elements of all the arguments.
468 469
Each argument may be a list, vector or string.
usage: (vconcat &rest SEQUENCES)   */)
470
  (ptrdiff_t nargs, Lisp_Object *args)
Jim Blandy's avatar
Jim Blandy committed
471
{
472
  return concat (nargs, args, Lisp_Vectorlike, 0);
Jim Blandy's avatar
Jim Blandy committed
473 474
}

475

Paul Eggert's avatar
Paul Eggert committed
476
DEFUN ("copy-sequence", Fcopy_sequence, Scopy_sequence, 1, 1, 0,
Dave Love's avatar
Dave Love committed
477
       doc: /* Return a copy of a list, vector, string or char-table.
Gerd Moellmann's avatar
Gerd Moellmann committed
478
The elements of a list or vector are not copied; they are shared
479
with the original.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
480
  (Lisp_Object arg)
Jim Blandy's avatar
Jim Blandy committed
481
{
Jim Blandy's avatar
Jim Blandy committed
482
  if (NILP (arg)) return arg;
483 484 485

  if (CHAR_TABLE_P (arg))
    {
486
      return copy_char_table (arg);
487 488 489 490
    }

  if (BOOL_VECTOR_P (arg))
    {
491 492 493 494
      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);
495 496 497
      return val;
    }

498
  if (!CONSP (arg) && !VECTORP (arg) && !STRINGP (arg))
499 500
    wrong_type_argument (Qsequencep, arg);

501
  return concat (1, &arg, XTYPE (arg), 0);
Jim Blandy's avatar
Jim Blandy committed
502 503
}

504 505
/* 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
506
struct textprop_rec
507
{
508
  ptrdiff_t argnum;		/* refer to ARGS (arguments of `concat') */
509 510
  ptrdiff_t from;		/* refer to ARGS[argnum] (argument string) */
  ptrdiff_t to;			/* refer to VAL (the target string) */
511 512
};

Jim Blandy's avatar
Jim Blandy committed
513
static Lisp_Object
514
concat (ptrdiff_t nargs, Lisp_Object *args,
515
	enum Lisp_Type target_type, bool last_special)
Jim Blandy's avatar
Jim Blandy committed
516 517
{
  Lisp_Object val;
518 519
  Lisp_Object tail;
  Lisp_Object this;
520 521
  ptrdiff_t toindex;
  ptrdiff_t toindex_byte = 0;
522 523
  EMACS_INT result_len;
  EMACS_INT result_len_byte;
524
  ptrdiff_t argnum;
Jim Blandy's avatar
Jim Blandy committed
525 526
  Lisp_Object last_tail;
  Lisp_Object prev;
527
  bool some_multibyte;
528
  /* When we make a multibyte string, we can't copy text properties
Paul Eggert's avatar
Paul Eggert committed
529 530
     while concatenating each string because the length of resulting
     string can't be decided until we finish the whole concatenation.
531
     So, we record strings that have text properties to be copied
Paul Eggert's avatar
Paul Eggert committed
532
     here, and copy the text properties after the concatenation.  */
533
  struct textprop_rec  *textprops = NULL;
Juanma Barranquero's avatar
Juanma Barranquero committed
534
  /* Number of elements in textprops.  */
535
  ptrdiff_t num_textprops = 0;
Kim F. Storm's avatar
Kim F. Storm committed
536
  USE_SAFE_ALLOCA;
Jim Blandy's avatar
Jim Blandy committed
537

538 539
  tail = Qnil;

Jim Blandy's avatar
Jim Blandy committed
540 541 542 543 544 545 546 547 548
  /* 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;

549
  /* Check each argument.  */
Jim Blandy's avatar
Jim Blandy committed
550 551 552
  for (argnum = 0; argnum < nargs; argnum++)
    {
      this = args[argnum];
553
      if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
Stefan Monnier's avatar
Stefan Monnier committed
554
	    || COMPILEDP (this) || BOOL_VECTOR_P (this)))
555
	wrong_type_argument (Qsequencep, this);
Jim Blandy's avatar
Jim Blandy committed
556 557
    }

558 559 560 561 562 563 564 565
  /* 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
566
    {
567
      EMACS_INT len;
Jim Blandy's avatar
Jim Blandy committed
568
      this = args[argnum];
569 570
      len = XFASTINT (Flength (this));
      if (target_type == Lisp_String)
571
	{
572 573
	  /* We must count the number of bytes needed in the string
	     as well as the number of characters.  */
574
	  ptrdiff_t i;
575
	  Lisp_Object ch;
576
	  int c;
577
	  ptrdiff_t this_len_byte;
578

Stefan Monnier's avatar
Stefan Monnier committed
579
	  if (VECTORP (this) || COMPILEDP (this))
580
	    for (i = 0; i < len; i++)
581
	      {
Stefan Monnier's avatar
Stefan Monnier committed
582
		ch = AREF (this, i);
Miles Bader's avatar
Miles Bader committed
583
		CHECK_CHARACTER (ch);
584 585
		c = XFASTINT (ch);
		this_len_byte = CHAR_BYTES (c);
586 587
		if (STRING_BYTES_BOUND - result_len_byte < this_len_byte)
		  string_overflow ();
588
		result_len_byte += this_len_byte;
589
		if (! ASCII_CHAR_P (c) && ! CHAR_BYTE8_P (c))
590
		  some_multibyte = 1;
591
	      }
592
	  else if (BOOL_VECTOR_P (this) && bool_vector_size (this) > 0)
593
	    wrong_type_argument (Qintegerp, Faref (this, make_number (0)));
594
	  else if (CONSP (this))
595
	    for (; CONSP (this); this = XCDR (this))
596
	      {
597
		ch = XCAR (this);
Miles Bader's avatar
Miles Bader committed
598
		CHECK_CHARACTER (ch);
599 600
		c = XFASTINT (ch);
		this_len_byte = CHAR_BYTES (c);
601 602
		if (STRING_BYTES_BOUND - result_len_byte < this_len_byte)
		  string_overflow ();
603
		result_len_byte += this_len_byte;
604
		if (! ASCII_CHAR_P (c) && ! CHAR_BYTE8_P (c))
605
		  some_multibyte = 1;
606
	      }
607
	  else if (STRINGP (this))
608
	    {
609
	      if (STRING_MULTIBYTE (this))
610 611
		{
		  some_multibyte = 1;
612
		  this_len_byte = SBYTES (this);
613 614
		}
	      else
615 616 617 618 619
		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;
620
	    }
621
	}
622 623

      result_len += len;
624 625
      if (MOST_POSITIVE_FIXNUM < result_len)
	memory_full (SIZE_MAX);
Jim Blandy's avatar
Jim Blandy committed
626 627
    }

628 629
  if (! some_multibyte)
    result_len_byte = result_len;
Jim Blandy's avatar
Jim Blandy committed
630

631
  /* Create the output object.  */
Jim Blandy's avatar
Jim Blandy committed
632
  if (target_type == Lisp_Cons)
633
    val = Fmake_list (make_number (result_len), Qnil);
634
  else if (target_type == Lisp_Vectorlike)
635
    val = Fmake_vector (make_number (result_len), Qnil);
636
  else if (some_multibyte)
637
    val = make_uninit_multibyte_string (result_len, result_len_byte);
638 639
  else
    val = make_uninit_string (result_len);
Jim Blandy's avatar
Jim Blandy committed
640

641 642 643
  /* In `append', if all but last arg are nil, return last arg.  */
  if (target_type == Lisp_Cons && EQ (val, Qnil))
    return last_tail;
Jim Blandy's avatar
Jim Blandy committed
644

645
  /* Copy the contents of the args into the result.  */
Jim Blandy's avatar
Jim Blandy committed
646
  if (CONSP (val))
647
    tail = val, toindex = -1; /* -1 in toindex is flag we are making a list */
Jim Blandy's avatar
Jim Blandy committed
648
  else
649
    toindex = 0, toindex_byte = 0;
Jim Blandy's avatar
Jim Blandy committed
650 651

  prev = Qnil;
652
  if (STRINGP (val))
653
    SAFE_NALLOCA (textprops, 1, nargs);
Jim Blandy's avatar
Jim Blandy committed
654 655 656 657

  for (argnum = 0; argnum < nargs; argnum++)
    {
      Lisp_Object thislen;
658 659 660
      ptrdiff_t thisleni = 0;
      register ptrdiff_t thisindex = 0;
      register ptrdiff_t thisindex_byte = 0;
Jim Blandy's avatar
Jim Blandy committed
661 662 663 664 665

      this = args[argnum];
      if (!CONSP (this))
	thislen = Flength (this), thisleni = XINT (thislen);

666 667 668
      /* 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
669
	{
670
	  ptrdiff_t thislen_byte = SBYTES (this);
671

672
	  memcpy (SDATA (val) + toindex_byte, SDATA (this), SBYTES (this));
673
	  if (string_intervals (this))
674
	    {
Kenichi Handa's avatar
Kenichi Handa committed
675
	      textprops[num_textprops].argnum = argnum;
676
	      textprops[num_textprops].from = 0;
Kenichi Handa's avatar
Kenichi Handa committed
677
	      textprops[num_textprops++].to = toindex;
678
	    }
679
	  toindex_byte += thislen_byte;
680
	  toindex += thisleni;
681
	}
682 683 684
      /* Copy a single-byte string to a multibyte string.  */
      else if (STRINGP (this) && STRINGP (val))
	{
685
	  if (string_intervals (this))
686
	    {
Kenichi Handa's avatar
Kenichi Handa committed
687 688 689
	      textprops[num_textprops].argnum = argnum;
	      textprops[num_textprops].from = 0;
	      textprops[num_textprops++].to = toindex;
690
	    }
691 692 693
	  toindex_byte += copy_text (SDATA (this),
				     SDATA (val) + toindex_byte,
				     SCHARS (this), 0, 1);
694 695
	  toindex += thisleni;
	}
696 697 698 699 700 701 702 703 704 705
      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))
706
	      elt = XCAR (this), this = XCDR (this);
707 708 709
	    else if (thisindex >= thisleni)
	      break;
	    else if (STRINGP (this))
710
	      {
711
		int c;
712
		if (STRING_MULTIBYTE (this))
713 714 715
		  FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c, this,
						      thisindex,
						      thisindex_byte);
716
		else
717
		  {
718 719 720
		    c = SREF (this, thisindex); thisindex++;
		    if (some_multibyte && !ASCII_CHAR_P (c))
		      c = BYTE8_TO_CHAR (c);
721
		  }
722
		XSETFASTINT (elt, c);
723 724 725
	      }
	    else if (BOOL_VECTOR_P (this))
	      {
726
		elt = bool_vector_ref (this, thisindex);
727
		thisindex++;
728
	      }
729
	    else
730 731 732 733
	      {
		elt = AREF (this, thisindex);
		thisindex++;
	      }
Jim Blandy's avatar
Jim Blandy committed
734

735 736
	    /* Store this element into the result.  */
	    if (toindex < 0)
Jim Blandy's avatar
Jim Blandy committed
737
	      {
738
		XSETCAR (tail, elt);