fns.c 139 KB
Newer Older
Jim Blandy's avatar
Jim Blandy committed
1
/* Random utility Lisp functions.
2 3
   Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995, 1997,
                 1998, 1999, 2000, 2001, 2002, 2003, 2004,
Glenn Morris's avatar
Glenn Morris committed
4
                 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
Jim Blandy's avatar
Jim Blandy committed
5 6 7

This file is part of GNU Emacs.

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

GNU Emacs is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
19
along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.  */
Jim Blandy's avatar
Jim Blandy committed
20

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

Andreas Schwab's avatar
Andreas Schwab committed
23 24 25
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif
Andreas Schwab's avatar
Andreas Schwab committed
26
#include <time.h>
27
#include <setjmp.h>
Andreas Schwab's avatar
Andreas Schwab committed
28

Jim Blandy's avatar
Jim Blandy committed
29 30 31 32
/* Note on some machines this defines `vector' as a typedef,
   so make sure we don't use that name in this file.  */
#undef vector
#define vector *****
33

Jim Blandy's avatar
Jim Blandy committed
34 35
#include "lisp.h"
#include "commands.h"
36
#include "character.h"
37
#include "coding.h"
Jim Blandy's avatar
Jim Blandy committed
38
#include "buffer.h"
Jim Blandy's avatar
Jim Blandy committed
39
#include "keyboard.h"
Stefan Monnier's avatar
Stefan Monnier committed
40
#include "keymap.h"
41
#include "intervals.h"
42 43
#include "frame.h"
#include "window.h"
Gerd Moellmann's avatar
Gerd Moellmann committed
44
#include "blockinput.h"
45 46
#ifdef HAVE_MENUS
#if defined (HAVE_X_WINDOWS)
Andreas Schwab's avatar
Andreas Schwab committed
47 48
#include "xterm.h"
#endif
Jim Blandy's avatar
Jim Blandy committed
49

Karl Heuer's avatar
Karl Heuer committed
50
#ifndef NULL
51
#define NULL ((POINTER_TYPE *)0)
Karl Heuer's avatar
Karl Heuer committed
52 53
#endif

54 55 56 57
/* Nonzero enables use of dialog boxes for questions
   asked by mouse commands.  */
int use_dialog_box;

Kenichi Handa's avatar
Kenichi Handa committed
58 59 60 61
/* Nonzero enables use of a file dialog for file name
   questions asked by mouse commands.  */
int use_file_dialog;

62 63
extern int minibuffer_auto_raise;
extern Lisp_Object minibuf_window;
64
extern Lisp_Object Vlocale_coding_system;
65
extern int load_in_progress;
66

67
Lisp_Object Qstring_lessp, Qprovide, Qrequire;
68
Lisp_Object Qyes_or_no_p_history;
69
Lisp_Object Qcursor_in_echo_area;
Karl Heuer's avatar
Karl Heuer committed
70
Lisp_Object Qwidget_type;
71
Lisp_Object Qcodeset, Qdays, Qmonths, Qpaper;
Jim Blandy's avatar
Jim Blandy committed
72

73 74
extern Lisp_Object Qinput_method_function;

75
static int internal_equal P_ ((Lisp_Object , Lisp_Object, int, int));
76 77

extern long get_random ();
78
extern void seed_random P_ ((long));
79 80 81 82

#ifndef HAVE_UNISTD_H
extern long time ();
#endif
83

Jim Blandy's avatar
Jim Blandy committed
84
DEFUN ("identity", Fidentity, Sidentity, 1, 1, 0,
Pavel Janík's avatar
Pavel Janík committed
85
       doc: /* Return the argument unchanged.  */)
86
     (arg)
Jim Blandy's avatar
Jim Blandy committed
87 88 89 90 91 92
     Lisp_Object arg;
{
  return arg;
}

DEFUN ("random", Frandom, Srandom, 0, 1, 0,
93
       doc: /* Return a pseudo-random number.
Gerd Moellmann's avatar
Gerd Moellmann committed
94
All integers representable in Lisp are equally likely.
Kenichi Handa's avatar
Kenichi Handa committed
95
  On most systems, this is 29 bits' worth.
96 97 98 99 100
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.  */)
     (limit)
     Lisp_Object limit;
