fns.c 143 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-2015 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>
Andreas Schwab's avatar
Andreas Schwab committed
24
#include <time.h>
Andreas Schwab's avatar
Andreas Schwab committed
25

26
#include <intprops.h>
Paul Eggert's avatar
Paul Eggert committed
27
#include <vla.h>
28

Jim Blandy's avatar
Jim Blandy committed
29 30
#include "lisp.h"
#include "commands.h"
31
#include "character.h"
32
#include "coding.h"
Jim Blandy's avatar
Jim Blandy committed
33
#include "buffer.h"
Jim Blandy's avatar
Jim Blandy committed
34
#include "keyboard.h"
Stefan Monnier's avatar
Stefan Monnier committed
35
#include "keymap.h"
36
#include "intervals.h"
37 38
#include "frame.h"
#include "window.h"
Gerd Moellmann's avatar
Gerd Moellmann committed
39
#include "blockinput.h"
40
#if defined (HAVE_X_WINDOWS)
Andreas Schwab's avatar
Andreas Schwab committed
41 42
#include "xterm.h"
#endif
Jim Blandy's avatar
Jim Blandy committed
43

Paul Eggert's avatar
Paul Eggert committed
44 45
static void sort_vector_copy (Lisp_Object, ptrdiff_t,
			      Lisp_Object [restrict], Lisp_Object [restrict]);
46
static bool internal_equal (Lisp_Object, Lisp_Object, int, bool, Lisp_Object);
47

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

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

61 62
With positive integer LIMIT, return random number in interval [0,LIMIT).
With argument t, set the random number seed from the current time and pid.
Glenn Morris's avatar
Glenn Morris committed
63 64 65 66
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
67
  (Lisp_Object limit)
Jim Blandy's avatar
Jim Blandy committed
68
{
69
  EMACS_INT val;
Jim Blandy's avatar
Jim Blandy committed
70

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

76
  val = get_random ();
77 78 79 80 81 82 83 84 85 86 87
  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 ();
      }
88
  return make_number (val);
Jim Blandy's avatar
Jim Blandy committed
89 90
}

91 92 93 94
/* 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 };

95
/* Random data-structure functions.  */
Jim Blandy's avatar
Jim Blandy committed
96

97 98 99 100 101 102
static void
CHECK_LIST_END (Lisp_Object x, Lisp_Object y)
{
  CHECK_TYPE (NILP (x), Qlistp, y);
}

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

113
  if (STRINGP (sequence))
114
    XSETFASTINT (val, SCHARS (sequence));
115
  else if (VECTORP (sequence))
Stefan Monnier's avatar
Stefan Monnier committed
116
    XSETFASTINT (val, ASIZE (sequence));
117
  else if (CHAR_TABLE_P (sequence))
118
    XSETFASTINT (val, MAX_CHAR);
119
  else if (BOOL_VECTOR_P (sequence))
120
    XSETFASTINT (val, bool_vector_size (sequence));
Stefan Monnier's avatar
Stefan Monnier committed
121 122
  else if (COMPILEDP (sequence))
    XSETFASTINT (val, ASIZE (sequence) & PSEUDOVECTOR_SIZE_MASK);
123
  else if (CONSP (sequence))
Jim Blandy's avatar
Jim Blandy committed
124
    {
125 126 127
      EMACS_INT i = 0;

      do
Jim Blandy's avatar
Jim Blandy committed
128
	{
129
	  ++i;
130
	  if ((i & (QUIT_COUNT_HEURISTIC - 1)) == 0)
131 132 133 134 135
	    {
	      if (MOST_POSITIVE_FIXNUM < i)
		error ("List too long");
	      QUIT;
	    }
136
	  sequence = XCDR (sequence);
Jim Blandy's avatar
Jim Blandy committed
137
	}
138
      while (CONSP (sequence));
Jim Blandy's avatar
Jim Blandy committed
139

140
      CHECK_LIST_END (sequence, sequence);
141 142

      val = make_number (i);
Jim Blandy's avatar
Jim Blandy committed
143
    }
