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 61 62

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

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

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

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

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

	  if (!CONSP (sequence))
	    break;

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

145
      CHECK_LIST_END (sequence, sequence);
146 147

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

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

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

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

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

  XSETINT (length, len);
  return length;
}

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

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

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

Juanma Barranquero's avatar
Juanma Barranquero committed
213 214
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
215 216 217 218 219 220 221 222 223 224 225
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;
226
  N - 1 is the number of characters that match at the beginning.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
227
  (Lisp_Object str1, Lisp_Object start1, Lisp_Object end1, Lisp_Object str2, Lisp_Object start2, Lisp_Object end2, Lisp_Object ignore_case)
228
{
229 230
  register EMACS_INT end1_char, end2_char;
  register EMACS_INT i1, i1_byte, i2, i2_byte;
231

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

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

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

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

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

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

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

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

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

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

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

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

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

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

/* ARGSUSED */
Lisp_Object
356
concat2 (Lisp_Object s1, Lisp_Object s2)
Jim Blandy's avatar
Jim Blandy committed
357 358 359 360 361 362 363
{
  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
364 365
/* ARGSUSED */
Lisp_Object
366
concat3 (Lisp_Object s1, Lisp_Object s2, Lisp_Object s3)
Richard M. Stallman's avatar
Richard M. Stallman committed
367 368 369 370 371 372 373 374
{
  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
375
DEFUN ("append", Fappend, Sappend, 0, MANY, 0,
376
       doc: /* Concatenate all the arguments and make the result a list.
Gerd Moellmann's avatar
Gerd Moellmann committed
377 378
The result is a list whose elements are the elements of all the arguments.
Each argument may be a list, vector or string.
379 380
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
381
  (int nargs, Lisp_Object *args)
Jim Blandy's avatar
Jim Blandy committed
382 383 384 385 386
{
  return concat (nargs, args, Lisp_Cons, 1);
}

DEFUN ("concat", Fconcat, Sconcat, 0, MANY, 0,
387
       doc: /* Concatenate all the arguments and make the result a string.
Gerd Moellmann's avatar
Gerd Moellmann committed
388
The result is a string whose elements are the elements of all the arguments.
389 390
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
391
  (int nargs, Lisp_Object *args)
Jim Blandy's avatar
Jim Blandy committed
392 393 394 395 396
{
  return concat (nargs, args, Lisp_String, 0);
}

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

406

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

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

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

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

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

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

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

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

472 473
  tail = Qnil;

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

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

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

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

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

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

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

565 566 567
  /* 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
568

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

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

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

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

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

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

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

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

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

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

728
void
729
clear_string_char_byte_cache (void)
730 731 732 733
{
  string_char_byte_cache_string = Qnil;
}

734
/* Return the byte index corresponding to CHAR_INDEX in STRING.  */
735

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

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

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

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

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

787
  string_char_byte_cache_bytepos = i_byte;
788
  string_char_byte_cache_charpos = char_index;
789 790
  string_char_byte_cache_string = string;

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

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

803
  best_below = best_below_byte = 0;
804 805
  best_above = SCHARS (string);
  best_above_byte = SBYTES (string);
806 807
  if (best_above == best_above_byte)
    return byte_index;
808 809