fns.c 136 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 56 57 58

#ifndef HAVE_UNISTD_H
extern long time ();
#endif
59

Paul Eggert's avatar
Paul Eggert committed
60
DEFUN ("identity", Fidentity, Sidentity, 1, 1, 0,
Pavel Janík's avatar
Pavel Janík committed
61
       doc: /* Return the argument unchanged.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
62
  (Lisp_Object arg)
Jim Blandy's avatar
Jim Blandy committed
63 64 65 66 67
{
  return arg;
}

DEFUN ("random", Frandom, Srandom, 0, 1, 0,
68
       doc: /* Return a pseudo-random number.
Gerd Moellmann's avatar
Gerd Moellmann committed
69
All integers representable in Lisp are equally likely.
Kenichi Handa's avatar
Kenichi Handa committed
70
  On most systems, this is 29 bits' worth.
71 72 73
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
74
  (Lisp_Object limit)
Jim Blandy's avatar
Jim Blandy committed
75
{
76 77
  EMACS_INT val;
  Lisp_Object lispy_val;
Jim Blandy's avatar
Jim Blandy committed
78

79
  if (EQ (limit, Qt))
80
    {
81
      EMACS_TIME t = current_emacs_time ();
82
      seed_random (getpid () ^ EMACS_SECS (t) ^ EMACS_NSECS (t));
83 84
    }

85
  if (NATNUMP (limit) && XFASTINT (limit) != 0)
Jim Blandy's avatar
Jim Blandy committed
86
    {
87 88 89 90
      /* Try to take our random number from the higher bits of VAL,
	 not the lower, since (says Gentzel) the low bits of `random'
	 are less random than the higher ones.  We do this by using the
	 quotient rather than the remainder.  At the high end of the RNG
91
	 it's possible to get a quotient larger than n; discarding
92
	 these values eliminates the bias that would otherwise appear
93
	 when using a large n.  */
94
      EMACS_INT denominator = (INTMASK + 1) / XFASTINT (limit);
95
      do
96
	val = get_random () / denominator;
97
      while (val >= XFASTINT (limit));
Jim Blandy's avatar
Jim Blandy committed
98
    }
99
  else
100
    val = get_random ();
101 102
  XSETINT (lispy_val, val);
  return lispy_val;
Jim Blandy's avatar
Jim Blandy committed
103 104
}

105 106 107 108
/* 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
109 110
/* Random data-structure functions */

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

121
  if (STRINGP (sequence))
122
    XSETFASTINT (val, SCHARS (sequence));
123
  else if (VECTORP (sequence))
Stefan Monnier's avatar
Stefan Monnier committed
124
    XSETFASTINT (val, ASIZE (sequence));
125
  else if (CHAR_TABLE_P (sequence))
126
    XSETFASTINT (val, MAX_CHAR);
127 128
  else if (BOOL_VECTOR_P (sequence))
    XSETFASTINT (val, XBOOL_VECTOR (sequence)->size);
Stefan Monnier's avatar
Stefan Monnier committed
129 130
  else if (COMPILEDP (sequence))
    XSETFASTINT (val, ASIZE (sequence) & PSEUDOVECTOR_SIZE_MASK);
131
  else if (CONSP (sequence))
Jim Blandy's avatar
Jim Blandy committed
132
    {
133 134 135
      EMACS_INT i = 0;

      do
Jim Blandy's avatar
Jim Blandy committed
136
	{
137
	  ++i;
138
	  if ((i & (QUIT_COUNT_HEURISTIC - 1)) == 0)
139 140 141 142 143
	    {
	      if (MOST_POSITIVE_FIXNUM < i)
		error ("List too long");
	      QUIT;
	    }
144
	  sequence = XCDR (sequence);
Jim Blandy's avatar
Jim Blandy committed
145
	}
146
      while (CONSP (sequence));
Jim Blandy's avatar
Jim Blandy committed
147

148
      CHECK_LIST_END (sequence, sequence);
149 150

      val = make_number (i);
Jim Blandy's avatar
Jim Blandy committed
151
    }
152
  else if (NILP (sequence))
153
    XSETFASTINT (val, 0);