144
  else if (NILP (sequence))
145
    XSETFASTINT (val, 0);
Jim Blandy's avatar
Jim Blandy committed
146
  else
147
    wrong_type_argument (Qsequencep, sequence);
148

149
  return val;
Jim Blandy's avatar
Jim Blandy committed
150 151
}

152
DEFUN ("safe-length", Fsafe_length, Ssafe_length, 1, 1, 0,
153
       doc: /* Return the length of a list, but avoid error or infinite loop.
Gerd Moellmann's avatar
Gerd Moellmann committed
154 155
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
156
which is at least the number of distinct elements.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
157
  (Lisp_Object list)
158
{
159 160 161 162 163
  Lisp_Object tail, halftail;
  double hilen = 0;
  uintmax_t lolen = 1;

  if (! CONSP (list))
164
    return make_number (0);
165 166

  /* halftail is used to detect circular lists.  */
167
  for (tail = halftail = list; ; )
168
    {
169 170
      tail = XCDR (tail);
      if (! CONSP (tail))
171
	break;
172 173 174 175 176 177 178 179 180 181 182 183 184
      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;
	    }
	}
185 186
    }

187 188 189 190
  /* 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);
191 192
}

193
DEFUN ("string-bytes", Fstring_bytes, Sstring_bytes, 1, 1, 0,
194
       doc: /* Return the number of bytes in STRING.
Miles Bader's avatar
Miles Bader committed
195
If STRING is multibyte, this may be greater than the length of STRING.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
196
  (Lisp_Object string)
197
{
198
  CHECK_STRING (string);
199
  return make_number (SBYTES (string));
200 201
}

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

215 216
  if (SCHARS (s1) != SCHARS (s2)
      || SBYTES (s1) != SBYTES (s2)
217
      || memcmp (SDATA (s1), SDATA (s2), SBYTES (s1)))
Jim Blandy's avatar
Jim Blandy committed
218 219 220 221
    return Qnil;
  return Qt;
}

Paul Eggert's avatar
Paul Eggert committed
222
DEFUN ("compare-strings", Fcompare_strings, Scompare_strings, 6, 7, 0,
Juanma Barranquero's avatar
Juanma Barranquero committed
223
       doc: /* Compare the contents of two strings, converting to multibyte if needed.
224 225 226 227 228 229
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
\(exclusive).  If START1 is nil, it defaults to 0, the beginning of
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.
230
Like in `substring', negative values are counted from the end.
231 232 233 234 235 236

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,
characters are converted to lower-case before comparing them.  Unibyte
strings are converted to multibyte for comparison.
Gerd Moellmann's avatar
Gerd Moellmann committed
237 238 239 240 241

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;
242
  N - 1 is the number of characters that match at the beginning.  */)
243 244
  (Lisp_Object str1, Lisp_Object start1, Lisp_Object end1, Lisp_Object str2,
   Lisp_Object start2, Lisp_Object end2, Lisp_Object ignore_case)
245
{
246
  ptrdiff_t from1, to1, from2, to2, i1, i1_byte, i2, i2_byte;
247

248 249
  CHECK_STRING (str1);
  CHECK_STRING (str2);
250

251 252 253 254 255 256 257
  /* 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));

258 259 260 261 262
  validate_subarray (str1, start1, end1, SCHARS (str1), &from1, &to1);
  validate_subarray (str2, start2, end2, SCHARS (str2), &from2, &to2);

  i1 = from1;
  i2 = from2;
263 264 265

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

267
  while (i1 < to1 && i2 < to2)
268 269 270 271 272
    {
      /* When we find a mismatch, we must compare the
	 characters, not just the bytes.  */
      int c1, c2;

273 274
      FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c1, str1, i1, i1_byte);
      FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c2, str2, i2, i2_byte);
275 276 277 278 279 280

      if (c1 == c2)
	continue;

      if (! NILP (ignore_case))
	{
281 282
	  c1 = XINT (Fupcase (make_number (c1)));
	  c2 = XINT (Fupcase (make_number (c2)));
283 284 285 286 287 288 289 290 291
	}

      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)