Jim Blandy's avatar
Jim Blandy committed
101
{
102 103
  EMACS_INT val;
  Lisp_Object lispy_val;
104
  unsigned long denominator;
Jim Blandy's avatar
Jim Blandy committed
105

106
  if (EQ (limit, Qt))
107
    seed_random (getpid () + time (NULL));
108
  if (NATNUMP (limit) && XFASTINT (limit) != 0)
Jim Blandy's avatar
Jim Blandy committed
109
    {
110 111 112 113
      /* 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
114
	 it's possible to get a quotient larger than n; discarding
115
	 these values eliminates the bias that would otherwise appear
116
	 when using a large n.  */
117
      denominator = ((unsigned long)1 << VALBITS) / XFASTINT (limit);
118
      do
119
	val = get_random () / denominator;
120
      while (val >= XFASTINT (limit));
Jim Blandy's avatar
Jim Blandy committed
121
    }
122
  else
123
    val = get_random ();
124 125
  XSETINT (lispy_val, val);
  return lispy_val;
Jim Blandy's avatar
Jim Blandy committed
126 127 128 129 130
}

/* Random data-structure functions */

DEFUN ("length", Flength, Slength, 1, 1, 0,
131
       doc: /* Return the length of vector, list or string SEQUENCE.
Gerd Moellmann's avatar
Gerd Moellmann committed
132
A byte-code function object is also allowed.
John Paul Wallington's avatar
John Paul Wallington committed
133
If the string contains multibyte characters, this is not necessarily
Gerd Moellmann's avatar
Gerd Moellmann committed
134
the number of bytes in the string; it is the number of characters.
135
To get the number of bytes, use `string-bytes'.  */)
136
     (sequence)
137
     register Lisp_Object sequence;
Jim Blandy's avatar
Jim Blandy committed
138
{
139
  register Lisp_Object val;
Jim Blandy's avatar
Jim Blandy committed
140 141
  register int i;

142
  if (STRINGP (sequence))
143
    XSETFASTINT (val, SCHARS (sequence));
144
  else if (VECTORP (sequence))
Stefan Monnier's avatar
Stefan Monnier committed
145
    XSETFASTINT (val, ASIZE (sequence));
146
  else if (CHAR_TABLE_P (sequence))
147
    XSETFASTINT (val, MAX_CHAR);
148 149 150
  else if (BOOL_VECTOR_P (sequence))
    XSETFASTINT (val, XBOOL_VECTOR (sequence)->size);
  else if (COMPILEDP (sequence))
Stefan Monnier's avatar
Stefan Monnier committed
151
    XSETFASTINT (val, ASIZE (sequence) & PSEUDOVECTOR_SIZE_MASK);
152
  else if (CONSP (sequence))
Jim Blandy's avatar
Jim Blandy committed
153
    {
154 155
      i = 0;
      while (CONSP (sequence))
Jim Blandy's avatar
Jim Blandy committed
156
	{
157
	  sequence = XCDR (sequence);
158 159 160 161 162 163 164 165
	  ++i;

	  if (!CONSP (sequence))
	    break;

	  sequence = XCDR (sequence);
	  ++i;
	  QUIT;
Jim Blandy's avatar
Jim Blandy committed
166 167
	}

168
      CHECK_LIST_END (sequence, sequence);
169 170

      val = make_number (i);
Jim Blandy's avatar
Jim Blandy committed
171
    }
172
  else if (NILP (sequence))
173
    XSETFASTINT (val, 0);
Jim Blandy's avatar
Jim Blandy committed
174
  else
175
    wrong_type_argument (Qsequencep, sequence);
176

177
  return val;
Jim Blandy's avatar
Jim Blandy committed
178 179
}

180
/* This does not check for quits.  That is safe since it must terminate.  */
181 182

DEFUN ("safe-length", Fsafe_length, Ssafe_length, 1, 1, 0,
183
       doc: /* Return the length of a list, but avoid error or infinite loop.
Gerd Moellmann's avatar
Gerd Moellmann committed
184 185
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
186
which is at least the number of distinct elements.  */)
187
     (list)