Jim Blandy's avatar
Jim Blandy committed
154
  else
155
    wrong_type_argument (Qsequencep, sequence);
156

157
  return val;
Jim Blandy's avatar
Jim Blandy committed
158 159
}

160
/* This does not check for quits.  That is safe since it must terminate.  */
161 162

DEFUN ("safe-length", Fsafe_length, Ssafe_length, 1, 1, 0,
163
       doc: /* Return the length of a list, but avoid error or infinite loop.
Gerd Moellmann's avatar
Gerd Moellmann committed
164 165
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
166
which is at least the number of distinct elements.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
167
  (Lisp_Object list)
168
{
169 170 171 172 173
  Lisp_Object tail, halftail;
  double hilen = 0;
  uintmax_t lolen = 1;

  if (! CONSP (list))
174
    return make_number (0);
175 176

  /* halftail is used to detect circular lists.  */
177
  for (tail = halftail = list; ; )
178
    {
179 180
      tail = XCDR (tail);
      if (! CONSP (tail))
181
	break;
182 183 184 185 186 187 188 189 190 191 192 193 194
      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;
	    }
	}
195 196
    }

197 198 199 200
  /* 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);
201 202
}

203
DEFUN ("string-bytes", Fstring_bytes, Sstring_bytes, 1, 1, 0,
204
       doc: /* Return the number of bytes in STRING.
Miles Bader's avatar
Miles Bader committed
205
If STRING is multibyte, this may be greater than the length of STRING.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
206
  (Lisp_Object string)
207
{
208
  CHECK_STRING (string);
209
  return make_number (SBYTES (string));
210 211
}

Paul Eggert's avatar
Paul Eggert committed
212
DEFUN ("string-equal", Fstring_equal, Sstring_equal, 2, 2, 0,
213
       doc: /* Return t if two strings have identical contents.
Gerd Moellmann's avatar
Gerd Moellmann committed
214
Case is significant, but text properties are ignored.
215
Symbols are also allowed; their print names are used instead.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
216
  (register Lisp_Object s1, Lisp_Object s2)
Jim Blandy's avatar
Jim Blandy committed
217
{
218
  if (SYMBOLP (s1))
219
    s1 = SYMBOL_NAME (s1);
220
  if (SYMBOLP (s2))
221
    s2 = SYMBOL_NAME (s2);
222 223
  CHECK_STRING (s1);
  CHECK_STRING (s2);
Jim Blandy's avatar
Jim Blandy committed
224

225 226
  if (SCHARS (s1) != SCHARS (s2)
      || SBYTES (s1) != SBYTES (s2)
227
      || memcmp (SDATA (s1), SDATA (s2), SBYTES (s1)))
Jim Blandy's avatar
Jim Blandy committed
228 229 230 231
    return Qnil;
  return Qt;
}

Paul Eggert's avatar
Paul Eggert committed
232
DEFUN ("compare-strings", Fcompare_strings, Scompare_strings, 6, 7, 0,
Juanma Barranquero's avatar
Juanma Barranquero committed
233
       doc: /* Compare the contents of two strings, converting to multibyte if needed.
Gerd Moellmann's avatar
Gerd Moellmann committed
234 235 236 237 238 239 240 241 242 243 244
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;
245
  N - 1 is the number of characters that match at the beginning.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
246
  (Lisp_Object str1, Lisp_Object start1, Lisp_Object end1, Lisp_Object str2, Lisp_Object start2, Lisp_Object end2, Lisp_Object ignore_case)
247
{
248 249
  register ptrdiff_t end1_char, end2_char;
  register ptrdiff_t i1, i1_byte, i2, i2_byte;
250

251 252
  CHECK_STRING (str1);
  CHECK_STRING (str2);
253 254 255 256
  if (NILP (start1))
    start1 = make_number (0);
  if (NILP (start2))
    start2 = make_number (0);
257 258
  CHECK_NATNUM (start1);
  CHECK_NATNUM (start2);
259
  if (! NILP (end1))
260
    CHECK_NATNUM (end1);
261
  if (! NILP (end2))
262
    CHECK_NATNUM (end2);
263

264
  end1_char = SCHARS (str1);
265 266
  if (! NILP (end1) && end1_char > XINT (end1))
    end1_char = XINT (end1);
267 268
  if (end1_char < XINT (start1))
    args_out_of_range (str1, start1);
269

270
  end2_char = SCHARS (str2);
271 272
  if (! NILP (end2) && end2_char > XINT (end2))
    end2_char = XINT (end2);
273 274 275 276 277 278 279 280
  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);
281 282 283 284 285 286 287 288

  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))
289
	FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1, str1, i1, i1_byte);
290 291
      else
	{
292
	  c1 = SREF (str1, i1++);
293
	  MAKE_CHAR_MULTIBYTE (c1);
294 295 296
	}

      if (STRING_MULTIBYTE (str2))
297
	FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2, str2, i2, i2_byte);
298 299
      else
	{
300
	  c2 = SREF (str2, i2++);
301
	  MAKE_CHAR_MULTIBYTE (c2);
302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323
	}

      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)
324
	return make_number (- i1 + XINT (start1));
325
      else
326
	return make_number (i1 - XINT (start1));
327 328 329 330 331 332 333 334 335 336
    }

  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
337
DEFUN ("string-lessp", Fstring_lessp, Sstring_lessp, 2, 2, 0,
338
       doc: /* Return t if first arg string is less than second in lexicographic order.
Gerd Moellmann's avatar
Gerd Moellmann committed
339
Case is significant.
340
Symbols are also allowed; their print names are used instead.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
341
  (register Lisp_Object s1, Lisp_Object s2)
Jim Blandy's avatar
Jim Blandy committed
342
{
343 344
  register ptrdiff_t end;
  register ptrdiff_t i1, i1_byte, i2, i2_byte;
Jim Blandy's avatar
Jim Blandy committed
345

346
  if (SYMBOLP (s1))
347
    s1 = SYMBOL_NAME (s1);
348
  if (SYMBOLP (s2))
349
    s2 = SYMBOL_NAME (s2);
350 351
  CHECK_STRING (s1);
  CHECK_STRING (s2);
Jim Blandy's avatar
Jim Blandy committed
352

353 354
  i1 = i1_byte = i2 = i2_byte = 0;

355 356 357
  end = SCHARS (s1);
  if (end > SCHARS (s2))
    end = SCHARS (s2);
Jim Blandy's avatar
Jim Blandy committed
358

359
  while (i1 < end)
Jim Blandy's avatar
Jim Blandy committed
360
    {
361 362 363 364
      /* When we find a mismatch, we must compare the
	 characters, not just the bytes.  */
      int c1, c2;