292
	return make_number (- i1 + from1);
293
      else
294
	return make_number (i1 - from1);
295 296
    }

297 298 299 300
  if (i1 < to1)
    return make_number (i1 - from1 + 1);
  if (i2 < to2)
    return make_number (- i1 + from1 - 1);
301 302 303 304

  return Qt;
}

Paul Eggert's avatar
Paul Eggert committed
305
DEFUN ("string-lessp", Fstring_lessp, Sstring_lessp, 2, 2, 0,
306
       doc: /* Return t if first arg string is less than second in lexicographic order.
Gerd Moellmann's avatar
Gerd Moellmann committed
307
Case is significant.
308
Symbols are also allowed; their print names are used instead.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
309
  (register Lisp_Object s1, Lisp_Object s2)
Jim Blandy's avatar
Jim Blandy committed
310
{
311 312
  register ptrdiff_t end;
  register ptrdiff_t i1, i1_byte, i2, i2_byte;
Jim Blandy's avatar
Jim Blandy committed
313

314
  if (SYMBOLP (s1))
315
    s1 = SYMBOL_NAME (s1);
316
  if (SYMBOLP (s2))
317
    s2 = SYMBOL_NAME (s2);
318 319
  CHECK_STRING (s1);
  CHECK_STRING (s2);
Jim Blandy's avatar
Jim Blandy committed
320

321 322
  i1 = i1_byte = i2 = i2_byte = 0;

323 324 325
  end = SCHARS (s1);
  if (end > SCHARS (s2))
    end = SCHARS (s2);
Jim Blandy's avatar
Jim Blandy committed
326

327
  while (i1 < end)
Jim Blandy's avatar
Jim Blandy committed
328
    {
329 330 331 332
      /* When we find a mismatch, we must compare the
	 characters, not just the bytes.  */
      int c1, c2;

333 334
      FETCH_STRING_CHAR_ADVANCE (c1, s1, i1, i1_byte);
      FETCH_STRING_CHAR_ADVANCE (c2, s2, i2, i2_byte);
335 336 337

      if (c1 != c2)
	return c1 < c2 ? Qt : Qnil;
Jim Blandy's avatar
Jim Blandy committed
338
    }
339
  return i1 < SCHARS (s2) ? Qt : Qnil;
Jim Blandy's avatar
Jim Blandy committed
340
}
Michael Albinus's avatar
Michael Albinus committed
341

342
DEFUN ("string-collate-lessp", Fstring_collate_lessp, Sstring_collate_lessp, 2, 4, 0,
Michael Albinus's avatar
Michael Albinus committed
343
       doc: /* Return t if first arg string is less than second in collation order.
344
Symbols are also allowed; their print names are used instead.
Michael Albinus's avatar
Michael Albinus committed
345 346 347

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

\(sort '\("11" "12" "1 1" "1 2" "1.1" "1.2") 'string-collate-lessp)
  => \("11" "1 1" "1.1" "12" "1 2" "1.2")

353 354 355
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,
356
while it would be, e.g., \"enu_USA.1252\" on MS-Windows systems.
Michael Albinus's avatar
Michael Albinus committed
357

358 359 360
If IGNORE-CASE is non-nil, characters are converted to lower-case
before comparing them.

361 362 363 364
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.

365 366 367
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
368
{
369
#if defined __STDC_ISO_10646__ || defined WINDOWSNT
Michael Albinus's avatar
Michael Albinus committed
370 371 372 373 374 375 376
  /* Check parameters.  */
  if (SYMBOLP (s1))
    s1 = SYMBOL_NAME (s1);
  if (SYMBOLP (s2))
    s2 = SYMBOL_NAME (s2);
  CHECK_STRING (s1);
  CHECK_STRING (s2);
377 378
  if (!NILP (locale))
    CHECK_STRING (locale);
Michael Albinus's avatar
Michael Albinus committed
379

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

382
#else  /* !__STDC_ISO_10646__, !WINDOWSNT */
Michael Albinus's avatar
Michael Albinus committed
383
  return Fstring_lessp (s1, s2);
384
#endif /* !__STDC_ISO_10646__, !WINDOWSNT */
Michael Albinus's avatar
Michael Albinus committed
385 386
}

