fns.c 135 KB
Newer Older
Jim Blandy's avatar
Jim Blandy committed
1
/* Random utility Lisp functions.
2
   Copyright (C) 1985-1987, 1993-1995, 1997-2012
Juanma Barranquero's avatar
Juanma Barranquero committed
3
		 Free Software Foundation, Inc.
Jim Blandy's avatar
Jim Blandy committed
4 5 6

This file is part of GNU Emacs.

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

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
18
along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.  */
Jim Blandy's avatar
Jim Blandy committed
19

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

Andreas Schwab's avatar
Andreas Schwab committed
22
#include <unistd.h>
Andreas Schwab's avatar
Andreas Schwab committed
23
#include <time.h>
Andreas Schwab's avatar
Andreas Schwab committed
24

25 26
#include <intprops.h>

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

44 45 46
Lisp_Object Qstring_lessp;
static Lisp_Object Qprovide, Qrequire;
static Lisp_Object Qyes_or_no_p_history;
47
Lisp_Object Qcursor_in_echo_area;
48 49
static Lisp_Object Qwidget_type;
static Lisp_Object Qcodeset, Qdays, Qmonths, Qpaper;
Jim Blandy's avatar
Jim Blandy committed
50

51 52
static Lisp_Object Qmd5, Qsha1, Qsha224, Qsha256, Qsha384, Qsha512;

53
static bool internal_equal (Lisp_Object, Lisp_Object, int, bool);
54

Paul Eggert's avatar
Paul Eggert committed
55
DEFUN ("identity", Fidentity, Sidentity, 1, 1, 0,
Pavel Janík's avatar
Pavel Janík committed
56
       doc: /* Return the argument unchanged.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
57
  (Lisp_Object arg)
Jim Blandy's avatar
Jim Blandy committed
58 59 60 61 62
{
  return arg;
}

DEFUN ("random", Frandom, Srandom, 0, 1, 0,
63
       doc: /* Return a pseudo-random number.
Gerd Moellmann's avatar
Gerd Moellmann committed
64
All integers representable in Lisp are equally likely.
Kenichi Handa's avatar
Kenichi Handa committed
65
  On most systems, this is 29 bits' worth.
66 67 68
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.
Other values of LIMIT are ignored.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
69
  (Lisp_Object limit)
Jim Blandy's avatar
Jim Blandy committed
70
{
71
  EMACS_INT val;
Jim Blandy's avatar
Jim Blandy committed
72

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

78
  val = get_random ();
79
  if (NATNUMP (limit) && XFASTINT (limit) != 0)
80 81
    val %= XFASTINT (limit);
  return make_number (val);
Jim Blandy's avatar
Jim Blandy committed
82 83
}

84 85 86 87
/* 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 };

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

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

100
  if (STRINGP (sequence))
101
    XSETFASTINT (val, SCHARS (sequence));
102
  else if (VECTORP (sequence))
Stefan Monnier's avatar
Stefan Monnier committed
103
    XSETFASTINT (val, ASIZE (sequence));
104
  else if (CHAR_TABLE_P (sequence))
105
    XSETFASTINT (val, MAX_CHAR);
106 107
  else if (BOOL_VECTOR_P (sequence))
    XSETFASTINT (val, XBOOL_VECTOR (sequence)->size);
Stefan Monnier's avatar
Stefan Monnier committed
108 109
  else if (COMPILEDP (sequence))
    XSETFASTINT (val, ASIZE (sequence) & PSEUDOVECTOR_SIZE_MASK);
110
  else if (CONSP (sequence))
Jim Blandy's avatar
Jim Blandy committed
111
    {
112 113 114
      EMACS_INT i = 0;

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

127
      CHECK_LIST_END (sequence, sequence);
128 129

      val = make_number (i);
Jim Blandy's avatar
Jim Blandy committed
130
    }
131
  else if (NILP (sequence))
132
    XSETFASTINT (val, 0);
Jim Blandy's avatar
Jim Blandy committed
133
  else
134
    wrong_type_argument (Qsequencep, sequence);
135

136
  return val;
Jim Blandy's avatar
Jim Blandy committed
137 138
}

139
/* This does not check for quits.  That is safe since it must terminate.  */
140 141

DEFUN ("safe-length", Fsafe_length, Ssafe_length, 1, 1, 0,
142
       doc: /* Return the length of a list, but avoid error or infinite loop.
Gerd Moellmann's avatar
Gerd Moellmann committed
143 144
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
145
which is at least the number of distinct elements.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
146
  (Lisp_Object list)
147
{
148 149 150 151 152
  Lisp_Object tail, halftail;
  double hilen = 0;
  uintmax_t lolen = 1;

  if (! CONSP (list))
153
    return make_number (0);
154 155

  /* halftail is used to detect circular lists.  */
156
  for (tail = halftail = list; ; )
157
    {
158 159
      tail = XCDR (tail);
      if (! CONSP (tail))
160
	break;
161 162 163 164 165 166 167 168 169 170 171 172 173
      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;
	    }
	}
174 175
    }

