fns.c 134 KB
Newer Older
Jim Blandy's avatar
Jim Blandy committed
1
/* Random utility Lisp functions.
2
   Copyright (C) 1985-1987, 1993-1995, 1997-2011
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

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

Karl Heuer's avatar
Karl Heuer committed
43
#ifndef NULL
44
#define NULL ((POINTER_TYPE *)0)
Karl Heuer's avatar
Karl Heuer committed
45 46
#endif

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

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;
78
  EMACS_UINT denominator;
Jim Blandy's avatar
Jim Blandy committed
79

80
  if (EQ (limit, Qt))
81
    seed_random (getpid () + time (NULL));
82
  if (NATNUMP (limit) && XFASTINT (limit) != 0)
Jim Blandy's avatar
Jim Blandy committed
83
    {
84 85 86 87
      /* 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
88
	 it's possible to get a quotient larger than n; discarding
89
	 these values eliminates the bias that would otherwise appear
90
	 when using a large n.  */
91
      denominator = ((EMACS_UINT) 1 << VALBITS) / XFASTINT (limit);
92
      do
93
	val = get_random () / denominator;
94
      while (val >= XFASTINT (limit));
Jim Blandy's avatar
Jim Blandy committed
95
    }
96
  else
97
    val = get_random ();
98 99
  XSETINT (lispy_val, val);
  return lispy_val;
Jim Blandy's avatar
Jim Blandy committed
100 101
}

102 103 104 105
/* 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
106 107
/* Random data-structure functions */

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

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

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

145
      CHECK_LIST_END (sequence, sequence);
146 147

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

154
  return val;
Jim Blandy's avatar
Jim Blandy committed
155 156
}

157
/* This does not check for quits.  That is safe since it must terminate.  */
158 159

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

  if (! CONSP (list))
171
    return make_number (0);
172 173

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

194 195 196 197
  /* 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);
198 199
}

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

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

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

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

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

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

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

267
  end1_char = SCHARS (str1);
268 269 270
  if (! NILP (end1) && end1_char > XINT (end1))
    end1_char = XINT (end1);

271
  end2_char = SCHARS (str2);
272 273 274 275 276 277 278 279 280 281
  if (! NILP (end2) && end2_char > XINT (end2))
    end2_char = XINT (end2);

  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))
282
	FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1, str1, i1, i1_byte);
283 284
      else
	{
285
	  c1 = SREF (str1, i1++);
286
	  MAKE_CHAR_MULTIBYTE (c1);
287 288 289
	}

      if (STRING_MULTIBYTE (str2))
290
	FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2, str2, i2, i2_byte);
291 292
      else
	{
293
	  c2 = SREF (str2, i2++);
294
	  MAKE_CHAR_MULTIBYTE (c2);
295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316
	}

      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)
317
	return make_number (- i1 + XINT (start1));
318
      else
319
	return make_number (i1 - XINT (start1));
320 321 322 323 324 325 326 327 328 329
    }

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

339
  if (SYMBOLP (s1))
340
    s1 = SYMBOL_NAME (s1);
341
  if (SYMBOLP (s2))
342
    s2 = SYMBOL_NAME (s2);
343 344
  CHECK_STRING (s1);
  CHECK_STRING (s2);
Jim Blandy's avatar
Jim Blandy committed
345

346 347
  i1 = i1_byte = i2 = i2_byte = 0;

348 349 350
  end = SCHARS (s1);
  if (end > SCHARS (s2))
    end = SCHARS (s2);
Jim Blandy's avatar
Jim Blandy committed
351

352
  while (i1 < end)
Jim Blandy's avatar
Jim Blandy committed
353
    {
354 355 356 357
      /* When we find a mismatch, we must compare the
	 characters, not just the bytes.  */
      int c1, c2;

358 359
      FETCH_STRING_CHAR_ADVANCE (c1, s1, i1, i1_byte);
      FETCH_STRING_CHAR_ADVANCE (c2, s2, i2, i2_byte);
360 361 362

      if (c1 != c2)
	return c1 < c2 ? Qt : Qnil;
Jim Blandy's avatar
Jim Blandy committed
363
    }
