fns.c 134 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

26 27
#include <intprops.h>

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

Karl Heuer's avatar
Karl Heuer committed
45
#ifndef NULL
46
#define NULL ((POINTER_TYPE *)0)
Karl Heuer's avatar
Karl Heuer committed
47 48
#endif

49 50 51
Lisp_Object Qstring_lessp;
static Lisp_Object Qprovide, Qrequire;
static Lisp_Object Qyes_or_no_p_history;
52
Lisp_Object Qcursor_in_echo_area;
53 54
static Lisp_Object Qwidget_type;
static Lisp_Object Qcodeset, Qdays, Qmonths, Qpaper;
Jim Blandy's avatar
Jim Blandy committed
55

56 57
static Lisp_Object Qmd5, Qsha1, Qsha224, Qsha256, Qsha384, Qsha512;

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

#ifndef HAVE_UNISTD_H
extern long time ();
#endif
63

Paul Eggert's avatar
Paul Eggert 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
  EMACS_UINT 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 = ((EMACS_UINT) 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 109
/* Heuristic on how many iterations of a tight loop can be safely done
   before it's time to do a QUIT.  This must be a power of 2.  */
enum { QUIT_COUNT_HEURISTIC = 1 << 16 };

Jim Blandy's avatar
Jim Blandy committed
110 111
/* Random data-structure functions */

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

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);
Stefan Monnier's avatar
Stefan Monnier committed
130 131
  else if (COMPILEDP (sequence))
    XSETFASTINT (val, ASIZE (sequence) & PSEUDOVECTOR_SIZE_MASK);
132
  else if (CONSP (sequence))
Jim Blandy's avatar
Jim Blandy committed
133
    {
134 135 136
      EMACS_INT i = 0;

      do
Jim Blandy's avatar
Jim Blandy committed
137
	{
138
	  ++i;
139
	  if ((i & (QUIT_COUNT_HEURISTIC - 1)) == 0)
140 141 142 143 144
	    {
	      if (MOST_POSITIVE_FIXNUM < i)
		error ("List too long");
	      QUIT;
	    }
145
	  sequence = XCDR (sequence);
Jim Blandy's avatar
Jim Blandy committed
146
	}
147
      while (CONSP (sequence));
Jim Blandy's avatar
Jim Blandy committed
148

149
      CHECK_LIST_END (sequence, sequence);
150 151

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

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

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

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

  if (! CONSP (list))
175
    return make_number (0);
176 177

  /* halftail is used to detect circular lists.  */
178
  for (tail = halftail = list; ; )
179
    {
180 181
      tail = XCDR (tail);
      if (! CONSP (tail))
182
	break;
183 184 185 186 187 188 189 190 191 192 193 194 195
      if (EQ (tail, halftail))
	break;
      lolen++;
      if ((lolen & 1) == 0)
	{
	  halftail = XCDR (halftail);
	  if ((lolen & (QUIT_COUNT_HEURISTIC - 1)) == 0)
	    {
	      QUIT;
	      if (lolen == 0)
		hilen += UINTMAX_MAX + 1.0;
	    }
	}
196 197
    }

198 199 200 201
  /* If the length does not fit into a fixnum, return a float.
     On all known practical machines this returns an upper bound on
     the true length.  */
  return hilen ? make_float (hilen + lolen) : make_fixnum_or_float (lolen);
202 203
}

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

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

226 227
  if (SCHARS (s1) != SCHARS (s2)
      || SBYTES (s1) != SBYTES (s2)
228
      || memcmp (SDATA (s1), SDATA (s2), SBYTES (s1)))
Jim Blandy's avatar
Jim Blandy committed
229 230 231 232
    return Qnil;
  return Qt;
}