176 177 178 179
  /* 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);
180 181
}

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

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

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

Paul Eggert's avatar
Paul Eggert committed
211
DEFUN ("compare-strings", Fcompare_strings, Scompare_strings, 6, 7, 0,
Juanma Barranquero's avatar
Juanma Barranquero committed
212
       doc: /* Compare the contents of two strings, converting to multibyte if needed.
Gerd Moellmann's avatar
Gerd Moellmann committed
213 214 215 216 217 218 219 220 221 222 223
In string STR1, skip the first START1 characters and stop at END1.
In string STR2, skip the first START2 characters and stop at END2.
END1 and END2 default to the full lengths of the respective strings.

Case is significant in this comparison if IGNORE-CASE is nil.
Unibyte strings are converted to multibyte for comparison.

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;
224
  N - 1 is the number of characters that match at the beginning.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
225
  (Lisp_Object str1, Lisp_Object start1, Lisp_Object end1, Lisp_Object str2, Lisp_Object start2, Lisp_Object end2, Lisp_Object ignore_case)
226
{
227 228
  register ptrdiff_t end1_char, end2_char;
  register ptrdiff_t i1, i1_byte, i2, i2_byte;
229

230 231
  CHECK_STRING (str1);
  CHECK_STRING (str2);
232 233 234 235
  if (NILP (start1))
    start1 = make_number (0);
  if (NILP (start2))
    start2 = make_number (0);
236 237
  CHECK_NATNUM (start1);
  CHECK_NATNUM (start2);
238
  if (! NILP (end1))
239
    CHECK_NATNUM (end1);
240
  if (! NILP (end2))
241
    CHECK_NATNUM (end2);
242

243
  end1_char = SCHARS (str1);
244 245
  if (! NILP (end1) && end1_char > XINT (end1))
    end1_char = XINT (end1);
246 247
  if (end1_char < XINT (start1))
    args_out_of_range (str1, start1);
248

249
  end2_char = SCHARS (str2);
250 251
  if (! NILP (end2) && end2_char > XINT (end2))
    end2_char = XINT (end2);
252 253 254 255 256 257 258 259
  if (end2_char < XINT (start2))
    args_out_of_range (str2, start2);

  i1 = XINT (start1);
  i2 = XINT (start2);

  i1_byte = string_char_to_byte (str1, i1);
  i2_byte = string_char_to_byte (str2, i2);
260 261 262 263 264 265 266 267

  while (i1 < end1_char && i2 < end2_char)
    {
      /* When we find a mismatch, we must compare the
	 characters, not just the bytes.  */
      int c1, c2;

      if (STRING_MULTIBYTE (str1))
268
	FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1, str1, i1, i1_byte);
269 270
      else
	{
271
	  c1 = SREF (str1, i1++);
272
	  MAKE_CHAR_MULTIBYTE (c1);
273 274 275
	}

      if (STRING_MULTIBYTE (str2))
276
	FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2, str2, i2, i2_byte);
277 278
      else
	{
279
	  c2 = SREF (str2, i2++);
280
	  MAKE_CHAR_MULTIBYTE (c2);
281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302
	}

      if (c1 == c2)
	continue;

      if (! NILP (ignore_case))
	{
	  Lisp_Object tem;

	  tem = Fupcase (make_number (c1));
	  c1 = XINT (tem);
	  tem = Fupcase (make_number (c2));
	  c2 = XINT (tem);
	}

      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)
303
	return make_number (- i1 + XINT (start1));
