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>
Andreas Schwab's avatar
Andreas Schwab committed
27

Jim Blandy's avatar
Jim Blandy committed
28 29 30 31
/* 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 *****
32

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

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

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

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

64 65
extern int minibuffer_auto_raise;
extern Lisp_Object minibuf_window;
66
extern Lisp_Object Vlocale_coding_system;
67
extern int load_in_progress;
68

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

75 76
extern Lisp_Object Qinput_method_function;

77
static int internal_equal P_ ((Lisp_Object , Lisp_Object, int, int));
78 79

extern long get_random ();
80
extern void seed_random P_ ((long));
81 82 83 84

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

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

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

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

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

	  if (!CONSP (sequence))
	    break;

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

170
      CHECK_LIST_END (sequence, sequence);
171 172

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

179
  return val;
Jim Blandy's avatar
Jim Blandy committed
180 181
}

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

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

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

  XSETINT (length, len);
  return length;
}

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

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

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

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

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

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

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

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

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

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

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

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

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

361 362
  i1 = i1_byte = i2 = i2_byte = 0;

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

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

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

      if (c1 != c2)
	return c1 < c2 ? Qt : Qnil;
Jim Blandy's avatar
Jim Blandy committed
378
    }
379
  return i1 < SCHARS (s2) ? Qt : Qnil;
Jim Blandy's avatar
Jim Blandy committed
380 381
}

382 383 384 385
#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
386
static Lisp_Object concat P_ ((int nargs, Lisp_Object *args, enum Lisp_Type target_type, int last_special)) __attribute__((noinline));
387
#else  /* !__GNUC__ */
Stefan Monnier's avatar
Stefan Monnier committed
388
static Lisp_Object concat P_ ((int nargs, Lisp_Object *args, enum Lisp_Type target_type, int last_special));
389
#endif
Jim Blandy's avatar
Jim Blandy committed
390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405

/* 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
406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421
/* 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
422
DEFUN ("append", Fappend, Sappend, 0, MANY, 0,
423
       doc: /* Concatenate all the arguments and make the result a list.
Gerd Moellmann's avatar
Gerd Moellmann committed
424 425
The result is a list whose elements are the elements of all the arguments.
Each argument may be a list, vector or string.
426 427
The last argument is not copied, just used as the tail of the new list.
usage: (append &rest SEQUENCES)  */)
428
     (nargs, args)
Jim Blandy's avatar
Jim Blandy committed
429 430 431 432 433 434 435
     int nargs;
     Lisp_Object *args;
{
  return concat (nargs, args, Lisp_Cons, 1);
}

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

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

459

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

  if (CHAR_TABLE_P (arg))
    {
471
      return copy_char_table (arg);
472 473 474 475 476 477
    }

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

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

487
  if (!CONSP (arg) && !VECTORP (arg) && !STRINGP (arg))
488 489
    wrong_type_argument (Qsequencep, arg);

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

493 494
/* 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
495
struct textprop_rec
496 497 498 499 500 501
{
  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
502 503 504 505 506 507 508 509 510 511 512
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;
513
  int toindex_byte = 0;
514 515
  register int result_len;
  register int result_len_byte;
Jim Blandy's avatar
Jim Blandy committed
516 517 518
  register int argnum;
  Lisp_Object last_tail;
  Lisp_Object prev;
519
  int some_multibyte;
520 521 522 523 524
  /* 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.  */
525
  struct textprop_rec  *textprops = NULL;
Kenichi Handa's avatar
Kenichi Handa committed
526 527
  /* Number of elments in textprops.  */
  int num_textprops = 0;
Kim F. Storm's avatar
Kim F. Storm committed
528
  USE_SAFE_ALLOCA;
Jim Blandy's avatar
Jim Blandy committed
529

530 531
  tail = Qnil;

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

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

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

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

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

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

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

623 624 625
  /* 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
626

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

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

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

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

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

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

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

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

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

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

787 788 789 790 791 792
void
clear_string_char_byte_cache ()
{
  string_char_byte_cache_string = Qnil;
}

793
/* Return the byte index corresponding to CHAR_INDEX in STRING.  */
794

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

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

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

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

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

848
  string_char_byte_cache_bytepos = i_byte;
849
  string_char_byte_cache_charpos = char_index;
850 851
  string_char_byte_cache_string = string;

852 853