188 189 190 191 192 193 194
     Lisp_Object list;
{
  Lisp_Object tail, halftail, length;
  int len = 0;

  /* halftail is used to detect circular lists.  */
  halftail = list;
195
  for (tail = list; CONSP (tail); tail = XCDR (tail))
196 197
    {
      if (EQ (tail, halftail) && len != 0)
198
	break;
199
      len++;
200
      if ((len & 1) == 0)
201
	halftail = XCDR (halftail);
202 203 204 205 206 207
    }

  XSETINT (length, len);
  return length;
}

208
DEFUN ("string-bytes", Fstring_bytes, Sstring_bytes, 1, 1, 0,
209
       doc: /* Return the number of bytes in STRING.
Miles Bader's avatar
Miles Bader committed
210
If STRING is multibyte, this may be greater than the length of STRING.  */)
211
     (string)
212
     Lisp_Object string;
213
{
214
  CHECK_STRING (string);
215
  return make_number (SBYTES (string));
216 217
}

Jim Blandy's avatar
Jim Blandy committed
218
DEFUN ("string-equal", Fstring_equal, Sstring_equal, 2, 2, 0,
219
       doc: /* Return t if two strings have identical contents.
Gerd Moellmann's avatar
Gerd Moellmann committed
220
Case is significant, but text properties are ignored.
221
Symbols are also allowed; their print names are used instead.  */)
222
     (s1, s2)
Jim Blandy's avatar
Jim Blandy committed
223 224
     register Lisp_Object s1, s2;
{
225
  if (SYMBOLP (s1))
226
    s1 = SYMBOL_NAME (s1);
227
  if (SYMBOLP (s2))
228
    s2 = SYMBOL_NAME (s2);
229 230
  CHECK_STRING (s1);
  CHECK_STRING (s2);
Jim Blandy's avatar
Jim Blandy committed
231

232 233 234
  if (SCHARS (s1) != SCHARS (s2)
      || SBYTES (s1) != SBYTES (s2)
      || bcmp (SDATA (s1), SDATA (s2), SBYTES (s1)))
Jim Blandy's avatar
Jim Blandy committed
235 236 237 238
    return Qnil;
  return Qt;
}

239
DEFUN ("compare-strings", Fcompare_strings,
240
       Scompare_strings, 6, 7, 0,
241
doc: /* Compare the contents of two strings, converting to multibyte if needed.
Gerd Moellmann's avatar
Gerd Moellmann committed
242 243 244 245 246 247 248 249 250 251 252
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;
253
  N - 1 is the number of characters that match at the beginning.  */)
254
     (str1, start1, end1, str2, start2, end2, ignore_case)
255 256 257 258 259
     Lisp_Object str1, start1, end1, start2, str2, end2, ignore_case;
{
  register int end1_char, end2_char;
  register int i1, i1_byte, i2, i2_byte;

260 261
  CHECK_STRING (str1);
  CHECK_STRING (str2);
262 263 264 265
  if (NILP (start1))
    start1 = make_number (0);
  if (NILP (start2))
    start2 = make_number (0);
266 267
  CHECK_NATNUM (start1);
  CHECK_NATNUM (start2);
268
  if (! NILP (end1))
269
    CHECK_NATNUM (end1);
270
  if (! NILP (end2))
271
    CHECK_NATNUM (end2);
272 273 274 275 276 277 278

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

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

279
  end1_char = SCHARS (str1);
280 281 282
  if (! NILP (end1) && end1_char > XINT (end1))
    end1_char = XINT (end1);

283
  end2_char = SCHARS (str2);
284 285 286 287 288 289 290 291 292 293
  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))
294
	FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1, str1, i1, i1_byte);
295 296
      else
	{
297
	  c1 = SREF (str1, i1++);
298
	  MAKE_CHAR_MULTIBYTE (c1);
299 300 301
	}

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

      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)
329
	return make_number (- i1 + XINT (start1));
330
      else
331
	return make_number (i1 - XINT (start1));
332 333 334 335 336 337 338 339 340 341
    }

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

  return Qt;
}