304
      else
305
	return make_number (i1 - XINT (start1));
306 307 308 309 310 311 312 313 314 315
    }

  if (i1 < end1_char)
    return make_number (i1 - XINT (start1) + 1);
  if (i2 < end2_char)
    return make_number (- i1 + XINT (start1) - 1);

  return Qt;
}

Paul Eggert's avatar
Paul Eggert committed
316
DEFUN ("string-lessp", Fstring_lessp, Sstring_lessp, 2, 2, 0,
317
       doc: /* Return t if first arg string is less than second in lexicographic order.
Gerd Moellmann's avatar
Gerd Moellmann committed
318
Case is significant.
319
Symbols are also allowed; their print names are used instead.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
320
  (register Lisp_Object s1, Lisp_Object s2)
Jim Blandy's avatar
Jim Blandy committed
321
{
322 323
  register ptrdiff_t end;
  register ptrdiff_t i1, i1_byte, i2, i2_byte;
Jim Blandy's avatar
Jim Blandy committed
324

325
  if (SYMBOLP (s1))
326
    s1 = SYMBOL_NAME (s1);
327
  if (SYMBOLP (s2))
328
    s2 = SYMBOL_NAME (s2);
329 330
  CHECK_STRING (s1);
  CHECK_STRING (s2);
Jim Blandy's avatar
Jim Blandy committed
331

332 333
  i1 = i1_byte = i2 = i2_byte = 0;

334 335 336
  end = SCHARS (s1);
  if (end > SCHARS (s2))
    end = SCHARS (s2);
Jim Blandy's avatar
Jim Blandy committed
337

338
  while (i1 < end)
Jim Blandy's avatar
Jim Blandy committed
339
    {
340 341 342 343
      /* When we find a mismatch, we must compare the
	 characters, not just the bytes.  */
      int c1, c2;

344 345
      FETCH_STRING_CHAR_ADVANCE (c1, s1, i1, i1_byte);
      FETCH_STRING_CHAR_ADVANCE (c2, s2, i2, i2_byte);
346 347 348

      if (c1 != c2)
	return c1 < c2 ? Qt : Qnil;
Jim Blandy's avatar
Jim Blandy committed
349
    }
350
  return i1 < SCHARS (s2) ? Qt : Qnil;
Jim Blandy's avatar
Jim Blandy committed
351 352
}

353
static Lisp_Object concat (ptrdiff_t nargs, Lisp_Object *args,
354
			   enum Lisp_Type target_type, bool last_special);
Jim Blandy's avatar
Jim Blandy committed
355 356 357