365 366
      FETCH_STRING_CHAR_ADVANCE (c1, s1, i1, i1_byte);
      FETCH_STRING_CHAR_ADVANCE (c2, s2, i2, i2_byte);
367 368 369

      if (c1 != c2)
	return c1 < c2 ? Qt : Qnil;
Jim Blandy's avatar
Jim Blandy committed
370
    }
371
  return i1 < SCHARS (s2) ? Qt : Qnil;
Jim Blandy's avatar
Jim Blandy committed
372 373
}

374
static Lisp_Object concat (ptrdiff_t nargs, Lisp_Object *args,
375
			   enum Lisp_Type target_type, int last_special);
Jim Blandy's avatar
Jim Blandy committed
376 377 378

/* ARGSUSED */
Lisp_Object
379
concat2 (Lisp_Object s1, Lisp_Object s2)
Jim Blandy's avatar
Jim Blandy committed
380 381 382 383 384 385 386
{
  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
387 388
/* ARGSUSED */
Lisp_Object
389
concat3 (Lisp_Object s1, Lisp_Object s2, Lisp_Object s3)
Richard M. Stallman's avatar
Richard M. Stallman committed
390 391 392 393 394 395 396 397
{
  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
398
DEFUN ("append", Fappend, Sappend, 0, MANY, 0,
399
       doc: /* Concatenate all the arguments and make the result a list.
Gerd Moellmann's avatar
Gerd Moellmann committed
400 401
The result is a list whose elements are the elements of all the arguments.
Each argument may be a list, vector or string.
402 403
The last argument is not copied, just used as the tail of the new list.
usage: (append &rest SEQUENCES)  */)
404
  (ptrdiff_t nargs, Lisp_Object *args)
Jim Blandy's avatar
Jim Blandy committed
405 406 407 408
{
  return concat (nargs, args, Lisp_Cons, 1);
}

Paul Eggert's avatar
Paul Eggert committed
409
DEFUN ("concat", Fconcat, Sconcat, 0, MANY, 0,
410
       doc: /* Concatenate all the arguments and make the result a string.
Gerd Moellmann's avatar
Gerd Moellmann committed
411
The result is a string whose elements are the elements of all the arguments.
412 413
Each argument may be a string or a list or vector of characters (integers).
usage: (concat &rest SEQUENCES)  */)
414
  (ptrdiff_t nargs, Lisp_Object *args)
Jim Blandy's avatar
Jim Blandy committed
415 416 417 418
{
  return concat (nargs, args, Lisp_String, 0);
}

Paul Eggert's avatar
Paul Eggert committed
419
DEFUN ("vconcat", Fvconcat, Svconcat, 0, MANY, 0,
420
       doc: /* Concatenate all the arguments and make the result a vector.
Gerd Moellmann's avatar
Gerd Moellmann committed
421
The result is a vector whose elements are the elements of all the arguments.
422 423
Each argument may be a list, vector or string.
usage: (vconcat &rest SEQUENCES)   */)
424
  (ptrdiff_t nargs, Lisp_Object *args)
Jim Blandy's avatar
Jim Blandy committed
425
{
426
  return concat (nargs, args, Lisp_Vectorlike, 0);
Jim Blandy's avatar
Jim Blandy committed
427 428
}

429

Paul Eggert's avatar
Paul Eggert committed
430
DEFUN ("copy-sequence", Fcopy_sequence, Scopy_sequence, 1, 1, 0,
Dave Love's avatar
Dave Love committed
431
       doc: /* Return a copy of a list, vector, string or char-table.
Gerd Moellmann's avatar
Gerd Moellmann committed
432
The elements of a list or vector are not copied; they are shared
433
with the original.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
434
  (Lisp_Object arg)
Jim Blandy's avatar
Jim Blandy committed
435
{
Jim Blandy's avatar
Jim Blandy committed
436
  if (NILP (arg)) return arg;
437 438 439

  if (CHAR_TABLE_P (arg))
    {
440
      return copy_char_table (arg);
441 442 443 444 445
    }

  if (BOOL_VECTOR_P (arg))
    {
      Lisp_Object val;
446
      ptrdiff_t size_in_chars
447 448
	= ((XBOOL_VECTOR (arg)->size + BOOL_VECTOR_BITS_PER_CHAR - 1)
	   / BOOL_VECTOR_BITS_PER_CHAR);
449 450

      val = Fmake_bool_vector (Flength (arg), Qnil);
451 452
      memcpy (XBOOL_VECTOR (val)->data, XBOOL_VECTOR (arg)->data,
	      size_in_chars);
453 454 455
      return val;
    }

456
  if (!CONSP (arg) && !VECTORP (arg) && !STRINGP (arg))
457 458
    wrong_type_argument (Qsequencep, arg);

Jim Blandy's avatar
Jim Blandy committed
459 460 461
  return concat (1, &arg, CONSP (arg) ? Lisp_Cons : XTYPE (arg), 0);
}

462 463
/* 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
464
struct textprop_rec
465
{
466
  ptrdiff_t argnum;		/* refer to ARGS (arguments of `concat') */
467 468
  ptrdiff_t from;		/* refer to ARGS[argnum] (argument string) */
  ptrdiff_t to;			/* refer to VAL (the target string) */
469 470
};

Jim Blandy's avatar
Jim Blandy committed
471
static Lisp_Object
472
concat (ptrdiff_t nargs, Lisp_Object *args,
473
	enum Lisp_Type target_type, int last_special)
Jim Blandy's avatar
Jim Blandy committed
474 475 476 477
{
  Lisp_Object val;
  register Lisp_Object tail;
  register Lisp_Object this;
478 479
  ptrdiff_t toindex;
  ptrdiff_t toindex_byte = 0;
480 481
  register EMACS_INT result_len;
  register EMACS_INT result_len_byte;
482
  ptrdiff_t argnum;
Jim Blandy's avatar
Jim Blandy committed
483 484
  Lisp_Object last_tail;
  Lisp_Object prev;
485
  int some_multibyte;
486
  /* When we make a multibyte string, we can't copy text properties
Paul Eggert's avatar
Paul Eggert committed
487 488
     while concatenating each string because the length of resulting
     string can't be decided until we finish the whole concatenation.
489
     So, we record strings that have text properties to be copied
Paul Eggert's avatar
Paul Eggert committed
490
     here, and copy the text properties after the concatenation.  */
491
  struct textprop_rec  *textprops = NULL;
Juanma Barranquero's avatar
Juanma Barranquero committed
492
  /* Number of elements in textprops.  */
493
  ptrdiff_t num_textprops = 0;
Kim F. Storm's avatar
Kim F. Storm committed
494
  USE_SAFE_ALLOCA;
Jim Blandy's avatar
Jim Blandy committed
495

496 497
  tail = Qnil;

Jim Blandy's avatar
Jim Blandy committed
498 499 500 501 502 503 504 505 506
  /* 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;

507
  /* Check each argument.  */
Jim Blandy's avatar
Jim Blandy committed
508 509 510
  for (argnum = 0; argnum < nargs; argnum++)
    {
      this = args[argnum];
511
      if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
Stefan Monnier's avatar
Stefan Monnier committed
512
	    || COMPILEDP (this) || BOOL_VECTOR_P (this)))
513
	wrong_type_argument (Qsequencep, this);
Jim Blandy's avatar
Jim Blandy committed
514 515
    }

516 517 518 519 520 521 522 523
  /* 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
524
    {
525
      EMACS_INT len;
Jim Blandy's avatar
Jim Blandy committed
526
      this = args[argnum];
527 528
      len = XFASTINT (Flength (this));
      if (target_type == Lisp_String)
529
	{
530 531
	  /* We must count the number of bytes needed in the string
	     as well as the number of characters.  */
532
	  ptrdiff_t i;
533
	  Lisp_Object ch;
534
	  int c;
535
	  ptrdiff_t this_len_byte;
536

Stefan Monnier's avatar
Stefan Monnier committed
537
	  if (VECTORP (this) || COMPILEDP (this))
538
	    for (i = 0; i < len; i++)
539
	      {
Stefan Monnier's avatar
Stefan Monnier committed
540
		ch = AREF (this, i);
Miles Bader's avatar
Miles Bader committed
541
		CHECK_CHARACTER (ch);
542 543
		c = XFASTINT (ch);
		this_len_byte = CHAR_BYTES (c);
544 545
		if (STRING_BYTES_BOUND - result_len_byte < this_len_byte)
		  string_overflow ();
546
		result_len_byte += this_len_byte;
547
		if (! ASCII_CHAR_P (c) && ! CHAR_BYTE8_P (c))
548
		  some_multibyte = 1;
549
	      }
550 551
	  else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size > 0)
	    wrong_type_argument (Qintegerp, Faref (this, make_number (0)));