Paul Eggert's avatar
Paul Eggert committed
233
DEFUN ("compare-strings", Fcompare_strings, Scompare_strings, 6, 7, 0,
Juanma Barranquero's avatar
Juanma Barranquero committed
234
       doc: /* Compare the contents of two strings, converting to multibyte if needed.
Gerd Moellmann's avatar
Gerd Moellmann committed
235 236 237 238 239 240 241 242 243 244 245
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;
246
  N - 1 is the number of characters that match at the beginning.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
247
  (Lisp_Object str1, Lisp_Object start1, Lisp_Object end1, Lisp_Object str2, Lisp_Object start2, Lisp_Object end2, Lisp_Object ignore_case)
248
{
249 250
  register EMACS_INT end1_char, end2_char;
  register EMACS_INT i1, i1_byte, i2, i2_byte;
251

252 253
  CHECK_STRING (str1);
  CHECK_STRING (str2);
254 255 256 257
  if (NILP (start1))
    start1 = make_number (0);
  if (NILP (start2))
    start2 = make_number (0);
258 259
  CHECK_NATNUM (start1);
  CHECK_NATNUM (start2);
260
  if (! NILP (end1))
261
    CHECK_NATNUM (end1);
262
  if (! NILP (end2))
263
    CHECK_NATNUM (end2);
264 265 266 267 268 269 270

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

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

271
  end1_char = SCHARS (str1);
272 273 274
  if (! NILP (end1) && end1_char > XINT (end1))
    end1_char = XINT (end1);

275
  end2_char = SCHARS (str2);
276 277 278 279 280 281 282 283 284 285
  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))
286
	FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1, str1, i1, i1_byte);
287 288
      else
	{
289
	  c1 = SREF (str1, i1++);
290
	  MAKE_CHAR_MULTIBYTE (c1);
291 292 293
	}

      if (STRING_MULTIBYTE (str2))
294
	FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2, str2, i2, i2_byte);
295 296
      else
	{
297
	  c2 = SREF (str2, i2++);
298
	  MAKE_CHAR_MULTIBYTE (c2);
299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320
	}

      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)
321
	return make_number (- i1 + XINT (start1));
322
      else
323
	return make_number (i1 - XINT (start1));
324 325 326 327 328 329 330 331 332 333
    }

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

  return Qt;
}

Paul Eggert's avatar
Paul Eggert committed
334
DEFUN ("string-lessp", Fstring_lessp, Sstring_lessp, 2, 2, 0,
335
       doc: /* Return t if first arg string is less than second in lexicographic order.
Gerd Moellmann's avatar
Gerd Moellmann committed
336
Case is significant.
337
Symbols are also allowed; their print names are used instead.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
338
  (register Lisp_Object s1, Lisp_Object s2)
Jim Blandy's avatar
Jim Blandy committed
339
{
340 341
  register EMACS_INT end;
  register EMACS_INT i1, i1_byte, i2, i2_byte;
Jim Blandy's avatar
Jim Blandy committed
342

343
  if (SYMBOLP (s1))
344
    s1 = SYMBOL_NAME (s1);
345
  if (SYMBOLP (s2))
346
    s2 = SYMBOL_NAME (s2);
347 348
  CHECK_STRING (s1);
  CHECK_STRING (s2);
Jim Blandy's avatar
Jim Blandy committed
349

350 351
  i1 = i1_byte = i2 = i2_byte = 0;

352 353 354
  end = SCHARS (s1);
  if (end > SCHARS (s2))
    end = SCHARS (s2);
Jim Blandy's avatar
Jim Blandy committed
355

356
  while (i1 < end)
Jim Blandy's avatar
Jim Blandy committed
357
    {
358 359 360 361
      /* When we find a mismatch, we must compare the
	 characters, not just the bytes.  */
      int c1, c2;

362 363
      FETCH_STRING_CHAR_ADVANCE (c1, s1, i1, i1_byte);
      FETCH_STRING_CHAR_ADVANCE (c2, s2, i2, i2_byte);
364 365 366

      if (c1 != c2)
	return c1 < c2 ? Qt : Qnil;
Jim Blandy's avatar
Jim Blandy committed
367
    }
368
  return i1 < SCHARS (s2) ? Qt : Qnil;
Jim Blandy's avatar
Jim Blandy committed
369 370
}

371
static Lisp_Object concat (ptrdiff_t nargs, Lisp_Object *args,
372
			   enum Lisp_Type target_type, int last_special);
Jim Blandy's avatar
Jim Blandy committed
373 374 375