Jim Blandy's avatar
Jim Blandy committed
342
DEFUN ("string-lessp", Fstring_lessp, Sstring_lessp, 2, 2, 0,
343
       doc: /* Return t if first arg string is less than second in lexicographic order.
Gerd Moellmann's avatar
Gerd Moellmann committed
344
Case is significant.
345
Symbols are also allowed; their print names are used instead.  */)
346
     (s1, s2)
Jim Blandy's avatar
Jim Blandy committed
347 348 349
     register Lisp_Object s1, s2;
{
  register int end;
350
  register int i1, i1_byte, i2, i2_byte;
Jim Blandy's avatar
Jim Blandy committed
351

352
  if (SYMBOLP (s1))
353
    s1 = SYMBOL_NAME (s1);
354
  if (SYMBOLP (s2))
355
    s2 = SYMBOL_NAME (s2);
356 357
  CHECK_STRING (s1);
  CHECK_STRING (s2);
Jim Blandy's avatar
Jim Blandy committed
358

359 360
  i1 = i1_byte = i2 = i2_byte = 0;

361 362 363
  end = SCHARS (s1);
  if (end > SCHARS (s2))
    end = SCHARS (s2);
Jim Blandy's avatar
Jim Blandy committed
364

365
  while (i1 < end)
Jim Blandy's avatar
Jim Blandy committed
366
    {
367 368 369 370
      /* When we find a mismatch, we must compare the
	 characters, not just the bytes.  */
      int c1, c2;

371 372
      FETCH_STRING_CHAR_ADVANCE (c1, s1, i1, i1_byte);
      FETCH_STRING_CHAR_ADVANCE (c2, s2, i2, i2_byte);
373 374 375

      if (c1 != c2)
	return c1 < c2 ? Qt : Qnil;
Jim Blandy's avatar
Jim Blandy committed
376
    }
377
  return i1 < SCHARS (s2) ? Qt : Qnil;
Jim Blandy's avatar
Jim Blandy committed
378 379
}

380 381 382 383
#if __GNUC__
/* "gcc -O3" enables automatic function inlining, which optimizes out
   the arguments for the invocations of this function, whereas it
   expects these values on the stack.  */
Stefan Monnier's avatar
Stefan Monnier committed
384
static Lisp_Object concat P_ ((int nargs, Lisp_Object *args, enum Lisp_Type target_type, int last_special)) __attribute__((noinline));
385
#else  /* !__GNUC__ */
Stefan Monnier's avatar
Stefan Monnier committed
386
static Lisp_Object concat P_ ((int nargs, Lisp_Object *args, enum Lisp_Type target_type, int last_special));
387
#endif
Jim Blandy's avatar
Jim Blandy committed
388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403

/* ARGSUSED */
Lisp_Object
concat2 (s1, s2)
     Lisp_Object s1, s2;
{
#ifdef NO_ARG_ARRAY
  Lisp_Object args[2];
  args[0] = s1;
  args[1] = s2;
  return concat (2, args, Lisp_String, 0);
#else
  return concat (2, &s1, Lisp_String, 0);
#endif /* NO_ARG_ARRAY */
}

Richard M. Stallman's avatar
Richard M. Stallman committed
404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419
/* ARGSUSED */
Lisp_Object
concat3 (s1, s2, s3)
     Lisp_Object s1, s2, s3;
{
#ifdef NO_ARG_ARRAY
  Lisp_Object args[3];
  args[0] = s1;
  args[1] = s2;
  args[2] = s3;
  return concat (3, args, Lisp_String, 0);
#else
  return concat (3, &s1, Lisp_String, 0);
#endif /* NO_ARG_ARRAY */
}

Jim Blandy's avatar
Jim Blandy committed
420
DEFUN ("append", Fappend, Sappend, 0, MANY, 0,
421
       doc: /* Concatenate all the arguments and make the result a list.
Gerd Moellmann's avatar
Gerd Moellmann committed
422 423
The result is a list whose elements are the elements of all the arguments.
Each argument may be a list, vector or string.
424 425
The last argument is not copied, just used as the tail of the new list.
usage: (append &rest SEQUENCES)  */)
426
     (nargs, args)
