fns.c 149 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-2017 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>
Andreas Schwab's avatar
Andreas Schwab committed
24
#include <unistd.h>
25
#include <filevercmp.h>
26
#include <intprops.h>
Paul Eggert's avatar
Paul Eggert committed
27
#include <vla.h>
28
#include <errno.h>
29

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

40
#if defined WINDOWSNT && defined HAVE_GNUTLS3
41 42 43
# define gnutls_rnd w32_gnutls_rnd
#endif

Paul Eggert's avatar
Paul Eggert committed
44
static void sort_vector_copy (Lisp_Object, ptrdiff_t,
45
			      Lisp_Object *restrict, Lisp_Object *restrict);
46 47 48
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);
49

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

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

63
With positive integer LIMIT, return random number in interval [0,LIMIT).
64
With argument t, set the random number seed from the system's entropy
65
pool if available, otherwise from less-random volatile data such as the time.
Glenn Morris's avatar
Glenn Morris committed
66 67 68 69
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
70
  (Lisp_Object limit)
Jim Blandy's avatar
Jim Blandy committed
71
{
72
  EMACS_INT val;
Jim Blandy's avatar
Jim Blandy committed
73

74
  if (EQ (limit, Qt))
75 76 77
    init_random ();
  else if (STRINGP (limit))
    seed_random (SSDATA (limit), SBYTES (limit));
78

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

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

106
  if (STRINGP (sequence))
107
    XSETFASTINT (val, SCHARS (sequence));
108
  else if (VECTORP (sequence))
Stefan Monnier's avatar
Stefan Monnier committed
109
    XSETFASTINT (val, ASIZE (sequence));
110
  else if (CHAR_TABLE_P (sequence))
111
    XSETFASTINT (val, MAX_CHAR);
112
  else if (BOOL_VECTOR_P (sequence))
113
    XSETFASTINT (val, bool_vector_size (sequence));
114
  else if (COMPILEDP (sequence) || RECORDP (sequence))
115
    XSETFASTINT (val, PVSIZE (sequence));
116
  else if (CONSP (sequence))
Jim Blandy's avatar
Jim Blandy committed
117
    {
118 119 120
      intptr_t i = 0;
      FOR_EACH_TAIL (sequence)
	i++;
121
      CHECK_LIST_END (sequence, sequence);
122 123
      if (MOST_POSITIVE_FIXNUM < i)
	error ("List too long");
124
      val = make_number (i);
Jim Blandy's avatar
Jim Blandy committed
125
    }
126
  else if (NILP (sequence))
127
    XSETFASTINT (val, 0);
Jim Blandy's avatar
Jim Blandy committed
128
  else
129
    wrong_type_argument (Qsequencep, sequence);
130

131
  return val;
Jim Blandy's avatar
Jim Blandy committed
132 133
}