/* ARGSUSED */
Lisp_Object
376
concat2 (Lisp_Object s1, Lisp_Object s2)
Jim Blandy's avatar
Jim Blandy committed
377 378 379 380 381 382 383
{
  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
384 385
/* ARGSUSED */
Lisp_Object
386
concat3 (Lisp_Object s1, Lisp_Object s2, Lisp_Object s3)
Richard M. Stallman's avatar
Richard M. Stallman committed
387 388 389 390 391 392 393 394
{
  Lisp_Object args[3];
  args[0] = s1;
  args[1] = s2;
  args[2] = s3;
  return concat (3, args, Lisp_String, 0);
}

Paul Eggert's avatar
Paul Eggert committed
395
DEFUN ("append", Fappend, Sappend, 0, MANY, 0,
396
       doc: /* Concatenate all the arguments and make the result a list.
Gerd Moellmann's avatar
Gerd Moellmann committed
397 398
The result is a list whose elements are the elements of all the arguments.
Each argument may be a list, vector or string.
399 400
The last argument is not copied, just used as the tail of the new list.
usage: (append &rest SEQUENCES)  */)
401
  (ptrdiff_t nargs, Lisp_Object *args)
Jim Blandy's avatar
Jim Blandy committed
402 403 404 405
{
  return concat (nargs, args, Lisp_Cons, 1);
}

Paul Eggert's avatar
Paul Eggert committed
406
DEFUN ("concat", Fconcat, Sconcat, 0, MANY, 0,
407
       doc: /* Concatenate all the arguments and make the result a string.
Gerd Moellmann's avatar
Gerd Moellmann committed
408
The result is a string whose elements are the elements of all the arguments.
409 410
Each argument may be a string or a list or vector of characters (integers).
usage: (concat &rest SEQUENCES)  */)
411
  (ptrdiff_t nargs, Lisp_Object *args)
Jim Blandy's avatar
Jim Blandy committed
412 413 414 415
{
  return concat (nargs, args, Lisp_String, 0);
}

Paul Eggert's avatar
Paul Eggert committed
416
DEFUN ("vconcat", Fvconcat, Svconcat, 0, MANY, 0,
417
       doc: /* Concatenate all the arguments and make the result a vector.
Gerd Moellmann's avatar
Gerd Moellmann committed
418
The result is a vector whose elements are the elements of all the arguments.
419 420
Each argument may be a list, vector or string.
usage: (vconcat &rest SEQUENCES)   */)
421
  (ptrdiff_t nargs, Lisp_Object *args)
Jim Blandy's avatar
Jim Blandy committed
422
{
423
  return concat (nargs, args, Lisp_Vectorlike, 0);
Jim Blandy's avatar
Jim Blandy committed
424 425
}

426

Paul Eggert's avatar
Paul Eggert committed
427
DEFUN ("copy-sequence", Fcopy_sequence, Scopy_sequence, 1, 1, 0,
Dave Love's avatar
Dave Love committed
428
       doc: /* Return a copy of a list, vector, string or char-table.
Gerd Moellmann's avatar
Gerd Moellmann committed
429
The elements of a list or vector are not copied; they are shared
430
with the original.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
431
  (Lisp_Object arg)
Jim Blandy's avatar
Jim Blandy committed
432
{
Jim Blandy's avatar
Jim Blandy committed
433
  if (NILP (arg)) return arg;
434 435 436

  if (CHAR_TABLE_P (arg))
    {
437
      return copy_char_table (arg);
438 439 440 441 442
    }

  if (BOOL_VECTOR_P (arg))
    {
      Lisp_Object val;
443
      ptrdiff_t size_in_chars
444 445
	= ((XBOOL_VECTOR (arg)->size + BOOL_VECTOR_BITS_PER_CHAR - 1)
	   / BOOL_VECTOR_BITS_PER_CHAR);
446 447

      val = Fmake_bool_vector (Flength (arg), Qnil);
448 449
      memcpy (XBOOL_VECTOR (val)->data, XBOOL_VECTOR (arg)->data,
	      size_in_chars);
450 451 452
      return val;
    }

453
  if (!CONSP (arg) && !VECTORP (arg) && !STRINGP (arg))
454 455
    wrong_type_argument (Qsequencep, arg);

Jim Blandy's avatar
Jim Blandy committed
456 457 458
  return concat (1, &arg, CONSP (arg) ? Lisp_Cons : XTYPE (arg), 0);
}

459 460
/* 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
461
struct textprop_rec
462
{
463
  ptrdiff_t argnum;		/* refer to ARGS (arguments of `concat') */
464 465
  EMACS_INT from;		/* refer to ARGS[argnum] (argument string) */
  EMACS_INT to;			/* refer to VAL (the target string) */
466 467
};

Jim Blandy's avatar
Jim Blandy committed
468
static Lisp_Object
469
concat (ptrdiff_t nargs, Lisp_Object *args,
470
	enum Lisp_Type target_type, int last_special)
Jim Blandy's avatar
Jim Blandy committed
471 472 473 474
{
  Lisp_Object val;
  register Lisp_Object tail;
  register Lisp_Object this;
475 476 477 478
  EMACS_INT toindex;
  EMACS_INT toindex_byte = 0;
  register EMACS_INT result_len;
  register EMACS_INT result_len_byte;
479
  ptrdiff_t argnum;
Jim Blandy's avatar
Jim Blandy committed
480 481
  Lisp_Object last_tail;
  Lisp_Object prev;
482
  int some_multibyte;
483
  /* When we make a multibyte string, we can't copy text properties
Paul Eggert's avatar
Paul Eggert committed
484 485
     while concatenating each string because the length of resulting
     string can't be decided until we finish the whole concatenation.
486
     So, we record strings that have text properties to be copied
Paul Eggert's avatar
Paul Eggert committed
487
     here, and copy the text properties after the concatenation.  */
488
  struct textprop_rec  *textprops = NULL;
Juanma Barranquero's avatar
Juanma Barranquero committed
489
  /* Number of elements in textprops.  */
490
  ptrdiff_t num_textprops = 0;
Kim F. Storm's avatar
Kim F. Storm committed
491
  USE_SAFE_ALLOCA;
Jim Blandy's avatar
Jim Blandy committed
492

493 494
  tail = Qnil;

Jim Blandy's avatar
Jim Blandy committed
495 496 497 498 499 500 501 502 503
  /* 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;

504
  /* Check each argument.  */
Jim Blandy's avatar
Jim Blandy committed
505 506 507
  for (argnum = 0; argnum < nargs; argnum++)
    {
      this = args[argnum];
508
      if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
Stefan Monnier's avatar
Stefan Monnier committed
509
	    || COMPILEDP (this) || BOOL_VECTOR_P (this)))
510
	wrong_type_argument (Qsequencep, this);
Jim Blandy's avatar
Jim Blandy committed
511 512
    }