387
DEFUN ("string-collate-equalp", Fstring_collate_equalp, Sstring_collate_equalp, 2, 4, 0,
Michael Albinus's avatar
Michael Albinus committed
388
       doc: /* Return t if two strings have identical contents.
389
Symbols are also allowed; their print names are used instead.
Michael Albinus's avatar
Michael Albinus committed
390 391 392

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

\(string-collate-equalp \(string ?\\uFF40) \(string ?\\u1FEF))
  => t

399 400 401
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,
402
while it would be \"enu_USA.1252\" on MS Windows systems.
Michael Albinus's avatar
Michael Albinus committed
403

404 405 406
If IGNORE-CASE is non-nil, characters are converted to lower-case
before comparing them.

407 408 409 410
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.

411
If your system does not support a locale environment, this function
412 413 414 415
behaves like `string-equal'.

Do NOT use this function to compare file names for equality, only
for sorting them.  */)
416
  (Lisp_Object s1, Lisp_Object s2, Lisp_Object locale, Lisp_Object ignore_case)
Michael Albinus's avatar
Michael Albinus committed
417
{
418
#if defined __STDC_ISO_10646__ || defined WINDOWSNT
Michael Albinus's avatar
Michael Albinus committed
419 420 421 422 423 424 425
  /* Check parameters.  */
  if (SYMBOLP (s1))
    s1 = SYMBOL_NAME (s1);
  if (SYMBOLP (s2))
    s2 = SYMBOL_NAME (s2);
  CHECK_STRING (s1);
  CHECK_STRING (s2);
426 427
  if (!NILP (locale))
    CHECK_STRING (locale);
Michael Albinus's avatar
Michael Albinus committed
428

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

431
#else  /* !__STDC_ISO_10646__, !WINDOWSNT */
Michael Albinus's avatar
Michael Albinus committed
432
  return Fstring_equal (s1, s2);
433
#endif /* !__STDC_ISO_10646__, !WINDOWSNT */
Michael Albinus's avatar
Michael Albinus committed
434
}
Jim Blandy's avatar
Jim Blandy committed
435

436
static Lisp_Object concat (ptrdiff_t nargs, Lisp_Object *args,
437
			   enum Lisp_Type target_type, bool last_special);
Jim Blandy's avatar
Jim Blandy committed
438 439 440

/* ARGSUSED */
Lisp_Object
441
concat2 (Lisp_Object s1, Lisp_Object s2)
Jim Blandy's avatar
Jim Blandy committed
442 443 444 445 446 447 448
{
  Lisp_Object args[2];
  args[0] = s1;
  args[1] = s2;
  return concat (2, args, Lisp_String, 0);
}

Richard M. Stallman's avatar
Richard M. Stallman committed
449 450
/* ARGSUSED */
Lisp_Object
451
concat3 (Lisp_Object s1, Lisp_Object s2, Lisp_Object s3)
Richard M. Stallman's avatar
Richard M. Stallman committed
452 453 454 455 456 457 458 459
{
  Lisp_Object args[3];
  args[0] = s1;
  args[1] = s2;
  args[2] = s3;
  return concat (3, args, Lisp_String, 0);
}

Paul Eggert's avatar
Paul Eggert committed
460
DEFUN ("append", Fappend, Sappend, 0, MANY, 0,
461
       doc: /* Concatenate all the arguments and make the result a list.
Gerd Moellmann's avatar
Gerd Moellmann committed
462 463
The result is a list whose elements are the elements of all the arguments.
Each argument may be a list, vector or string.
464 465
The last argument is not copied, just used as the tail of the new list.
usage: (append &rest SEQUENCES)  */)
466
  (ptrdiff_t nargs, Lisp_Object *args)
Jim Blandy's avatar
Jim Blandy committed
467 468 469 470
{
  return concat (nargs, args, Lisp_Cons, 1);
}

