fns.c 132 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 28 29
/* 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 *****
30

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

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

52
Lisp_Object Qstring_lessp, Qprovide, Qrequire;
53
Lisp_Object Qyes_or_no_p_history;
54
Lisp_Object Qcursor_in_echo_area;
Karl Heuer's avatar
Karl Heuer committed
55
Lisp_Object Qwidget_type;
56
Lisp_Object Qcodeset, Qdays, Qmonths, Qpaper;
Jim Blandy's avatar
Jim Blandy committed
57

58
static int internal_equal (Lisp_Object , Lisp_Object, int, int);
59

60
extern long get_random (void);
61
extern void seed_random (long);
62 63 64 65

#ifndef HAVE_UNISTD_H
extern long time ();
#endif
66

Jim Blandy's avatar
Jim Blandy committed
67
DEFUN ("identity", Fidentity, Sidentity, 1, 1, 0,
Pavel Janík's avatar
Pavel Janík committed
68
       doc: /* Return the argument unchanged.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
69
  (Lisp_Object arg)
Jim Blandy's avatar
Jim Blandy committed
70 71 72 73 74
{
  return arg;
}

DEFUN ("random", Frandom, Srandom, 0, 1, 0,
75
       doc: /* Return a pseudo-random number.
Gerd Moellmann's avatar
Gerd Moellmann committed
76
All integers representable in Lisp are equally likely.
Kenichi Handa's avatar
Kenichi Handa committed
77
  On most systems, this is 29 bits' worth.
78 79 80
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
81
  (Lisp_Object limit)
Jim Blandy's avatar
Jim Blandy committed
82
{
83 84
  EMACS_INT val;
  Lisp_Object lispy_val;
85
  unsigned long denominator;
Jim Blandy's avatar
Jim Blandy committed
86

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

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

122
  if (STRINGP (sequence))
123
    XSETFASTINT (val, SCHARS (sequence));
124
  else if (VECTORP (sequence))
Stefan Monnier's avatar
Stefan Monnier committed
125
    XSETFASTINT (val, ASIZE (sequence));
126
  else if (CHAR_TABLE_P (sequence))
127
    XSETFASTINT (val, MAX_CHAR);
128 129
  else if (BOOL_VECTOR_P (sequence))
    XSETFASTINT (val, XBOOL_VECTOR (sequence)->size);
130 131
  else if (FUNVECP (sequence))
    XSETFASTINT (val, FUNVEC_SIZE (sequence));
132
  else if (CONSP (sequence))
Jim Blandy's avatar
Jim Blandy committed
133
    {
134 135
      i = 0;
      while (CONSP (sequence))
Jim Blandy's avatar
Jim Blandy committed
136
	{
137
	  sequence = XCDR (sequence);
138 139 140 141 142 143 144 145
	  ++i;

	  if (!CONSP (sequence))
	    break;

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

148
      CHECK_LIST_END (sequence, sequence);
149 150

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

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

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

DEFUN ("safe-length", Fsafe_length, Ssafe_length, 1, 1, 0,
163
       doc: /* Return the length of a list, but avoid error or infinite loop.
Gerd Moellmann's avatar
Gerd Moellmann committed
164 165
This function never gets an error.  If LIST is not really a list,
it returns 0.  If LIST is circular, it returns a finite value
166
which is at least the number of distinct elements.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
167
  (Lisp_Object list)
168 169 170 171 172 173
{
  Lisp_Object tail, halftail, length;
  int len = 0;

  /* halftail is used to detect circular lists.  */
  halftail = list;
174
  for (tail = list; CONSP (tail); tail = XCDR (tail))
175 176
    {
      if (EQ (tail, halftail) && len != 0)
177
	break;
178
      len++;
179
      if ((len & 1) == 0)
180
	halftail = XCDR (halftail);
181 182 183 184 185 186
    }

  XSETINT (length, len);
  return length;
}

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

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