513 514 515 516 517 518 519 520
  /* 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
521
    {
522
      EMACS_INT len;
Jim Blandy's avatar
Jim Blandy committed
523
      this = args[argnum];
524 525
      len = XFASTINT (Flength (this));
      if (target_type == Lisp_String)
526
	{
527 528
	  /* We must count the number of bytes needed in the string
	     as well as the number of characters.  */
529
	  EMACS_INT i;
530
	  Lisp_Object ch;
531
	  int c;
532
	  EMACS_INT this_len_byte;
533

Stefan Monnier's avatar
Stefan Monnier committed
534
	  if (VECTORP (this) || COMPILEDP (this))
535
	    for (i = 0; i < len; i++)
536
	      {
Stefan Monnier's avatar
Stefan Monnier committed
537
		ch = AREF (this, i);
Miles Bader's avatar
Miles Bader committed
538
		CHECK_CHARACTER (ch);
539 540
		c = XFASTINT (ch);
		this_len_byte = CHAR_BYTES (c);
541
		result_len_byte += this_len_byte;
542
		if (! ASCII_CHAR_P (c) && ! CHAR_BYTE8_P (c))
543
		  some_multibyte = 1;
544
	      }
545 546
	  else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size > 0)
	    wrong_type_argument (Qintegerp, Faref (this, make_number (0)));
547
	  else if (CONSP (this))
548
	    for (; CONSP (this); this = XCDR (this))
549
	      {
550
		ch = XCAR (this);
Miles Bader's avatar
Miles Bader committed
551
		CHECK_CHARACTER (ch);
552 553
		c = XFASTINT (ch);
		this_len_byte = CHAR_BYTES (c);
554
		result_len_byte += this_len_byte;
555
		if (! ASCII_CHAR_P (c) && ! CHAR_BYTE8_P (c))
556
		  some_multibyte = 1;
557
	      }
558
	  else if (STRINGP (this))
559
	    {
560
	      if (STRING_MULTIBYTE (this))
561 562
		{
		  some_multibyte = 1;
563
		  result_len_byte += SBYTES (this);
564 565
		}
	      else
566 567
		result_len_byte += count_size_as_multibyte (SDATA (this),
							    SCHARS (this));
568
	    }