Jim Blandy's avatar
Jim Blandy committed
427 428 429 430 431 432 433
     int nargs;
     Lisp_Object *args;
{
  return concat (nargs, args, Lisp_Cons, 1);
}

DEFUN ("concat", Fconcat, Sconcat, 0, MANY, 0,
434
       doc: /* Concatenate all the arguments and make the result a string.
Gerd Moellmann's avatar
Gerd Moellmann committed
435
The result is a string whose elements are the elements of all the arguments.
436 437
Each argument may be a string or a list or vector of characters (integers).
usage: (concat &rest SEQUENCES)  */)
438
     (nargs, args)
Jim Blandy's avatar
Jim Blandy committed
439 440 441 442 443 444 445
     int nargs;
     Lisp_Object *args;
{
  return concat (nargs, args, Lisp_String, 0);
}

DEFUN ("vconcat", Fvconcat, Svconcat, 0, MANY, 0,
446
       doc: /* Concatenate all the arguments and make the result a vector.
Gerd Moellmann's avatar
Gerd Moellmann committed
447
The result is a vector whose elements are the elements of all the arguments.
448 449
Each argument may be a list, vector or string.
usage: (vconcat &rest SEQUENCES)   */)
450
     (nargs, args)
Jim Blandy's avatar
Jim Blandy committed
451 452 453
     int nargs;
     Lisp_Object *args;
{
454
  return concat (nargs, args, Lisp_Vectorlike, 0);
Jim Blandy's avatar
Jim Blandy committed
455 456
}

457

Jim Blandy's avatar
Jim Blandy committed
458
DEFUN ("copy-sequence", Fcopy_sequence, Scopy_sequence, 1, 1, 0,
Dave Love's avatar
Dave Love committed
459
       doc: /* Return a copy of a list, vector, string or char-table.
Gerd Moellmann's avatar
Gerd Moellmann committed
460
The elements of a list or vector are not copied; they are shared
461
with the original.  */)
462
     (arg)
Jim Blandy's avatar
Jim Blandy committed
463 464
     Lisp_Object arg;
{
Jim Blandy's avatar
Jim Blandy committed
465
  if (NILP (arg)) return arg;
466 467 468

  if (CHAR_TABLE_P (arg))
    {
469
      return copy_char_table (arg);
470 471 472 473 474 475
    }

  if (BOOL_VECTOR_P (arg))
    {
      Lisp_Object val;
      int size_in_chars
476 477
	= ((XBOOL_VECTOR (arg)->size + BOOL_VECTOR_BITS_PER_CHAR - 1)
	   / BOOL_VECTOR_BITS_PER_CHAR);
478 479 480 481 482 483 484

      val = Fmake_bool_vector (Flength (arg), Qnil);
      bcopy (XBOOL_VECTOR (arg)->data, XBOOL_VECTOR (val)->data,
	     size_in_chars);
      return val;
    }

485
  if (!CONSP (arg) && !VECTORP (arg) && !STRINGP (arg))
486 487
    wrong_type_argument (Qsequencep, arg);

Jim Blandy's avatar
Jim Blandy committed
488 489 490
  return concat (1, &arg, CONSP (arg) ? Lisp_Cons : XTYPE (arg), 0);
}

491 492
/* 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
493
struct textprop_rec
494 495 496 497 498 499
{
  int argnum;			/* refer to ARGS (arguments of `concat') */
  int from;			/* refer to ARGS[argnum] (argument string) */
  int to;			/* refer to VAL (the target string) */
};