134
DEFUN ("safe-length", Fsafe_length, Ssafe_length, 1, 1, 0,
135
       doc: /* Return the length of a list, but avoid error or infinite loop.
Gerd Moellmann's avatar
Gerd Moellmann committed
136 137
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
138
which is at least the number of distinct elements.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
139
  (Lisp_Object list)
140
{
141 142 143 144
  intptr_t len = 0;
  FOR_EACH_TAIL_SAFE (list)
    len++;
  return make_fixnum_or_float (len);
145 146
}

147
DEFUN ("string-bytes", Fstring_bytes, Sstring_bytes, 1, 1, 0,
148
       doc: /* Return the number of bytes in STRING.
Miles Bader's avatar
Miles Bader committed
149
If STRING is multibyte, this may be greater than the length of STRING.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
150
  (Lisp_Object string)
151
{
152
  CHECK_STRING (string);
153
  return make_number (SBYTES (string));
154 155
}

Paul Eggert's avatar
Paul Eggert committed
156
DEFUN ("string-equal", Fstring_equal, Sstring_equal, 2, 2, 0,
157
       doc: /* Return t if two strings have identical contents.
Gerd Moellmann's avatar
Gerd Moellmann committed
158
Case is significant, but text properties are ignored.
159
Symbols are also allowed; their print names are used instead.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
160
  (register Lisp_Object s1, Lisp_Object s2)
Jim Blandy's avatar
Jim Blandy committed
161
{
162
  if (SYMBOLP (s1))
163
    s1 = SYMBOL_NAME (s1);
164
  if (SYMBOLP (s2))
165
    s2 = SYMBOL_NAME (s2);
166 167
  CHECK_STRING (s1);
  CHECK_STRING (s2);
Jim Blandy's avatar
Jim Blandy committed
168

169 170
  if (SCHARS (s1) != SCHARS (s2)
      || SBYTES (s1) != SBYTES (s2)
171
      || memcmp (SDATA (s1), SDATA (s2), SBYTES (s1)))
Jim Blandy's avatar
Jim Blandy committed
172 173 174 175
    return Qnil;
  return Qt;
}

Paul Eggert's avatar
Paul Eggert committed
176
DEFUN ("compare-strings", Fcompare_strings, Scompare_strings, 6, 7, 0,
Juanma Barranquero's avatar
Juanma Barranquero committed
177
       doc: /* Compare the contents of two strings, converting to multibyte if needed.
178 179 180
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
181
\(exclusive).  If START1 is nil, it defaults to 0, the beginning of
182 183
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.
184
Like in `substring', negative values are counted from the end.
185 186 187 188

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,
189
characters are converted to upper-case before comparing them.  Unibyte
190
strings are converted to multibyte for comparison.
Gerd Moellmann's avatar
Gerd Moellmann committed
191 192 193 194 195

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;
196
  N - 1 is the number of characters that match at the beginning.  */)
197 198
  (Lisp_Object str1, Lisp_Object start1, Lisp_Object end1, Lisp_Object str2,
   Lisp_Object start2, Lisp_Object end2, Lisp_Object ignore_case)
199
{
200
  ptrdiff_t from1, to1, from2, to2, i1, i1_byte, i2, i2_byte;
201

202 203
  CHECK_STRING (str1);
  CHECK_STRING (str2);
204

205 206 207 208 209 210 211
  /* 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));

212 213 214 215 216
  validate_subarray (str1, start1, end1, SCHARS (str1), &from1, &to1);
  validate_subarray (str2, start2, end2, SCHARS (str2), &from2, &to2);

  i1 = from1;
  i2 = from2;
217 218 219

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

221
  while (i1 < to1 && i2 < to2)
222 223 224 225 226
    {
      /* When we find a mismatch, we must compare the
	 characters, not just the bytes.  */
      int c1, c2;

227 228
      FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c1, str1, i1, i1_byte);
      FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c2, str2, i2, i2_byte);
229 230 231 232 233 234

      if (c1 == c2)
	continue;

      if (! NILP (ignore_case))
	{
235 236
	  c1 = XINT (Fupcase (make_number (c1)));
	  c2 = XINT (Fupcase (make_number (c2)));
237 238 239 240 241 242 243 244 245
	}

      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)
246
	return make_number (- i1 + from1);
247
      else
248
	return make_number (i1 - from1);
249 250
    }

251 252 253 254
  if (i1 < to1)
    return make_number (i1 - from1 + 1);
  if (i2 < to2)
    return make_number (- i1 + from1 - 1);
255 256 257 258

  return Qt;
}

Paul Eggert's avatar
Paul Eggert committed
259
DEFUN ("string-lessp", Fstring_lessp, Sstring_lessp, 2, 2, 0,
260
       doc: /* Return non-nil if STRING1 is less than STRING2 in lexicographic order.
Gerd Moellmann's avatar
Gerd Moellmann committed
261
Case is significant.
262
Symbols are also allowed; their print names are used instead.  */)
263
  (register Lisp_Object string1, Lisp_Object string2)