569
	}
570 571

      result_len += len;
572 573
      if (STRING_BYTES_BOUND < result_len)
	string_overflow ();
Jim Blandy's avatar
Jim Blandy committed
574 575
    }

576 577
  if (! some_multibyte)
    result_len_byte = result_len;
Jim Blandy's avatar
Jim Blandy committed
578

579
  /* Create the output object.  */
Jim Blandy's avatar
Jim Blandy committed
580
  if (target_type == Lisp_Cons)
581
    val = Fmake_list (make_number (result_len), Qnil);
582
  else if (target_type == Lisp_Vectorlike)
583
    val = Fmake_vector (make_number (result_len), Qnil);
584
  else if (some_multibyte)
585
    val = make_uninit_multibyte_string (result_len, result_len_byte);
586 587
  else
    val = make_uninit_string (result_len);
Jim Blandy's avatar
Jim Blandy committed
588

589 590 591
  /* 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
592

593
  /* Copy the contents of the args into the result.  */
Jim Blandy's avatar
Jim Blandy committed
594
  if (CONSP (val))
595
    tail = val, toindex = -1; /* -1 in toindex is flag we are making a list */
Jim Blandy's avatar
Jim Blandy committed
596
  else
597
    toindex = 0, toindex_byte = 0;
Jim Blandy's avatar
Jim Blandy committed
598 599

  prev = Qnil;
600
  if (STRINGP (val))
Kim F. Storm's avatar
Kim F. Storm committed
601
    SAFE_ALLOCA (textprops, struct textprop_rec *, sizeof (struct textprop_rec) * nargs);
Jim Blandy's avatar
Jim Blandy committed
602 603 604 605

  for (argnum = 0; argnum < nargs; argnum++)
    {
      Lisp_Object thislen;
606 607 608
      EMACS_INT thisleni = 0;
      register EMACS_INT thisindex = 0;
      register EMACS_INT thisindex_byte = 0;
Jim Blandy's avatar
Jim Blandy committed
609 610 611 612 613

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

614 615 616
      /* 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
617
	{
618
	  EMACS_INT thislen_byte = SBYTES (this);
619

620
	  memcpy (SDATA (val) + toindex_byte, SDATA (this), SBYTES (this));
621
	  if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
622
	    {
Kenichi Handa's avatar
Kenichi Handa committed
623
	      textprops[num_textprops].argnum = argnum;
624
	      textprops[num_textprops].from = 0;
Kenichi Handa's avatar
Kenichi Handa committed
625
	      textprops[num_textprops++].to = toindex;
626
	    }
627
	  toindex_byte += thislen_byte;
628
	  toindex += thisleni;
629
	}
630 631 632
      /* Copy a single-byte string to a multibyte string.  */
      else if (STRINGP (this) && STRINGP (val))
	{
633
	  if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
634
	    {
Kenichi Handa's avatar
Kenichi Handa committed
635 636 637
	      textprops[num_textprops].argnum = argnum;
	      textprops[num_textprops].from = 0;
	      textprops[num_textprops++].to = toindex;
638
	    }
639 640 641
	  toindex_byte += copy_text (SDATA (this),
				     SDATA (val) + toindex_byte,
				     SCHARS (this), 0, 1);
642 643
	  toindex += thisleni;
	}
644 645 646 647 648 649 650 651 652 653
      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))
654
	      elt = XCAR (this), this = XCDR (this);
655 656 657
	    else if (thisindex >= thisleni)
	      break;
	    else if (STRINGP (this))
658
	      {
659
		int c;
660
		if (STRING_MULTIBYTE (this))
661 662 663
		  FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c, this,
						      thisindex,
						      thisindex_byte);
664
		else
665
		  {
666 667 668
		    c = SREF (this, thisindex); thisindex++;
		    if (some_multibyte && !ASCII_CHAR_P (c))
		      c = BYTE8_TO_CHAR (c);
669
		  }
670
		XSETFASTINT (elt, c);
671 672 673 674
	      }
	    else if (BOOL_VECTOR_P (this))
	      {
		int byte;
675 676
		byte = XBOOL_VECTOR (this)->data[thisindex / BOOL_VECTOR_BITS_PER_CHAR];
		if (byte & (1 << (thisindex % BOOL_VECTOR_BITS_PER_CHAR)))
677
		  elt = Qt;
678
		else
679 680
		  elt = Qnil;
		thisindex++;
681
	      }