364
  return i1 < SCHARS (s2) ? Qt : Qnil;
Jim Blandy's avatar
Jim Blandy committed
365 366
}

367
static Lisp_Object concat (ptrdiff_t nargs, Lisp_Object *args,
368
			   enum Lisp_Type target_type, int last_special);
Jim Blandy's avatar
Jim Blandy committed
369 370 371

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

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

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

422

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

  if (CHAR_TABLE_P (arg))
    {
433
      return copy_char_table (arg);
434 435 436 437 438
    }

  if (BOOL_VECTOR_P (arg))
    {
      Lisp_Object val;
439
      ptrdiff_t size_in_chars
440 441
	= ((XBOOL_VECTOR (arg)->size + BOOL_VECTOR_BITS_PER_CHAR - 1)
	   / BOOL_VECTOR_BITS_PER_CHAR);
442 443

      val = Fmake_bool_vector (Flength (arg), Qnil);
444 445
      memcpy (XBOOL_VECTOR (val)->data, XBOOL_VECTOR (arg)->data,
	      size_in_chars);
446 447 448
      return val;
    }

449
  if (!CONSP (arg) && !VECTORP (arg) && !STRINGP (arg))
450 451
    wrong_type_argument (Qsequencep, arg);

Jim Blandy's avatar
Jim Blandy committed
452 453 454
  return concat (1, &arg, CONSP (arg) ? Lisp_Cons : XTYPE (arg), 0);
}

455 456
/* 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
457
struct textprop_rec
458
{
459
  ptrdiff_t argnum;		/* refer to ARGS (arguments of `concat') */
460 461
  EMACS_INT from;		/* refer to ARGS[argnum] (argument string) */
  EMACS_INT to;			/* refer to VAL (the target string) */
462 463
};

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

489 490
  tail = Qnil;

Jim Blandy's avatar
Jim Blandy committed
491 492 493 494 495 496 497 498 499
  /* 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;

500
  /* Check each argument.  */
Jim Blandy's avatar
Jim Blandy committed
501 502 503
  for (argnum = 0; argnum < nargs; argnum++)
    {
      this = args[argnum];
504
      if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
Stefan Monnier's avatar
Stefan Monnier committed
505
	    || COMPILEDP (this) || BOOL_VECTOR_P (this)))
506
	wrong_type_argument (Qsequencep, this);
Jim Blandy's avatar
Jim Blandy committed
507 508
    }

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

Stefan Monnier's avatar
Stefan Monnier committed
530
	  if (VECTORP (this) || COMPILEDP (this))
531
	    for (i = 0; i < len; i++)
532
	      {
Stefan Monnier's avatar
Stefan Monnier committed
533
		ch = AREF (this, i);
Miles Bader's avatar
Miles Bader committed
534
		CHECK_CHARACTER (ch);
535 536
		c = XFASTINT (ch);
		this_len_byte = CHAR_BYTES (c);
537
		result_len_byte += this_len_byte;
538
		if (! ASCII_CHAR_P (c) && ! CHAR_BYTE8_P (c))
539
		  some_multibyte = 1;
540
	      }
541 542
	  else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size > 0)
	    wrong_type_argument (Qintegerp, Faref (this, make_number (0)));
543
	  else if (CONSP (this))
544
	    for (; CONSP (this); this = XCDR (this))
545
	      {
546
		ch = XCAR (this);
Miles Bader's avatar
Miles Bader committed
547
		CHECK_CHARACTER (ch);
548 549
		c = XFASTINT (ch);
		this_len_byte = CHAR_BYTES (c);
550
		result_len_byte += this_len_byte;
551
		if (! ASCII_CHAR_P (c) && ! CHAR_BYTE8_P (c))
552
		  some_multibyte = 1;
553
	      }
554
	  else if (STRINGP (this))
555
	    {
556
	      if (STRING_MULTIBYTE (this))
557 558
		{
		  some_multibyte = 1;
559
		  result_len_byte += SBYTES (this);
560 561
		}
	      else
562 563
		result_len_byte += count_size_as_multibyte (SDATA (this),
							    SCHARS (this));
564
	    }
565
	}
566 567

      result_len += len;