552
	  else if (CONSP (this))
553
	    for (; CONSP (this); this = XCDR (this))
554
	      {
555
		ch = XCAR (this);
Miles Bader's avatar
Miles Bader committed
556
		CHECK_CHARACTER (ch);
557 558
		c = XFASTINT (ch);
		this_len_byte = CHAR_BYTES (c);
559 560
		if (STRING_BYTES_BOUND - result_len_byte < this_len_byte)
		  string_overflow ();
561
		result_len_byte += this_len_byte;
562
		if (! ASCII_CHAR_P (c) && ! CHAR_BYTE8_P (c))
563
		  some_multibyte = 1;
564
	      }
565
	  else if (STRINGP (this))
566
	    {
567
	      if (STRING_MULTIBYTE (this))
568 569
		{
		  some_multibyte = 1;
570
		  this_len_byte = SBYTES (this);
571 572
		}
	      else
573 574 575 576 577
		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;
578
	    }
579
	}
580 581

      result_len += len;
582 583
      if (MOST_POSITIVE_FIXNUM < result_len)
	memory_full (SIZE_MAX);
Jim Blandy's avatar
Jim Blandy committed
584 585
    }

586 587
  if (! some_multibyte)
    result_len_byte = result_len;
Jim Blandy's avatar
Jim Blandy committed
588