Paul Eggert's avatar
Paul Eggert committed
471
DEFUN ("concat", Fconcat, Sconcat, 0, MANY, 0,
472
       doc: /* Concatenate all the arguments and make the result a string.
Gerd Moellmann's avatar
Gerd Moellmann committed
473
The result is a string whose elements are the elements of all the arguments.
474 475
Each argument may be a string or a list or vector of characters (integers).
usage: (concat &rest SEQUENCES)  */)
476
  (ptrdiff_t nargs, Lisp_Object *args)
Jim Blandy's avatar
Jim Blandy committed
477 478 479 480
{
  return concat (nargs, args, Lisp_String, 0);
}

Paul Eggert's avatar
Paul Eggert committed
481
DEFUN ("vconcat", Fvconcat, Svconcat, 0, MANY, 0,
482
       doc: /* Concatenate all the arguments and make the result a vector.
Gerd Moellmann's avatar
Gerd Moellmann committed
483
The result is a vector whose elements are the elements of all the arguments.
484 485
Each argument may be a list, vector or string.
usage: (vconcat &rest SEQUENCES)   */)
486
  (ptrdiff_t nargs, Lisp_Object *args)
Jim Blandy's avatar
Jim Blandy committed
487
{
488
  return concat (nargs, args, Lisp_Vectorlike, 0);
Jim Blandy's avatar
Jim Blandy committed
489 490
}

491

Paul Eggert's avatar
Paul Eggert committed
492
DEFUN ("copy-sequence", Fcopy_sequence, Scopy_sequence, 1, 1, 0,
Dave Love's avatar
Dave Love committed
493
       doc: /* Return a copy of a list, vector, string or char-table.
Gerd Moellmann's avatar
Gerd Moellmann committed
494
The elements of a list or vector are not copied; they are shared
495
with the original.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
496
  (Lisp_Object arg)
Jim Blandy's avatar
Jim Blandy committed
497
{
Jim Blandy's avatar
Jim Blandy committed
498
  if (NILP (arg)) return arg;
499 500 501

  if (CHAR_TABLE_P (arg))
    {
502
      return copy_char_table (arg);
503 504 505 506
    }

  if (BOOL_VECTOR_P (arg))
    {
507 508 509 510
      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);
511 512 513
      return val;
    }

514
  if (!CONSP (arg) && !VECTORP (arg) && !STRINGP (arg))
515 516
    wrong_type_argument (Qsequencep, arg);

517
  return concat (1, &arg, XTYPE (arg), 0);
Jim Blandy's avatar
Jim Blandy committed
518 519
}

520 521
/* 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
522
struct textprop_rec
523
{
524
  ptrdiff_t argnum;		/* refer to ARGS (arguments of `concat') */
525 526
  ptrdiff_t from;		/* refer to ARGS[argnum] (argument string) */
  ptrdiff_t to;			/* refer to VAL (the target string) */
527 528
};

Jim Blandy's avatar
Jim Blandy committed
529
static Lisp_Object
530
concat (ptrdiff_t nargs, Lisp_Object *args,
531
	enum Lisp_Type target_type, bool last_special)