209 210
  if (SCHARS (s1) != SCHARS (s2)
      || SBYTES (s1) != SBYTES (s2)
211
      || memcmp (SDATA (s1), SDATA (s2), SBYTES (s1)))
Jim Blandy's avatar
Jim Blandy committed
212 213 214 215
    return Qnil;
  return Qt;
}

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

235 236
  CHECK_STRING (str1);
  CHECK_STRING (str2);
237 238 239 240
  if (NILP (start1))
    start1 = make_number (0);
  if (NILP (start2))
    start2 = make_number (0);
241 242
  CHECK_NATNUM (start1);
  CHECK_NATNUM (start2);
243
  if (! NILP (end1))
244
    CHECK_NATNUM (end1);
245
  if (! NILP (end2))
246
    CHECK_NATNUM (end2);
247 248 249 250 251 252 253

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

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

254
  end1_char = SCHARS (str1);
255 256 257
  if (! NILP (end1) && end1_char > XINT (end1))
    end1_char = XINT (end1);

258
  end2_char = SCHARS (str2);
259 260 261 262 263 264 265 266 267 268
  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))
269
	FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1, str1, i1, i1_byte);
270 271
      else
	{
272
	  c1 = SREF (str1, i1++);
273
	  MAKE_CHAR_MULTIBYTE (c1);
274 275 276
	}

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

      if (c1 == c2)
	continue;

      if (! NILP (ignore_case))
	{
	  Lisp_Object tem;

	  tem = Fupcase (make_number (c1));
	  c1 = XINT (tem);
	  tem = Fupcase (make_number (c2));
	  c2 = XINT (tem);
	}

      if (c1 == c2)
	continue;

      /* Note that I1 has already been incremented
	 past the character that we are comparing;
	 hence we don't add or subtract 1 here.  */
      if (c1 < c2)
304
	return make_number (- i1 + XINT (start1));
305
      else
306
	return make_number (i1 - XINT (start1));
307 308 309 310 311 312 313 314 315 316
    }

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

  return Qt;
}

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

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

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

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

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

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

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

/* ARGSUSED */
Lisp_Object
359
concat2 (Lisp_Object s1, Lisp_Object s2)
Jim Blandy's avatar
Jim Blandy committed
360 361 362 363 364 365 366
{
  Lisp_Object args[2];
  args[0] = s1;
  args[1] = s2;
  return concat (2, args, Lisp_String, 0);
}

Richard M. Stallman's avatar
Richard M. Stallman committed
367 368
/* ARGSUSED */
Lisp_Object
369
concat3 (Lisp_Object s1, Lisp_Object s2, Lisp_Object s3)
Richard M. Stallman's avatar
Richard M. Stallman committed
370 371 372 373 374 375 376 377
{
  Lisp_Object args[3];
  args[0] = s1;
  args[1] = s2;
  args[2] = s3;
  return concat (3, args, Lisp_String, 0);
}