589
  /* Create the output object.  */
Jim Blandy's avatar
Jim Blandy committed
590
  if (target_type == Lisp_Cons)
591
    val = Fmake_list (make_number (result_len), Qnil);
592
  else if (target_type == Lisp_Vectorlike)
593
    val = Fmake_vector (make_number (result_len), Qnil);
594
  else if (some_multibyte)
595
    val = make_uninit_multibyte_string (result_len, result_len_byte);
596 597
  else
    val = make_uninit_string (result_len);
Jim Blandy's avatar
Jim Blandy committed
598

599 600 601
  /* 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
602

603
  /* Copy the contents of the args into the result.  */
Jim Blandy's avatar
Jim Blandy committed
604
  if (CONSP (val))
605
    tail = val, toindex = -1; /* -1 in toindex is flag we are making a list */
Jim Blandy's avatar
Jim Blandy committed
606
  else
607
    toindex = 0, toindex_byte = 0;
Jim Blandy's avatar
Jim Blandy committed
608 609

  prev = Qnil;
610
  if (STRINGP (val))
611
    SAFE_NALLOCA (textprops, 1, nargs);
Jim Blandy's avatar
Jim Blandy committed
612 613 614 615

  for (argnum = 0; argnum < nargs; argnum++)
    {
      Lisp_Object thislen;
616 617 618
      ptrdiff_t thisleni = 0;
      register ptrdiff_t thisindex = 0;
      register ptrdiff_t thisindex_byte = 0;
Jim Blandy's avatar
Jim Blandy committed
619 620 621 622 623

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

624 625 626
      /* 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
627
	{
628
	  ptrdiff_t thislen_byte = SBYTES (this);
629

630
	  memcpy (SDATA (val) + toindex_byte, SDATA (this), SBYTES (this));
631
	  if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
632
	    {
Kenichi Handa's avatar
Kenichi Handa committed
633
	      textprops[num_textprops].argnum = argnum;
634
	      textprops[num_textprops].from = 0;
Kenichi Handa's avatar
Kenichi Handa committed
635
	      textprops[num_textprops++].to = toindex;
636
	    }
637
	  toindex_byte += thislen_byte;
638
	  toindex += thisleni;
639
	}
640 641 642
      /* Copy a single-byte string to a multibyte string.  */
      else if (STRINGP (this) && STRINGP (val))
	{
643
	  if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
644
	    {
Kenichi Handa's avatar
Kenichi Handa committed
645 646 647
	      textprops[num_textprops].argnum = argnum;
	      textprops[num_textprops].from = 0;
	      textprops[num_textprops++].to = toindex;
648
	    }
649 650 651
	  toindex_byte += copy_text (SDATA (this),
				     SDATA (val) + toindex_byte,
				     SCHARS (this), 0, 1);
652 653
	  toindex += thisleni;
	}
654 655 656 657 658 659 660 661 662 663
      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))