682
	    else
683 684 685 686
	      {
		elt = AREF (this, thisindex);
		thisindex++;
	      }
Jim Blandy's avatar
Jim Blandy committed
687

688 689
	    /* Store this element into the result.  */
	    if (toindex < 0)
Jim Blandy's avatar
Jim Blandy committed
690
	      {
691
		XSETCAR (tail, elt);
692
		prev = tail;
693
		tail = XCDR (tail);
Jim Blandy's avatar
Jim Blandy committed
694
	      }
695
	    else if (VECTORP (val))
696 697 698 699
	      {
		ASET (val, toindex, elt);
		toindex++;
	      }
700 701
	    else
	      {
702 703 704
		int c;
		CHECK_CHARACTER (elt);
		c = XFASTINT (elt);
705
		if (some_multibyte)
706
		  toindex_byte += CHAR_STRING (c, SDATA (val) + toindex_byte);
707
		else
708
		  SSET (val, toindex_byte++, c);
709
		toindex++;
710 711
	      }
	  }
Jim Blandy's avatar
Jim Blandy committed
712
    }
Jim Blandy's avatar
Jim Blandy committed
713
  if (!NILP (prev))
714
    XSETCDR (prev, last_tail);
Jim Blandy's avatar
Jim Blandy committed
715

Kenichi Handa's avatar
Kenichi Handa committed
716
  if (num_textprops > 0)
717
    {
718
      Lisp_Object props;
719
      EMACS_INT last_to_end = -1;
720

Kenichi Handa's avatar
Kenichi Handa committed
721
      for (argnum = 0; argnum < num_textprops; argnum++)
722
	{
Kenichi Handa's avatar
Kenichi Handa committed
723
	  this = args[textprops[argnum].argnum];
724 725
	  props = text_property_list (this,
				      make_number (0),
726
				      make_number (SCHARS (this)),
727
				      Qnil);
Paul Eggert's avatar
Paul Eggert committed
728
	  /* If successive arguments have properties, be sure that the
729
	     value of `composition' property be the copy.  */
730
	  if (last_to_end == textprops[argnum].to)
731 732 733
	    make_composition_value_copy (props);
	  add_text_properties_from_list (val, props,
					 make_number (textprops[argnum].to));
734
	  last_to_end = textprops[argnum].to + SCHARS (this);
735 736
	}
    }
Kim F. Storm's avatar
Kim F. Storm committed
737 738

  SAFE_FREE ();
Karl Heuer's avatar
Karl Heuer committed
739
  return val;
Jim Blandy's avatar
Jim Blandy committed
740 741
}

742
static Lisp_Object string_char_byte_cache_string;
743 744
static EMACS_INT string_char_byte_cache_charpos;
static EMACS_INT string_char_byte_cache_bytepos;
745

746
void
747
clear_string_char_byte_cache (void)
748 749 750 751
{
  string_char_byte_cache_string = Qnil;
}

752
/* Return the byte index corresponding to CHAR_INDEX in STRING.  */
753

754
EMACS_INT
755
string_char_to_byte (Lisp_Object string, EMACS_INT char_index)
756
{
757 758 759
  EMACS_INT i_byte;
  EMACS_INT best_below, best_below_byte;
  EMACS_INT best_above, best_above_byte;
760

761
  best_below = best_below_byte = 0;
762 763
  best_above = SCHARS (string);
  best_above_byte = SBYTES (string);
764 765
  if (best_above == best_above_byte)
    return char_index;
766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782

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

785 786
      while (best_below < char_index)
	{
787 788
	  p += BYTES_BY_CHAR_HEAD (*p);
	  best_below++;
789
	}
Kenichi Handa's avatar
Kenichi Handa committed
790
      i_byte = p - SDATA (string);
791 792
    }
  else
793
    {
Kenichi Handa's avatar
Kenichi Handa committed
794
      unsigned char *p = SDATA (string) + best_above_byte;
795

796 797
      while (best_above > char_index)
	{
798 799
	  p--;
	  while (!CHAR_HEAD_P (*p)) p--;
800 801
	  best_above--;
	}
Kenichi Handa's avatar
Kenichi Handa committed
802
      i_byte = p - SDATA (string);
803 804
    }