Jim Blandy's avatar
Jim Blandy committed
532 533
{
  Lisp_Object val;
534 535
  Lisp_Object tail;
  Lisp_Object this;
536 537
  ptrdiff_t toindex;
  ptrdiff_t toindex_byte = 0;
538 539
  EMACS_INT result_len;
  EMACS_INT result_len_byte;
540
  ptrdiff_t argnum;
Jim Blandy's avatar
Jim Blandy committed
541 542
  Lisp_Object last_tail;
  Lisp_Object prev;
543
  bool some_multibyte;
544
  /* When we make a multibyte string, we can't copy text properties
Paul Eggert's avatar
Paul Eggert committed
545 546
     while concatenating each string because the length of resulting
     string can't be decided until we finish the whole concatenation.
547
     So, we record strings that have text properties to be copied
Paul Eggert's avatar
Paul Eggert committed
548
     here, and copy the text properties after the concatenation.  */
549
  struct textprop_rec  *textprops = NULL;
Juanma Barranquero's avatar
Juanma Barranquero committed
550
  /* Number of elements in textprops.  */
551
  ptrdiff_t num_textprops = 0;
Kim F. Storm's avatar
Kim F. Storm committed
552
  USE_SAFE_ALLOCA;
Jim Blandy's avatar
Jim Blandy committed
553

554 555
  tail = Qnil;

Jim Blandy's avatar
Jim Blandy committed
556 557 558 559 560 561 562 563 564
  /* 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;

565
  /* Check each argument.  */
Jim Blandy's avatar
Jim Blandy committed
566 567 568
  for (argnum = 0; argnum < nargs; argnum++)
    {
      this = args[argnum];
569
      if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
Stefan Monnier's avatar
Stefan Monnier committed
570
	    || COMPILEDP (this) || BOOL_VECTOR_P (this)))
571
	wrong_type_argument (Qsequencep, this);
Jim Blandy's avatar
Jim Blandy committed
572 573
    }

574 575 576 577 578 579 580 581
  /* 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
582
    {
583
      EMACS_INT len;
Jim Blandy's avatar
Jim Blandy committed
584
      this = args[argnum];
585 586
      len = XFASTINT (Flength (this));
      if (target_type == Lisp_String)
587
	{
588 589
	  /* We must count the number of bytes needed in the string
	     as well as the number of characters.  */
590
	  ptrdiff_t i;
591
	  Lisp_Object ch;
592
	  int c;
593
	  ptrdiff_t this_len_byte;
594

Stefan Monnier's avatar
Stefan Monnier committed
595
	  if (VECTORP (this) || COMPILEDP (this))
596
	    for (i = 0; i < len; i++)
597
	      {
Stefan Monnier's avatar
Stefan Monnier committed
598
		ch = AREF (this, i);
Miles Bader's avatar
Miles Bader committed
599
		CHECK_CHARACTER (ch);
600 601
		c = XFASTINT (ch);
		this_len_byte = CHAR_BYTES (c);
602 603
		if (STRING_BYTES_BOUND - result_len_byte < this_len_byte)
		  string_overflow ();
604
		result_len_byte += this_len_byte;
605
		if (! ASCII_CHAR_P (c) && ! CHAR_BYTE8_P (c))
606
		  some_multibyte = 1;
607
	      }
608
	  else if (BOOL_VECTOR_P (this) && bool_vector_size (this) > 0)
609
	    wrong_type_argument (Qintegerp, Faref (this, make_number (0)));
610
	  else if (CONSP (this))
611
	    for (; CONSP (this); this = XCDR (this))
612
	      {
613
		ch = XCAR (this);
Miles Bader's avatar
Miles Bader committed
614
		CHECK_CHARACTER (ch);
615 616
		c = XFASTINT (ch);
		this_len_byte = CHAR_BYTES (c);
617 618
		if (STRING_BYTES_BOUND - result_len_byte < this_len_byte)
		  string_overflow ();
619
		result_len_byte += this_len_byte;
620
		if (! ASCII_CHAR_P (c) && ! CHAR_BYTE8_P (c))
621
		  some_multibyte = 1;
622
	      }
623
	  else if (STRINGP (this))
624
	    {
625
	      if (STRING_MULTIBYTE (this))
626 627
		{
		  some_multibyte = 1;
628
		  this_len_byte = SBYTES (this);
629 630
		}
	      else
631 632 633 634 635
		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;
636
	    }
637
	}
638 639

      result_len += len;
640 641
      if (MOST_POSITIVE_FIXNUM < result_len)
	memory_full (SIZE_MAX);
Jim Blandy's avatar
Jim Blandy committed
642 643
    }

644 645
  if (! some_multibyte)
    result_len_byte = result_len;
Jim Blandy's avatar
Jim Blandy committed
646

647
  /* Create the output object.  */
Jim Blandy's avatar
Jim Blandy committed
648
  if (target_type == Lisp_Cons)