664
	      elt = XCAR (this), this = XCDR (this);
665 666 667
	    else if (thisindex >= thisleni)
	      break;
	    else if (STRINGP (this))
668
	      {
669
		int c;
670
		if (STRING_MULTIBYTE (this))
671 672 673
		  FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c, this,
						      thisindex,
						      thisindex_byte);
674
		else
675
		  {
676 677 678
		    c = SREF (this, thisindex); thisindex++;
		    if (some_multibyte && !ASCII_CHAR_P (c))
		      c = BYTE8_TO_CHAR (c);
679
		  }
680
		XSETFASTINT (elt, c);
681 682 683 684
	      }
	    else if (BOOL_VECTOR_P (this))
	      {
		int byte;
685 686
		byte = XBOOL_VECTOR (this)->data[thisindex / BOOL_VECTOR_BITS_PER_CHAR];
		if (byte & (1 << (thisindex % BOOL_VECTOR_BITS_PER_CHAR)))
687
		  elt = Qt;
688
		else
689 690
		  elt = Qnil;
		thisindex++;
691
	      }
692
	    else
693 694 695 696
	      {
		elt = AREF (this, thisindex);
		thisindex++;
	      }
Jim Blandy's avatar
Jim Blandy committed
697

698 699
	    /* Store this element into the result.  */
	    if (toindex < 0)