Jim Blandy's avatar
Jim Blandy committed
500 501 502 503 504 505 506 507 508 509 510
static Lisp_Object
concat (nargs, args, target_type, last_special)
     int nargs;
     Lisp_Object *args;
     enum Lisp_Type target_type;
     int last_special;
{
  Lisp_Object val;
  register Lisp_Object tail;
  register Lisp_Object this;
  int toindex;
511
  int toindex_byte = 0;
512 513
  register int result_len;
  register int result_len_byte;
Jim Blandy's avatar
Jim Blandy committed
514 515 516
  register int argnum;
  Lisp_Object last_tail;
  Lisp_Object prev;
517
  int some_multibyte;
518 519 520 521 522
  /* When we make a multibyte string, we can't copy text properties
     while concatinating each string because the length of resulting
     string can't be decided until we finish the whole concatination.
     So, we record strings that have text properties to be copied
     here, and copy the text properties after the concatination.  */
523
  struct textprop_rec  *textprops = NULL;
Kenichi Handa's avatar
Kenichi Handa committed
524 525
  /* Number of elments in textprops.  */
  int num_textprops = 0;
Kim F. Storm's avatar
Kim F. Storm committed
526
  USE_SAFE_ALLOCA;
Jim Blandy's avatar
Jim Blandy committed
527

528 529
  tail = Qnil;

Jim Blandy's avatar
Jim Blandy committed
530 531 532 533 534 535 536 537 538
  /* 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;

539
  /* Check each argument.  */
Jim Blandy's avatar
Jim Blandy committed
540 541 542
  for (argnum = 0; argnum < nargs; argnum++)
    {
      this = args[argnum];
543
      if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
544
	    || COMPILEDP (this) || BOOL_VECTOR_P (this)))
545
	wrong_type_argument (Qsequencep, this);
Jim Blandy's avatar
Jim Blandy committed
546 547
    }

548 549 550 551 552 553 554 555
  /* 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
556
    {
557
      int len;
Jim Blandy's avatar
Jim Blandy committed
558
      this = args[argnum];
559 560
      len = XFASTINT (Flength (this));
      if (target_type == Lisp_String)
561
	{
562 563
	  /* We must count the number of bytes needed in the string
	     as well as the number of characters.  */
564 565
	  int i;
	  Lisp_Object ch;
566
	  int this_len_byte;
567

568
	  if (VECTORP (this))
569
	    for (i = 0; i < len; i++)
570
	      {
Stefan Monnier's avatar
Stefan Monnier committed
571
		ch = AREF (this, i);
Miles Bader's avatar
Miles Bader committed
572
		CHECK_CHARACTER (ch);
573
		this_len_byte = CHAR_BYTES (XINT (ch));
574
		result_len_byte += this_len_byte;
575
		if (! ASCII_CHAR_P (XINT (ch)) && ! CHAR_BYTE8_P (XINT (ch)))
576
		  some_multibyte = 1;
577
	      }
578 579
	  else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size > 0)
	    wrong_type_argument (Qintegerp, Faref (this, make_number (0)));
580
	  else if (CONSP (this))
581
	    for (; CONSP (this); this = XCDR (this))
582
	      {
583
		ch = XCAR (this);
Miles Bader's avatar
Miles Bader committed
584
		CHECK_CHARACTER (ch);
585
		this_len_byte = CHAR_BYTES (XINT (ch));
586
		result_len_byte += this_len_byte;
587
		if (! ASCII_CHAR_P (XINT (ch)) && ! CHAR_BYTE8_P (XINT (ch)))
588
		  some_multibyte = 1;
589
	      }
590
	  else if (STRINGP (this))
591
	    {
592
	      if (STRING_MULTIBYTE (this))
593 594
		{
		  some_multibyte = 1;
595
		  result_len_byte += SBYTES (this);
596 597
		}
	      else
598 599
		result_len_byte += count_size_as_multibyte (SDATA (this),
							    SCHARS (this));
600
	    }
601
	}
602 603

      result_len += len;
604 605
      if (result_len < 0)
	error ("String overflow");
Jim Blandy's avatar
Jim Blandy committed
606 607
    }

608 609
  if (! some_multibyte)
    result_len_byte = result_len;
Jim Blandy's avatar
Jim Blandy committed
610

611
  /* Create the output object.  */
Jim Blandy's avatar
Jim Blandy committed
612
  if (target_type == Lisp_Cons)
613
    val = Fmake_list (make_number (result_len), Qnil);
614
  else if (target_type == Lisp_Vectorlike)
615
    val = Fmake_vector (make_number (result_len), Qnil);
616
  else if (some_multibyte)
617
    val = make_uninit_multibyte_string (result_len, result_len_byte);
