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>
24
#include <setjmp.h>
Andreas Schwab's avatar
Andreas Schwab committed
25

26 27
#include <intprops.h>

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

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

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

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

DEFUN ("random", Frandom, Srandom, 0, 1, 0,
64
       doc: /* Return a pseudo-random number.
Gerd Moellmann's avatar
Gerd Moellmann committed
65
All integers representable in Lisp are equally likely.
Kenichi Handa's avatar
Kenichi Handa committed
66
  On most systems, this is 29 bits' worth.
67 68 69
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
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
  if (NATNUMP (limit) && XFASTINT (limit) != 0)
81 82
    val %= XFASTINT (limit);
  return make_number (val);
Jim Blandy's avatar
Jim Blandy committed
83 84
}

85 86 87 88
/* 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
89 90
/* Random data-structure functions */

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

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

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

128
      CHECK_LIST_END (sequence, sequence);
129 130

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

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

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

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

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

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

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

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

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

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

Paul Eggert's avatar
Paul Eggert committed
212
DEFUN ("compare-strings", Fcompare_strings, Scompare_strings, 6, 7, 0,
Juanma Barranquero's avatar
Juanma Barranquero committed
213
       doc: /* Compare the contents of two strings, converting to multibyte if needed.
Gerd Moellmann's avatar
Gerd Moellmann committed
214 215 216 217 218 219 220 221 222 223 224
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;
225
  N - 1 is the number of characters that match at the beginning.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
226
  (Lisp_Object str1, Lisp_Object start1, Lisp_Object end1, Lisp_Object str2, Lisp_Object start2, Lisp_Object end2, Lisp_Object ignore_case)
227
{
228 229
  register ptrdiff_t end1_char, end2_char;
  register ptrdiff_t i1, i1_byte, i2, i2_byte;
230

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

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

250
  end2_char = SCHARS (str2);
251 252
  if (! NILP (end2) && end2_char > XINT (end2))
    end2_char = XINT (end2);
253 254 255 256 257 258 259 260
  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);
261 262 263 264 265 266 267 268

  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))
269
	FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1, str1, i1, i1_byte);
270 271
      else
	{
272
	  c1 = SREF (str1, i1++);
273
	  MAKE_CHAR_MULTIBYTE (c1);
274 275 276
	}

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

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

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

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

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

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

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

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

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

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

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

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

409

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

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

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

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

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

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

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

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

476 477
  tail = Qnil;

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

  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
773
      unsigned char *p = SDATA (string) + best_below_byte;
774

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

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

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

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

804 805
ptrdiff_t
string_byte_to_char (Lisp_Object string, ptrdiff_t byte_index)
806
{