/* ARGSUSED */
Lisp_Object
358
concat2 (Lisp_Object s1, Lisp_Object s2)
Jim Blandy's avatar
Jim Blandy committed
359 360 361 362 363 364 365
{
  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
366 367
/* ARGSUSED */
Lisp_Object
368
concat3 (Lisp_Object s1, Lisp_Object s2, Lisp_Object s3)
Richard M. Stallman's avatar
Richard M. Stallman committed
369 370 371 372 373 374 375 376
{
  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
377
DEFUN ("append", Fappend, Sappend, 0, MANY, 0,
378
       doc: /* Concatenate all the arguments and make the result a list.
Gerd Moellmann's avatar
Gerd Moellmann committed
379 380
The result is a list whose elements are the elements of all the arguments.
Each argument may be a list, vector or string.
381 382
The last argument is not copied, just used as the tail of the new list.
usage: (append &rest SEQUENCES)  */)
383
  (ptrdiff_t nargs, Lisp_Object *args)
Jim Blandy's avatar
Jim Blandy committed
384 385 386 387
{
  return concat (nargs, args, Lisp_Cons, 1);
}

Paul Eggert's avatar
Paul Eggert committed
388
DEFUN ("concat", Fconcat, Sconcat, 0, MANY, 0,
389
       doc: /* Concatenate all the arguments and make the result a string.
Gerd Moellmann's avatar
Gerd Moellmann committed
390
The result is a string whose elements are the elements of all the arguments.
391 392
Each argument may be a string or a list or vector of characters (integers).
usage: (concat &rest SEQUENCES)  */)
393
  (ptrdiff_t nargs, Lisp_Object *args)
Jim Blandy's avatar
Jim Blandy committed
394 395 396 397
{
  return concat (nargs, args, Lisp_String, 0);
}

Paul Eggert's avatar
Paul Eggert committed
398
DEFUN ("vconcat", Fvconcat, Svconcat, 0, MANY, 0,
399
       doc: /* Concatenate all the arguments and make the result a vector.
Gerd Moellmann's avatar
Gerd Moellmann committed
400
The result is a vector whose elements are the elements of all the arguments.
401 402
Each argument may be a list, vector or string.
usage: (vconcat &rest SEQUENCES)   */)
403
  (ptrdiff_t nargs, Lisp_Object *args)
Jim Blandy's avatar
Jim Blandy committed
404
{
405
  return concat (nargs, args, Lisp_Vectorlike, 0);
Jim Blandy's avatar
Jim Blandy committed
406 407
}

408

Paul Eggert's avatar
Paul Eggert committed
409
DEFUN ("copy-sequence", Fcopy_sequence, Scopy_sequence, 1, 1, 0,
Dave Love's avatar
Dave Love committed
410
       doc: /* Return a copy of a list, vector, string or char-table.
Gerd Moellmann's avatar
Gerd Moellmann committed
411
The elements of a list or vector are not copied; they are shared
412
with the original.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
413
  (Lisp_Object arg)
Jim Blandy's avatar
Jim Blandy committed
414
{
Jim Blandy's avatar
Jim Blandy committed
415
  if (NILP (arg)) return arg;
416 417 418

  if (CHAR_TABLE_P (arg))
    {
419
      return copy_char_table (arg);
420 421 422 423 424
    }

  if (BOOL_VECTOR_P (arg))
    {
      Lisp_Object val;
425
      ptrdiff_t size_in_chars
426 427
	= ((XBOOL_VECTOR (arg)->size + BOOL_VECTOR_BITS_PER_CHAR - 1)
	   / BOOL_VECTOR_BITS_PER_CHAR);
428 429

      val = Fmake_bool_vector (Flength (arg), Qnil);
430 431
      memcpy (XBOOL_VECTOR (val)->data, XBOOL_VECTOR (arg)->data,
	      size_in_chars);
432 433 434
      return val;
    }

435
  if (!CONSP (arg) && !VECTORP (arg) && !STRINGP (arg))
436 437
    wrong_type_argument (Qsequencep, arg);

Jim Blandy's avatar
Jim Blandy committed
438 439 440
  return concat (1, &arg, CONSP (arg) ? Lisp_Cons : XTYPE (arg), 0);
}

441 442
/* 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
443
struct textprop_rec
444
{
445
  ptrdiff_t argnum;		/* refer to ARGS (arguments of `concat') */
446 447
  ptrdiff_t from;		/* refer to ARGS[argnum] (argument string) */
  ptrdiff_t to;			/* refer to VAL (the target string) */
448 449
};

Jim Blandy's avatar
Jim Blandy committed
450
static Lisp_Object
451
concat (ptrdiff_t nargs, Lisp_Object *args,
452
	enum Lisp_Type target_type, bool last_special)
Jim Blandy's avatar
Jim Blandy committed
453 454
{
  Lisp_Object val;
455 456
  Lisp_Object tail;
  Lisp_Object this;
457 458
  ptrdiff_t toindex;
  ptrdiff_t toindex_byte = 0;
459 460
  EMACS_INT result_len;
  EMACS_INT result_len_byte;
461
  ptrdiff_t argnum;
Jim Blandy's avatar
Jim Blandy committed
462 463
  Lisp_Object last_tail;
  Lisp_Object prev;
464
  bool some_multibyte;
465
  /* When we make a multibyte string, we can't copy text properties
Paul Eggert's avatar
Paul Eggert committed
466 467
     while concatenating each string because the length of resulting
     string can't be decided until we finish the whole concatenation.
468
     So, we record strings that have text properties to be copied
Paul Eggert's avatar
Paul Eggert committed
469
     here, and copy the text properties after the concatenation.  */
470
  struct textprop_rec  *textprops = NULL;
Juanma Barranquero's avatar
Juanma Barranquero committed
471
  /* Number of elements in textprops.  */
472
  ptrdiff_t num_textprops = 0;
Kim F. Storm's avatar
Kim F. Storm committed
473
  USE_SAFE_ALLOCA;
Jim Blandy's avatar
Jim Blandy committed
474

475 476
  tail = Qnil;

Jim Blandy's avatar
Jim Blandy committed
477 478 479 480 481 482 483 484 485
  /* 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;

486
  /* Check each argument.  */
Jim Blandy's avatar
Jim Blandy committed
487 488 489
  for (argnum = 0; argnum < nargs; argnum++)
    {
      this = args[argnum];
490
      if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
Stefan Monnier's avatar
Stefan Monnier committed
491
	    || COMPILEDP (this) || BOOL_VECTOR_P (this)))
492
	wrong_type_argument (Qsequencep, this);
Jim Blandy's avatar
Jim Blandy committed
493 494
    }

495 496 497 498 499 500 501 502
  /* 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
503
    {
504
      EMACS_INT len;
Jim Blandy's avatar
Jim Blandy committed
505
      this = args[argnum];
506 507
      len = XFASTINT (Flength (this));
      if (target_type == Lisp_String)
508
	{
509 510
	  /* We must count the number of bytes needed in the string
	     as well as the number of characters.  */
511
	  ptrdiff_t i;
512
	  Lisp_Object ch;
513
	  int c;
514
	  ptrdiff_t this_len_byte;
515

Stefan Monnier's avatar
Stefan Monnier committed
516
	  if (VECTORP (this) || COMPILEDP (this))
517
	    for (i = 0; i < len; i++)
518
	      {
Stefan Monnier's avatar
Stefan Monnier committed
519
		ch = AREF (this, i);
Miles Bader's avatar
Miles Bader committed
520
		CHECK_CHARACTER (ch);
521 522
		c = XFASTINT (ch);
		this_len_byte = CHAR_BYTES (c);
523 524
		if (STRING_BYTES_BOUND - result_len_byte < this_len_byte)
		  string_overflow ();
525
		result_len_byte += this_len_byte;
526
		if (! ASCII_CHAR_P (c) && ! CHAR_BYTE8_P (c))
527
		  some_multibyte = 1;
528
	      }
529 530
	  else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size > 0)
	    wrong_type_argument (Qintegerp, Faref (this, make_number (0)));
