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 53 54
Lisp_Object Qstring_lessp;
static Lisp_Object Qprovide, Qrequire;
static Lisp_Object Qyes_or_no_p_history;
55
Lisp_Object Qcursor_in_echo_area;
56 57
static Lisp_Object Qwidget_type;
static Lisp_Object Qcodeset, Qdays, Qmonths, Qpaper;
Jim Blandy's avatar
Jim Blandy committed
58

59
static int internal_equal (Lisp_Object , Lisp_Object, int, int);
60 61 62 63

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

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

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

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

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

	  if (!CONSP (sequence))
	    break;

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

146
      CHECK_LIST_END (sequence, sequence);
147 148

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

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

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

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

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

  XSETINT (length, len);
  return length;
}

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

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

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

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

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

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

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

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

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

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

      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)
302
	return make_number (- i1 + XINT (start1));
303
      else
304
	return make_number (i1 - XINT (start1));
305 306 307 308 309 310 311 312 313 314
    }

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

  return Qt;
}

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

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

331 332
  i1 = i1_byte = i2 = i2_byte = 0;

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

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

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

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

/* ARGSUSED */
Lisp_Object
357
concat2 (Lisp_Object s1, Lisp_Object s2)
Jim Blandy's avatar
Jim Blandy committed
358 359 360 361 362 363 364
{
  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
365 366
/* ARGSUSED */
Lisp_Object
367
concat3 (Lisp_Object s1, Lisp_Object s2, Lisp_Object s3)
Richard M. Stallman's avatar
Richard M. Stallman committed
368 369 370 371 372 373 374 375
{
  Lisp_Object args[3];
  args[0] = s1;
  args[1] = s2;
  args[2] = s3;
  return concat (3, args, Lisp_String, 0);
}

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

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

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

407

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

  if (CHAR_TABLE_P (arg))
    {
418
      return copy_char_table (arg);
419 420 421 422 423 424
    }

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

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

434
  if (!CONSP (arg) && !VECTORP (arg) && !STRINGP (arg))
435 436
    wrong_type_argument (Qsequencep, arg);

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

440 441
/* 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
442
struct textprop_rec
443 444
{
  int argnum;			/* refer to ARGS (arguments of `concat') */
445 446
  EMACS_INT from;		/* refer to ARGS[argnum] (argument string) */
  EMACS_INT to;			/* refer to VAL (the target string) */
447 448
};

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

474 475
  tail = Qnil;

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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