649
    val = Fmake_list (make_number (result_len), Qnil);
650
  else if (target_type == Lisp_Vectorlike)
651
    val = Fmake_vector (make_number (result_len), Qnil);
652
  else if (some_multibyte)
653
    val = make_uninit_multibyte_string (result_len, result_len_byte);
654 655
  else
    val = make_uninit_string (result_len);
Jim Blandy's avatar
Jim Blandy committed
656

657 658 659
  /* 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
660

661
  /* Copy the contents of the args into the result.  */
Jim Blandy's avatar
Jim Blandy committed
662
  if (CONSP (val))
663
    tail = val, toindex = -1; /* -1 in toindex is flag we are making a list */
Jim Blandy's avatar
Jim Blandy committed
664
  else
665
    toindex = 0, toindex_byte = 0;
Jim Blandy's avatar
Jim Blandy committed
666 667

  prev = Qnil;
668
  if (STRINGP (val))
669
    SAFE_NALLOCA (textprops, 1, nargs);
Jim Blandy's avatar
Jim Blandy committed
670 671 672 673

  for (argnum = 0; argnum < nargs; argnum++)
    {
      Lisp_Object thislen;
674 675 676
      ptrdiff_t thisleni = 0;
      register ptrdiff_t thisindex = 0;
      register ptrdiff_t thisindex_byte = 0;
Jim Blandy's avatar
Jim Blandy committed
677 678 679 680 681

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

682 683 684
      /* 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
685
	{
686
	  ptrdiff_t thislen_byte = SBYTES (this);
687

688
	  memcpy (SDATA (val) + toindex_byte, SDATA (this), SBYTES (this));
689
	  if (string_intervals (this))
690
	    {
Kenichi Handa's avatar
Kenichi Handa committed
691
	      textprops[num_textprops].argnum = argnum;
692
	      textprops[num_textprops].from = 0;
Kenichi Handa's avatar
Kenichi Handa committed
693
	      textprops[num_textprops++].to = toindex;
694
	    }
695
	  toindex_byte += thislen_byte;
696
	  toindex += thisleni;
697
	}
698 699 700
      /* Copy a single-byte string to a multibyte string.  */
      else if (STRINGP (this) && STRINGP (val))
	{
701
	  if (string_intervals (this))
702
	    {
Kenichi Handa's avatar
Kenichi Handa committed
703 704 705
	      textprops[num_textprops].argnum = argnum;
	      textprops[num_textprops].from = 0;
	      textprops[num_textprops++].to = toindex;
706
	    }
707 708 709
	  toindex_byte += copy_text (SDATA (this),
				     SDATA (val) + toindex_byte,
				     SCHARS (this), 0, 1);
710 711
	  toindex += thisleni;
	}
712 713 714 715 716 717 718 719 720 721
      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))
722
	      elt = XCAR (this), this = XCDR (this);
723 724 725
	    else if (thisindex >= thisleni)
	      break;
	    else if (STRINGP (this))
726
	      {
727
		int c;
728
		if (STRING_MULTIBYTE (this))
729 730 731
		  FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c, this,
						      thisindex,
						      thisindex_byte);
732
		else
733
		  {
734 735 736
		    c = SREF (this, thisindex); thisindex++;
		    if (some_multibyte && !ASCII_CHAR_P (c))
		      c = BYTE8_TO_CHAR (c);
737
		  }
738
		XSETFASTINT (elt, c);
739 740 741
	      }
	    else if (BOOL_VECTOR_P (this))
	      {
742
		elt = bool_vector_ref (this, thisindex);
743
		thisindex++;
744
	      }
745
	    else
746 747 748 749
	      {
		elt = AREF (this, thisindex);
		thisindex++;
	      }
Jim Blandy's avatar
Jim Blandy committed
750

751 752
	    /* Store this element into the result.  */
	    if (toindex < 0)
Jim Blandy's avatar
Jim Blandy committed
753
	      {
754
		XSETCAR (tail, elt);
755
		prev = tail;
756
		tail = XCDR (tail);