Jim Blandy's avatar
Jim Blandy committed
700
	      {
701
		XSETCAR (tail, elt);
702
		prev = tail;
703
		tail = XCDR (tail);
Jim Blandy's avatar
Jim Blandy committed
704
	      }
705
	    else if (VECTORP (val))
706 707 708 709
	      {
		ASET (val, toindex, elt);
		toindex++;
	      }
710 711
	    else
	      {
712 713 714
		int c;
		CHECK_CHARACTER (elt);
		c = XFASTINT (elt);
715
		if (some_multibyte)
716
		  toindex_byte += CHAR_STRING (c, SDATA (val) + toindex_byte);
717
		else
718
		  SSET (val, toindex_byte++, c);
719
		toindex++;
720 721
	      }
	  }
Jim Blandy's avatar
Jim Blandy committed
722
    }
Jim Blandy's avatar
Jim Blandy committed
723
  if (!NILP (prev))
724
    XSETCDR (prev, last_tail);
Jim Blandy's avatar
Jim Blandy committed
725

Kenichi Handa's avatar
Kenichi Handa committed
726
  if (num_textprops > 0)
727
    {
728
      Lisp_Object props;
729
      ptrdiff_t last_to_end = -1;
730

Kenichi Handa's avatar
Kenichi Handa committed
731
      for (argnum = 0; argnum < num_textprops; argnum++)
732
	{
Kenichi Handa's avatar
Kenichi Handa committed
733
	  this = args[textprops[argnum].argnum];
734 735
	  props = text_property_list (this,
				      make_number (0),
736
				      make_number (SCHARS (this)),
737
				      Qnil);
Paul Eggert's avatar
Paul Eggert committed
738
	  /* If successive arguments have properties, be sure that the
739
	     value of `composition' property be the copy.  */
740
	  if (last_to_end == textprops[argnum].to)
741 742 743
	    make_composition_value_copy (props);
	  add_text_properties_from_list (val, props,
					 make_number (textprops[argnum].to));
744
	  last_to_end = textprops[argnum].to + SCHARS (this);
745 746
	}
    }
Kim F. Storm's avatar
Kim F. Storm committed
747 748

  SAFE_FREE ();
Karl Heuer's avatar
Karl Heuer committed
749
  return val;
Jim Blandy's avatar
Jim Blandy committed
750 751
}

752
static Lisp_Object string_char_byte_cache_string;
753 754
static ptrdiff_t string_char_byte_cache_charpos;
static ptrdiff_t string_char_byte_cache_bytepos;
755

756
void
757
clear_string_char_byte_cache (void)
758 759 760 761
{
  string_char_byte_cache_string = Qnil;
}

762
/* Return the byte index corresponding to CHAR_INDEX in STRING.  */
763

764 765
ptrdiff_t
string_char_to_byte (Lisp_Object string, ptrdiff_t char_index)
766
{
767 768 769
  ptrdiff_t i_byte;
  ptrdiff_t best_below, best_below_byte;
  ptrdiff_t best_above, best_above_byte;
770

771
  best_below = best_below_byte = 0;
772 773
  best_above = SCHARS (string);
  best_above_byte = SBYTES (string);
774 775
  if (best_above == best_above_byte)
    return char_index;
776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792

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

795 796
      while (best_below < char_index)
	{
797 798
	  p += BYTES_BY_CHAR_HEAD (*p);
	  best_below++;
799
	}
Kenichi Handa's avatar
Kenichi Handa committed
800
      i_byte = p - SDATA (string);
801 802
    }
  else
803
    {
Kenichi Handa's avatar
Kenichi Handa committed
804
      unsigned char *p = SDATA (string) + best_above_byte;