Jim Blandy's avatar
Jim Blandy committed
378
DEFUN ("append", Fappend, Sappend, 0, MANY, 0,
379
       doc: /* Concatenate all the arguments and make the result a list.
Gerd Moellmann's avatar
Gerd Moellmann committed
380 381
The result is a list whose elements are the elements of all the arguments.
Each argument may be a list, vector or string.
382 383
The last argument is not copied, just used as the tail of the new list.
usage: (append &rest SEQUENCES)  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
384
  (int nargs, Lisp_Object *args)
Jim Blandy's avatar
Jim Blandy committed
385 386 387 388 389
{
  return concat (nargs, args, Lisp_Cons, 1);
}

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

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

409

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

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

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

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

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

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

442 443
/* This structure holds information of an argument of `concat' that is
   a string and has text properties to be copied.  */
Kenichi Handa's avatar
Kenichi Handa committed
444
struct textprop_rec
445 446
{
  int argnum;			/* refer to ARGS (arguments of `concat') */
447 448
  EMACS_INT from;		/* refer to ARGS[argnum] (argument string) */
  EMACS_INT to;			/* refer to VAL (the target string) */
449 450
};

Jim Blandy's avatar
Jim Blandy committed
451
static Lisp_Object
452
concat (int nargs, Lisp_Object *args, enum Lisp_Type target_type, int last_special)
Jim Blandy's avatar
Jim Blandy committed
453 454 455 456
{
  Lisp_Object val;
  register Lisp_Object tail;
  register Lisp_Object this;
457 458 459 460
  EMACS_INT toindex;
  EMACS_INT toindex_byte = 0;
  register EMACS_INT result_len;
  register EMACS_INT result_len_byte;
Jim Blandy's avatar
Jim Blandy committed
461 462 463
  register int argnum;
  Lisp_Object last_tail;
  Lisp_Object prev;
464
  int some_multibyte;
465 466 467 468 469
  /* 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.  */
470
  struct textprop_rec  *textprops = NULL;
Juanma Barranquero's avatar
Juanma Barranquero committed
471
  /* Number of elements in textprops.  */
Kenichi Handa's avatar
Kenichi Handa committed
472
  int num_textprops = 0;
Kim F. Storm's avatar
Kim F. Storm committed
473
  USE_SAFE_ALLOCA;
Jim Blandy's avatar
Jim Blandy committed
474

475 476
  tail = Qnil;

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

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

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

515
	  if (VECTORP (this) || FUNVECP (this))
516
	    for (i = 0; i < len; i++)
517
	      {
Stefan Monnier's avatar
Stefan Monnier committed
518
		ch = AREF (this, i);
Miles Bader's avatar
Miles Bader committed
519
		CHECK_CHARACTER (ch);
520
		this_len_byte = CHAR_BYTES (XINT (ch));
521
		result_len_byte += this_len_byte;
522
		if (! ASCII_CHAR_P (XINT (ch)) && ! CHAR_BYTE8_P (XINT (ch)))
523
		  some_multibyte = 1;
524
	      }
525 526
	  else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size > 0)
	    wrong_type_argument (Qintegerp, Faref (this, make_number (0)));
527
	  else if (CONSP (this))
528
	    for (; CONSP (this); this = XCDR (this))
529
	      {
530
		ch = XCAR (this);
Miles Bader's avatar
Miles Bader committed
531
		CHECK_CHARACTER (ch);
532
		this_len_byte = CHAR_BYTES (XINT (ch));
533
		result_len_byte += this_len_byte;
534
		if (! ASCII_CHAR_P (XINT (ch)) && ! CHAR_BYTE8_P (XINT (ch)))
535
		  some_multibyte = 1;
536
	      }
537
	  else if (STRINGP (this))
538
	    {
539
	      if (STRING_MULTIBYTE (this))
540 541
		{
		  some_multibyte = 1;
542
		  result_len_byte += SBYTES (this);
543 544
		}
	      else
545 546
		result_len_byte += count_size_as_multibyte (SDATA (this),
							    SCHARS (this));
547
	    }
548
	}
549 550

      result_len += len;
551 552
      if (result_len < 0)
	error ("String overflow");
Jim Blandy's avatar
Jim Blandy committed
553 554
    }

555 556
  if (! some_multibyte)
    result_len_byte = result_len;
Jim Blandy's avatar
Jim Blandy committed
557

558
  /* Create the output object.  */
Jim Blandy's avatar
Jim Blandy committed
559
  if (target_type == Lisp_Cons)
560
    val = Fmake_list (make_number (result_len), Qnil);
561
  else if (target_type == Lisp_Vectorlike)
562
    val = Fmake_vector (make_number (result_len), Qnil);
563
  else if (some_multibyte)
564
    val = make_uninit_multibyte_string (result_len, result_len_byte);
565 566
  else
    val = make_uninit_string (result_len);