618 619
  else
    val = make_uninit_string (result_len);
Jim Blandy's avatar
Jim Blandy committed
620

621 622 623
  /* 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
624

625
  /* Copy the contents of the args into the result.  */
Jim Blandy's avatar
Jim Blandy committed
626
  if (CONSP (val))
627
    tail = val, toindex = -1; /* -1 in toindex is flag we are making a list */
Jim Blandy's avatar
Jim Blandy committed
628
  else
629
    toindex = 0, toindex_byte = 0;
Jim Blandy's avatar
Jim Blandy committed
630 631

  prev = Qnil;
632
  if (STRINGP (val))
Kim F. Storm's avatar
Kim F. Storm committed
633
    SAFE_ALLOCA (textprops, struct textprop_rec *, sizeof (struct textprop_rec) * nargs);
Jim Blandy's avatar
Jim Blandy committed
634 635 636 637

  for (argnum = 0; argnum < nargs; argnum++)
    {
      Lisp_Object thislen;
638
      int thisleni = 0;
639
      register unsigned int thisindex = 0;
640
      register unsigned int thisindex_byte = 0;
Jim Blandy's avatar
Jim Blandy committed
641 642 643 644 645

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

646 647 648
      /* 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
649
	{
650
	  int thislen_byte = SBYTES (this);
651

652 653 654
	  bcopy (SDATA (this), SDATA (val) + toindex_byte,
		 SBYTES (this));
	  if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
655
	    {
Kenichi Handa's avatar
Kenichi Handa committed
656
	      textprops[num_textprops].argnum = argnum;
657
	      textprops[num_textprops].from = 0;
Kenichi Handa's avatar
Kenichi Handa committed
658
	      textprops[num_textprops++].to = toindex;
659
	    }
660
	  toindex_byte += thislen_byte;
661
	  toindex += thisleni;
662
	}
663 664 665
      /* Copy a single-byte string to a multibyte string.  */
      else if (STRINGP (this) && STRINGP (val))
	{
666
	  if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
667
	    {
Kenichi Handa's avatar
Kenichi Handa committed
668 669 670
	      textprops[num_textprops].argnum = argnum;
	      textprops[num_textprops].from = 0;
	      textprops[num_textprops++].to = toindex;
671
	    }
672 673 674
	  toindex_byte += copy_text (SDATA (this),
				     SDATA (val) + toindex_byte,
				     SCHARS (this), 0, 1);
675 676
	  toindex += thisleni;
	}
677 678 679 680 681 682 683 684 685 686
      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))
687
	      elt = XCAR (this), this = XCDR (this);
688 689 690
	    else if (thisindex >= thisleni)
	      break;
	    else if (STRINGP (this))
691
	      {
692
		int c;
693
		if (STRING_MULTIBYTE (this))
694
		  {
695 696 697
		    FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c, this,
							thisindex,
							thisindex_byte);
698
		    XSETFASTINT (elt, c);
699
		  }
700
		else
701
		  {
702
		    XSETFASTINT (elt, SREF (this, thisindex)); thisindex++;
703
		    if (some_multibyte
704
			&& !ASCII_CHAR_P (XINT (elt))
705 706
			&& XINT (elt) < 0400)
		      {
707
			c = BYTE8_TO_CHAR (XINT (elt));
708 709
			XSETINT (elt, c);
		      }
710
		  }
711 712 713 714
	      }
	    else if (BOOL_VECTOR_P (this))
	      {
		int byte;
715 716
		byte = XBOOL_VECTOR (this)->data[thisindex / BOOL_VECTOR_BITS_PER_CHAR];
		if (byte & (1 << (thisindex % BOOL_VECTOR_BITS_PER_CHAR)))
717
		  elt = Qt;
718
		else
719 720
		  elt = Qnil;
		thisindex++;
721
	      }
722
	    else
723 724 725 726
	      {
		elt = AREF (this, thisindex);
		thisindex++;
	      }
Jim Blandy's avatar
Jim Blandy committed
727

728 729
	    /* Store this element into the result.  */
	    if (toindex < 0)