531
	  else if (CONSP (this))
532
	    for (; CONSP (this); this = XCDR (this))
533
	      {
534
		ch = XCAR (this);
Miles Bader's avatar
Miles Bader committed
535
		CHECK_CHARACTER (ch);
536 537
		c = XFASTINT (ch);
		this_len_byte = CHAR_BYTES (c);
538 539
		if (STRING_BYTES_BOUND - result_len_byte < this_len_byte)
		  string_overflow ();
540
		result_len_byte += this_len_byte;
541
		if (! ASCII_CHAR_P (c) && ! CHAR_BYTE8_P (c))
542
		  some_multibyte = 1;
543
	      }
544
	  else if (STRINGP (this))
545
	    {
546
	      if (STRING_MULTIBYTE (this))
547 548
		{
		  some_multibyte = 1;
549
		  this_len_byte = SBYTES (this);
550 551
		}
	      else
552 553 554 555 556
		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;
557
	    }
558
	}
559 560

      result_len += len;
561 562
      if (MOST_POSITIVE_FIXNUM < result_len)
	memory_full (SIZE_MAX);
Jim Blandy's avatar
Jim Blandy committed
563 564
    }

565 566
  if (! some_multibyte)
    result_len_byte = result_len;
Jim Blandy's avatar
Jim Blandy committed
567

568
  /* Create the output object.  */
Jim Blandy's avatar
Jim Blandy committed
569
  if (target_type == Lisp_Cons)
570
    val = Fmake_list (make_number (result_len), Qnil);
571
  else if (target_type == Lisp_Vectorlike)
572
    val = Fmake_vector (make_number (result_len), Qnil);
573
  else if (some_multibyte)
574
    val = make_uninit_multibyte_string (result_len, result_len_byte);
575 576
  else
    val = make_uninit_string (result_len);
Jim Blandy's avatar
Jim Blandy committed
577

578 579 580
  /* 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
581

582
  /* Copy the contents of the args into the result.  */
Jim Blandy's avatar
Jim Blandy committed
583
  if (CONSP (val))