Jim Blandy's avatar
Jim Blandy committed
567

568 569 570
  /* 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
571

572
  /* Copy the contents of the args into the result.  */
Jim Blandy's avatar
Jim Blandy committed
573
  if (CONSP (val))
574
    tail = val, toindex = -1; /* -1 in toindex is flag we are making a list */
Jim Blandy's avatar
Jim Blandy committed
575
  else
576
    toindex = 0, toindex_byte = 0;
Jim Blandy's avatar
Jim Blandy committed
577 578

  prev = Qnil;
579
  if (STRINGP (val))
Kim F. Storm's avatar
Kim F. Storm committed
580
    SAFE_ALLOCA (textprops, struct textprop_rec *, sizeof (struct textprop_rec) * nargs);
Jim Blandy's avatar
Jim Blandy committed
581 582 583 584

  for (argnum = 0; argnum < nargs; argnum++)
    {
      Lisp_Object thislen;
585 586 587
      EMACS_INT thisleni = 0;
      register EMACS_INT thisindex = 0;
      register EMACS_INT thisindex_byte = 0;
Jim Blandy's avatar
Jim Blandy committed
588 589 590 591 592

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

593 594 595
      /* 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
596
	{
597
	  EMACS_INT thislen_byte = SBYTES (this);
598

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

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

Kenichi Handa's avatar
Kenichi Handa committed
701
  if (num_textprops > 0)
702
    {
703
      Lisp_Object props;
704
      EMACS_INT last_to_end = -1;
705

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

  SAFE_FREE ();
Karl Heuer's avatar
Karl Heuer committed
724
  return val;
Jim Blandy's avatar
Jim Blandy committed
725 726
}

727
static Lisp_Object string_char_byte_cache_string;
728 729
static EMACS_INT string_char_byte_cache_charpos;
static EMACS_INT string_char_byte_cache_bytepos;
730

731
void
732
clear_string_char_byte_cache (void)
733 734 735 736
{
  string_char_byte_cache_string = Qnil;
}

737
/* Return the byte index corresponding to CHAR_INDEX in STRING.  */
738

739
EMACS_INT
740
string_char_to_byte (Lisp_Object string, EMACS_INT char_index)
741
{
742 743 744
  EMACS_INT i_byte;
  EMACS_INT best_below, best_below_byte;
  EMACS_INT best_above, best_above_byte;
745

746
  best_below = best_below_byte = 0;
747 748
  best_above = SCHARS (string);
  best_above_byte = SBYTES (string);
749 750
  if (best_above == best_above_byte)
    return char_index;
751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767

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

770 771
      while (best_below < char_index)
	{
772 773
	  p += BYTES_BY_CHAR_HEAD (*p);
	  best_below++;
774
	}
Kenichi Handa's avatar
Kenichi Handa committed
775
      i_byte = p - SDATA (string);
776 777
    }
  else
778
    {
Kenichi Handa's avatar
Kenichi Handa committed
779
      unsigned char *p = SDATA (string) + best_above_byte;
780

781 782
      while (best_above > char_index)
	{
783 784
	  p--;
	  while (!CHAR_HEAD_P (*p)) p--;
785 786
	  best_above--;
	}
Kenichi Handa's avatar
Kenichi Handa committed
787
      i_byte = p - SDATA (string);
788 789
    }

790
  string_char_byte_cache_bytepos = i_byte;
791
  string_char_byte_cache_charpos = char_index;
792 793
  string_char_byte_cache_string = string;

794 795
  return i_byte;
}
796

797 798
/* Return the character index corresponding to BYTE_INDEX in STRING.  */

799
EMACS_INT
800
string_byte_to_char (Lisp_Object string, EMACS_INT byte_index)
801
{
802 803 804
  EMACS_INT i, i_byte;
  EMACS_INT best_below, best_below_byte;
  EMACS_INT best_above, best_above_byte;
805

806
  best_below = best_below_byte = 0;