568 569
      if (result_len < 0)
	error ("String overflow");
Jim Blandy's avatar
Jim Blandy committed
570 571
    }

572 573
  if (! some_multibyte)
    result_len_byte = result_len;
Jim Blandy's avatar
Jim Blandy committed
574

575
  /* Create the output object.  */
Jim Blandy's avatar
Jim Blandy committed
576
  if (target_type == Lisp_Cons)
577
    val = Fmake_list (make_number (result_len), Qnil);
578
  else if (target_type == Lisp_Vectorlike)
579
    val = Fmake_vector (make_number (result_len), Qnil);
580
  else if (some_multibyte)
581
    val = make_uninit_multibyte_string (result_len, result_len_byte);
582 583
  else
    val = make_uninit_string (result_len);
Jim Blandy's avatar
Jim Blandy committed
584

585 586 587
  /* 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
588

589
  /* Copy the contents of the args into the result.  */
Jim Blandy's avatar
Jim Blandy committed
590
  if (CONSP (val))
591
    tail = val, toindex = -1; /* -1 in toindex is flag we are making a list */
Jim Blandy's avatar
Jim Blandy committed
592
  else
593
    toindex = 0, toindex_byte = 0;
Jim Blandy's avatar
Jim Blandy committed
594 595

  prev = Qnil;
596
  if (STRINGP (val))
Kim F. Storm's avatar
Kim F. Storm committed
597
    SAFE_ALLOCA (textprops, struct textprop_rec *, sizeof (struct textprop_rec) * nargs);
Jim Blandy's avatar
Jim Blandy committed
598 599 600 601

  for (argnum = 0; argnum < nargs; argnum++)
    {
      Lisp_Object thislen;
602 603 604
      EMACS_INT thisleni = 0;
      register EMACS_INT thisindex = 0;
      register EMACS_INT thisindex_byte = 0;
Jim Blandy's avatar
Jim Blandy committed
605 606 607 608 609

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

610 611 612
      /* 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
613
	{
614
	  EMACS_INT thislen_byte = SBYTES (this);
615

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

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

Kenichi Handa's avatar
Kenichi Handa committed
712
  if (num_textprops > 0)
713
    {
714
      Lisp_Object props;
715
      EMACS_INT last_to_end = -1;
716

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

  SAFE_FREE ();
Karl Heuer's avatar
Karl Heuer committed
735
  return val;
Jim Blandy's avatar
Jim Blandy committed
736 737
}

738
static Lisp_Object string_char_byte_cache_string;
739 740
static EMACS_INT string_char_byte_cache_charpos;
static EMACS_INT string_char_byte_cache_bytepos;
741

742
void
743
clear_string_char_byte_cache (void)
744 745 746 747
{
  string_char_byte_cache_string = Qnil;
}

748
/* Return the byte index corresponding to CHAR_INDEX in STRING.  */
749

750
EMACS_INT
751
string_char_to_byte (Lisp_Object string, EMACS_INT char_index)
752
{
753 754 755
  EMACS_INT i_byte;
  EMACS_INT best_below, best_below_byte;
  EMACS_INT best_above, best_above_byte;
756

757
  best_below = best_below_byte = 0;
758 759
  best_above = SCHARS (string);
  best_above_byte = SBYTES (string);
760 761
  if (best_above == best_above_byte)
    return char_index;
762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778

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

781 782
      while (best_below < char_index)
	{
783 784
	  p += BYTES_BY_CHAR_HEAD (*p);
	  best_below++;
785
	}
Kenichi Handa's avatar
Kenichi Handa committed
786
      i_byte = p - SDATA (string);
787 788
    }
  else
789
    {
Kenichi Handa's avatar
Kenichi Handa committed
790
      unsigned char *p = SDATA (string) + best_above_byte;
791

792 793
      while (best_above > char_index)
	{
794 795
	  p--;
	  while (!CHAR_HEAD_P (*p)) p--;
796 797
	  best_above--;
	}
Kenichi Handa's avatar
Kenichi Handa committed
798
      i_byte = p - SDATA (string);
799 800
    }

801
  string_char_byte_cache_bytepos = i_byte;
802
  string_char_byte_cache_charpos = char_index;