Jim Blandy's avatar
Jim Blandy committed
264
{
265 266
  register ptrdiff_t end;
  register ptrdiff_t i1, i1_byte, i2, i2_byte;
Jim Blandy's avatar
Jim Blandy committed
267

268 269 270 271 272 273
  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
274

275 276
  i1 = i1_byte = i2 = i2_byte = 0;

277 278 279
  end = SCHARS (string1);
  if (end > SCHARS (string2))
    end = SCHARS (string2);
Jim Blandy's avatar
Jim Blandy committed
280

281
  while (i1 < end)
Jim Blandy's avatar
Jim Blandy committed
282
    {
283 284 285 286
      /* When we find a mismatch, we must compare the
	 characters, not just the bytes.  */
      int c1, c2;

287 288
      FETCH_STRING_CHAR_ADVANCE (c1, string1, i1, i1_byte);
      FETCH_STRING_CHAR_ADVANCE (c2, string2, i2, i2_byte);
289 290 291

      if (c1 != c2)
	return c1 < c2 ? Qt : Qnil;
Jim Blandy's avatar
Jim Blandy committed
292
    }
293
  return i1 < SCHARS (string2) ? Qt : Qnil;
Jim Blandy's avatar
Jim Blandy committed
294
}
Michael Albinus's avatar
Michael Albinus committed
295

296 297 298 299 300 301 302 303 304
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.
305

306
For example, \"foo2.png\" compares less than \"foo12.png\".
307 308
Case is significant.
Symbols are also allowed; their print names are used instead.  */)
309
  (Lisp_Object string1, Lisp_Object string2)
310 311 312 313 314 315 316 317
{
  if (SYMBOLP (string1))
    string1 = SYMBOL_NAME (string1);
  if (SYMBOLP (string2))
    string2 = SYMBOL_NAME (string2);
  CHECK_STRING (string1);
  CHECK_STRING (string2);

318 319 320 321 322
  char *p1 = SSDATA (string1);
  char *p2 = SSDATA (string2);
  char *lim1 = p1 + SBYTES (string1);
  char *lim2 = p2 + SBYTES (string2);
  int cmp;
323

324
  while ((cmp = filevercmp (p1, p2)) == 0)
325
    {
326 327 328 329 330 331 332 333 334
      /* If the strings are identical through their first null bytes,
	 skip past identical prefixes and try again.  */
      ptrdiff_t size = strlen (p1) + 1;
      p1 += size;
      p2 += size;
      if (lim1 < p1)
	return lim2 < p2 ? Qnil : Qt;
      if (lim2 < p2)
	return Qnil;
335
    }
336 337

  return cmp < 0 ? Qt : Qnil;
338 339
}

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

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

348
\(sort \\='("11" "12" "1 1" "1 2" "1.1" "1.2") \\='string-collate-lessp)
349
  => ("11" "1 1" "1.1" "12" "1 2" "1.2")
Michael Albinus's avatar
Michael Albinus committed
350

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

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

359 360 361 362
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.

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

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

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

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

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

394
\(string-collate-equalp (string ?\\uFF40) (string ?\\u1FEF))
Michael Albinus's avatar
Michael Albinus committed
395 396
  => t

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

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

405 406 407 408
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.