584
    tail = val, toindex = -1; /* -1 in toindex is flag we are making a list */
Jim Blandy's avatar
Jim Blandy committed
585
  else
586
    toindex = 0, toindex_byte = 0;
Jim Blandy's avatar
Jim Blandy committed
587 588

  prev = Qnil;
589
  if (STRINGP (val))
590
    SAFE_NALLOCA (textprops, 1, nargs);
Jim Blandy's avatar
Jim Blandy committed
591 592 593 594

  for (argnum = 0; argnum < nargs; argnum++)
    {
      Lisp_Object thislen;
595 596 597
      ptrdiff_t thisleni = 0;
      register ptrdiff_t thisindex = 0;
      register ptrdiff_t thisindex_byte = 0;
Jim Blandy's avatar
Jim Blandy committed
598 599 600 601 602

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

603 604 605
      /* 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
606
	{
607
	  ptrdiff_t thislen_byte = SBYTES (this);
608

609
	  memcpy (SDATA (val) + toindex_byte, SDATA (this), SBYTES (this));
610
	  if (string_intervals (this))
611
	    {
Kenichi Handa's avatar
Kenichi Handa committed
612
	      textprops[num_textprops].argnum = argnum;
613
	      textprops[num_textprops].from = 0;
Kenichi Handa's avatar
Kenichi Handa committed
614
	      textprops[num_textprops++].to = toindex;
615
	    }
616
	  toindex_byte += thislen_byte;
617
	  toindex += thisleni;
618
	}
619 620 621
      /* Copy a single-byte string to a multibyte string.  */
      else if (STRINGP (this) && STRINGP (val))
	{
622
	  if (string_intervals (this))
623
	    {
Kenichi Handa's avatar
Kenichi Handa committed
624 625 626
	      textprops[num_textprops].argnum = argnum;
	      textprops[num_textprops].from = 0;
	      textprops[num_textprops++].to = toindex;
627
	    }
628 629 630
	  toindex_byte += copy_text (SDATA (this),
				     SDATA (val) + toindex_byte,
				     SCHARS (this), 0, 1);
631 632
	  toindex += thisleni;
	}
633 634 635 636 637 638 639 640 641 642
      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))
643
	      elt = XCAR (this), this = XCDR (this);
644 645 646
	    else if (thisindex >= thisleni)
	      break;
	    else if (STRINGP (this))
647
	      {
648
		int c;
649
		if (STRING_MULTIBYTE (this))
650 651 652
		  FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c, this,
						      thisindex,
						      thisindex_byte);
653
		else
654
		  {
655 656 657
		    c = SREF (this, thisindex); thisindex++;
		    if (some_multibyte && !ASCII_CHAR_P (c))
		      c = BYTE8_TO_CHAR (c);
658
		  }
659
		XSETFASTINT (elt, c);
660 661 662 663
	      }
	    else if (BOOL_VECTOR_P (this))
	      {
		int byte;
664 665
		byte = XBOOL_VECTOR (this)->data[thisindex / BOOL_VECTOR_BITS_PER_CHAR];
		if (byte & (1 << (thisindex % BOOL_VECTOR_BITS_PER_CHAR)))
666
		  elt = Qt;
667
		else
668 669
		  elt = Qnil;
		thisindex++;
670
	      }
671
	    else
672 673 674 675
	      {
		elt = AREF (this, thisindex);
		thisindex++;
	      }
Jim Blandy's avatar
Jim Blandy committed
676

677 678
	    /* Store this element into the result.  */
	    if (toindex < 0)
Jim Blandy's avatar
Jim Blandy committed
679
	      {
680
		XSETCAR (tail, elt);
681
		prev = tail;
682
		tail = XCDR (tail);
Jim Blandy's avatar
Jim Blandy committed
683
	      }
684
	    else if (VECTORP (val))
685 686 687 688
	      {
		ASET (val, toindex, elt);
		toindex++;
	      }
689 690
	    else
	      {
691 692 693
		int c;
		CHECK_CHARACTER (elt);
		c = XFASTINT (elt);
694
		if (some_multibyte)
695
		  toindex_byte += CHAR_STRING (c, SDATA (val) + toindex_byte);
696
		else
697
		  SSET (val, toindex_byte++, c);
698
		toindex++;
699 700
	      }
	  }