Jim Blandy's avatar
Jim Blandy committed
730
	      {
731
		XSETCAR (tail, elt);
732
		prev = tail;
733
		tail = XCDR (tail);
Jim Blandy's avatar
Jim Blandy committed
734
	      }
735
	    else if (VECTORP (val))
736 737 738 739
	      {
		ASET (val, toindex, elt);
		toindex++;
	      }
740 741
	    else
	      {
742
		CHECK_NUMBER (elt);
743
		if (some_multibyte)
Kenichi Handa's avatar
Kenichi Handa committed
744 745
		  toindex_byte += CHAR_STRING (XINT (elt),
					       SDATA (val) + toindex_byte);
746
		else
Kenichi Handa's avatar
Kenichi Handa committed
747
		  SSET (val, toindex_byte++, XINT (elt));
748
		toindex++;
749 750
	      }
	  }
Jim Blandy's avatar
Jim Blandy committed
751
    }
Jim Blandy's avatar
Jim Blandy committed
752
  if (!NILP (prev))
753
    XSETCDR (prev, last_tail);
Jim Blandy's avatar
Jim Blandy committed
754

Kenichi Handa's avatar
Kenichi Handa committed
755
  if (num_textprops > 0)
756
    {
757
      Lisp_Object props;
758
      int last_to_end = -1;
759

Kenichi Handa's avatar
Kenichi Handa committed
760
      for (argnum = 0; argnum < num_textprops; argnum++)
761
	{
Kenichi Handa's avatar
Kenichi Handa committed
762
	  this = args[textprops[argnum].argnum];
763 764
	  props = text_property_list (this,
				      make_number (0),
765
				      make_number (SCHARS (this)),
766 767 768
				      Qnil);
	  /* If successive arguments have properites, be sure that the
	     value of `composition' property be the copy.  */
769
	  if (last_to_end == textprops[argnum].to)
770 771 772
	    make_composition_value_copy (props);
	  add_text_properties_from_list (val, props,
					 make_number (textprops[argnum].to));
773
	  last_to_end = textprops[argnum].to + SCHARS (this);
774 775
	}
    }
Kim F. Storm's avatar
Kim F. Storm committed
776 777

  SAFE_FREE ();
Karl Heuer's avatar
Karl Heuer committed
778
  return val;
Jim Blandy's avatar
Jim Blandy committed
779 780
}

781
static Lisp_Object string_char_byte_cache_string;
782 783
static EMACS_INT string_char_byte_cache_charpos;
static EMACS_INT string_char_byte_cache_bytepos;
784

785 786 787 788 789 790
void
clear_string_char_byte_cache ()
{
  string_char_byte_cache_string = Qnil;
}

791
/* Return the byte index corresponding to CHAR_INDEX in STRING.  */
792

793
EMACS_INT
794 795
string_char_to_byte (string, char_index)
     Lisp_Object string;
796
     EMACS_INT char_index;
797
{
798 799 800
  EMACS_INT i_byte;
  EMACS_INT best_below, best_below_byte;
  EMACS_INT best_above, best_above_byte;
801

802
  best_below = best_below_byte = 0;
803 804
  best_above = SCHARS (string);
  best_above_byte = SBYTES (string);
805 806
  if (best_above == best_above_byte)
    return char_index;
807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823

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

826 827
      while (best_below < char_index)
	{
828 829
	  p += BYTES_BY_CHAR_HEAD (*p);
	  best_below++;
830
	}
Kenichi Handa's avatar
Kenichi Handa committed
831
      i_byte = p - SDATA (string);
832 833
    }
  else
834
    {
Kenichi Handa's avatar
Kenichi Handa committed
835
      unsigned char *p = SDATA (string) + best_above_byte;
836

837 838
      while (best_above > char_index)
	{
839 840
	  p--;
	  while (!CHAR_HEAD_P (*p)) p--;
841 842
	  best_above--;
	}
Kenichi Handa's avatar
Kenichi Handa committed
843
      i_byte = p - SDATA (string);
844 845
    }

846
  string_char_byte_cache_bytepos = i_byte;
847
  string_char_byte_cache_charpos = char_index;
848 849
  string_char_byte_cache_string = string;