409
If your system does not support a locale environment, this function
410 411
behaves like `string-equal'.

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

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

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

/* ARGSUSED */
Lisp_Object
438
concat2 (Lisp_Object s1, Lisp_Object s2)
Jim Blandy's avatar
Jim Blandy committed
439
{
440
  return concat (2, ((Lisp_Object []) {s1, s2}), Lisp_String, 0);
Jim Blandy's avatar
Jim Blandy committed
441 442
}

Richard M. Stallman's avatar
Richard M. Stallman committed
443 444
/* ARGSUSED */
Lisp_Object
445
concat3 (Lisp_Object s1, Lisp_Object s2, Lisp_Object s3)
Richard M. Stallman's avatar
Richard M. Stallman committed
446
{
447
  return concat (3, ((Lisp_Object []) {s1, s2, s3}), Lisp_String, 0);
Richard M. Stallman's avatar
Richard M. Stallman committed
448 449
}

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

Paul Eggert's avatar
Paul Eggert committed
461
DEFUN ("concat", Fconcat, Sconcat, 0, MANY, 0,
462
       doc: /* Concatenate all the arguments and make the result a string.
Gerd Moellmann's avatar
Gerd Moellmann committed
463
The result is a string whose elements are the elements of all the arguments.
464 465
Each argument may be a string or a list or vector of characters (integers).
usage: (concat &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_String, 0);
}

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

481

Paul Eggert's avatar
Paul Eggert committed
482
DEFUN ("copy-sequence", Fcopy_sequence, Scopy_sequence, 1, 1, 0,
483 484 485
       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
shared with the original.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
486
  (Lisp_Object arg)
Jim Blandy's avatar
Jim Blandy committed
487
{
Jim Blandy's avatar
Jim Blandy committed
488
  if (NILP (arg)) return arg;
489

490 491
  if (RECORDP (arg))
    {
492
      return Frecord (PVSIZE (arg), XVECTOR (arg)->contents);
493 494
    }

495 496
  if (CHAR_TABLE_P (arg))
    {
497
      return copy_char_table (arg);
498 499 500 501
    }

  if (BOOL_VECTOR_P (arg))
    {
502 503 504 505
      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);
506 507 508
      return val;
    }

509
  if (!CONSP (arg) && !VECTORP (arg) && !STRINGP (arg))
510 511
    wrong_type_argument (Qsequencep, arg);

512
  return concat (1, &arg, XTYPE (arg), 0);
Jim Blandy's avatar
Jim Blandy committed
513 514
}

515 516
/* 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
517
struct textprop_rec
518
{
519
  ptrdiff_t argnum;		/* refer to ARGS (arguments of `concat') */
520 521
  ptrdiff_t from;		/* refer to ARGS[argnum] (argument string) */
  ptrdiff_t to;			/* refer to VAL (the target string) */
522 523
};

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

549 550
  tail = Qnil;

Jim Blandy's avatar
Jim Blandy committed
551 552 553 554 555 556 557 558 559
  /* 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;

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

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

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

      result_len += len;
635 636
      if (MOST_POSITIVE_FIXNUM < result_len)
	memory_full (SIZE_MAX);
Jim Blandy's avatar
Jim Blandy committed
637 638
    }

639 640
  if (! some_multibyte)
    result_len_byte = result_len;
Jim Blandy's avatar
Jim Blandy committed
641

642
  /* Create the output object.  */
Jim Blandy's avatar
Jim Blandy committed
643
  if (target_type == Lisp_Cons)
644
    val = Fmake_list (make_number (result_len), Qnil);
645
  else if (target_type == Lisp_Vectorlike)
646
    val = Fmake_vector (make_number (result_len), Qnil);
647
  else if (some_multibyte)
648
    val = make_uninit_multibyte_string (result_len, result_len_byte);
649 650
  else
    val = make_uninit_string (result_len);
Jim Blandy's avatar
Jim Blandy committed
651

652 653 654
  /* 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
655

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

  prev = Qnil;
663
  if (STRINGP (val))
664
    SAFE_NALLOCA (textprops, 1, nargs);
Jim Blandy's avatar
Jim Blandy committed
665 666 667 668

  for (argnum = 0; argnum < nargs; argnum++)
    {
      Lisp_Object thislen;
669 670 671
      ptrdiff_t thisleni = 0;
      register ptrdiff_t thisindex = 0;
      register ptrdiff_t thisindex_byte = 0;
Jim Blandy's avatar
Jim Blandy committed
672 673 674 675 676

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

677 678 679
      /* 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
680
	{
681
	  ptrdiff_t thislen_byte = SBYTES (this);
682

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