Jim Blandy's avatar
Jim Blandy committed
701
    }
Jim Blandy's avatar
Jim Blandy committed
702
  if (!NILP (prev))
703
    XSETCDR (prev, last_tail);
Jim Blandy's avatar
Jim Blandy committed
704

Kenichi Handa's avatar
Kenichi Handa committed
705
  if (num_textprops > 0)
706
    {
707
      Lisp_Object props;
708
      ptrdiff_t last_to_end = -1;
709

Kenichi Handa's avatar
Kenichi Handa committed
710
      for (argnum = 0; argnum < num_textprops; argnum++)
711
	{
Kenichi Handa's avatar
Kenichi Handa committed
712
	  this = args[textprops[argnum].argnum];
713 714
	  props = text_property_list (this,
				      make_number (0),
715
				      make_number (SCHARS (this)),
716
				      Qnil);
Paul Eggert's avatar
Paul Eggert committed
717
	  /* If successive arguments have properties, be sure that the
718
	     value of `composition' property be the copy.  */
719
	  if (last_to_end == textprops[argnum].to)
720 721 722
	    make_composition_value_copy (props);
	  add_text_properties_from_list (val, props,
					 make_number (textprops[argnum].to));
723
	  last_to_end = textprops[argnum].to + SCHARS (this);
724 725
	}
    }
Kim F. Storm's avatar
Kim F. Storm committed
726 727

  SAFE_FREE ();
Karl Heuer's avatar
Karl Heuer committed
728
  return val;
Jim Blandy's avatar
Jim Blandy committed
729 730
}

731
static Lisp_Object string_char_byte_cache_string;
732 733
static ptrdiff_t string_char_byte_cache_charpos;
static ptrdiff_t string_char_byte_cache_bytepos;
734

735
void
736
clear_string_char_byte_cache (void)
737 738 739 740
{
  string_char_byte_cache_string = Qnil;
}

741
/* Return the byte index corresponding to CHAR_INDEX in STRING.  */
742

743 744
ptrdiff_t
string_char_to_byte (Lisp_Object string, ptrdiff_t char_index)
745
{
746 747 748
  ptrdiff_t i_byte;
  ptrdiff_t best_below, best_below_byte;
  ptrdiff_t best_above, best_above_byte;
749

750
  best_below = best_below_byte = 0;
751 752
  best_above = SCHARS (string);
  best_above_byte = SBYTES (string);
753 754
  if (best_above == best_above_byte)
    return char_index;
755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771

  if (EQ (string, string_char_byte_cache_string))
    {
      if (string_char_byte_cache_charpos < char_index)
	{
	  best_below = string_char_byte_cache_charpos;
	  best_below_byte = string_char_byte_cache_bytepos;
	}
      else
	{
	  best_above = string_char_byte_cache_charpos;
	  best_above_byte = string_char_byte_cache_bytepos;
	}
    }

  if (char_index - best_below < best_above - char_index)
    {
Kenichi Handa's avatar
Kenichi Handa committed
772
      unsigned char *p = SDATA (string) + best_below_byte;
773

774 775
      while (best_below < char_index)
	{
776 777
	  p += BYTES_BY_CHAR_HEAD (*p);
	  best_below++;
778
	}
Kenichi Handa's avatar
Kenichi Handa committed
779
      i_byte = p - SDATA (string);
780 781
    }
  else
782
    {
Kenichi Handa's avatar
Kenichi Handa committed
783
      unsigned char *p = SDATA (string) + best_above_byte;
784

785 786
      while (best_above > char_index)
	{
787 788
	  p--;
	  while (!CHAR_HEAD_P (*p)) p--;
789 790
	  best_above--;
	}
Kenichi Handa's avatar
Kenichi Handa committed
791
      i_byte = p - SDATA (string);
792 793
    }

794
  string_char_byte_cache_bytepos = i_byte;
795
  string_char_byte_cache_charpos = char_index;
796 797
  string_char_byte_cache_string = string;

798 799
  return i_byte;
}
800

801 802
/* Return the character index corresponding to BYTE_INDEX in STRING.  */

803 804
ptrdiff_t
string_byte_to_char (Lisp_Object string, ptrdiff_t byte_index)
805
{
Paul Eggert's avatar