fns.c 135 KB
Newer Older
Jim Blandy's avatar
Jim Blandy committed
1
/* Random utility Lisp functions.
2
   Copyright (C) 1985-1987, 1993-1995, 1997-2012
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

45 46 47
Lisp_Object Qstring_lessp;
static Lisp_Object Qprovide, Qrequire;
static Lisp_Object Qyes_or_no_p_history;
48
Lisp_Object Qcursor_in_echo_area;
49 50
static Lisp_Object Qwidget_type;
static Lisp_Object Qcodeset, Qdays, Qmonths, Qpaper;
Jim Blandy's avatar
Jim Blandy committed
51

52 53
static Lisp_Object Qmd5, Qsha1, Qsha224, Qsha256, Qsha384, Qsha512;

54
static int internal_equal (Lisp_Object , Lisp_Object, int, int);
55 56 57 58

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

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

79
  if (EQ (limit, Qt))
80 81 82 83 84 85
    {
      EMACS_TIME t;
      EMACS_GET_TIME (t);
      seed_random (getpid () ^ EMACS_SECS (t) ^ EMACS_USECS (t));
    }

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
      EMACS_INT denominator = (INTMASK + 1) / 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 ptrdiff_t end1_char, end2_char;
  register ptrdiff_t 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
  end1_char = SCHARS (str1);
266 267
  if (! NILP (end1) && end1_char > XINT (end1))
    end1_char = XINT (end1);
268 269
  if (end1_char < XINT (start1))
    args_out_of_range (str1, start1);
270

271
  end2_char = SCHARS (str2);
272 273
  if (! NILP (end2) && end2_char > XINT (end2))
    end2_char = XINT (end2);
274 275 276 277 278 279 280 281
  if (end2_char < XINT (start2))
    args_out_of_range (str2, start2);

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

  i1_byte = string_char_to_byte (str1, i1);
  i2_byte = string_char_to_byte (str2, i2);
282 283 284 285 286 287 288 289

  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))
290
	FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1, str1, i1, i1_byte);
291 292
      else
	{
293
	  c1 = SREF (str1, i1++);
294
	  MAKE_CHAR_MULTIBYTE (c1);
295 296 297
	}

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

      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)
325
	return make_number (- i1 + XINT (start1));
326
      else
327
	return make_number (i1 - XINT (start1));
328 329 330 331 332 333 334 335 336 337
    }

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

347
  if (SYMBOLP (s1))
348
    s1 = SYMBOL_NAME (s1);
349
  if (SYMBOLP (s2))
350
    s2 = SYMBOL_NAME (s2);
351 352
  CHECK_STRING (s1);
  CHECK_STRING (s2);
Jim Blandy's avatar
Jim Blandy committed
353

354 355
  i1 = i1_byte = i2 = i2_byte = 0;

356 357 358
  end = SCHARS (s1);
  if (end > SCHARS (s2))
    end = SCHARS (s2);
Jim Blandy's avatar
Jim Blandy committed
359

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

366 367
      FETCH_STRING_CHAR_ADVANCE (c1, s1, i1, i1_byte);
      FETCH_STRING_CHAR_ADVANCE (c2, s2, i2, i2_byte);
368 369 370

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

/* ARGSUSED */
Lisp_Object
380
concat2 (Lisp_Object s1, Lisp_Object s2)
Jim Blandy's avatar
Jim Blandy committed
381 382 383 384 385 386 387
{
  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
388 389
/* ARGSUSED */
Lisp_Object
390
concat3 (Lisp_Object s1, Lisp_Object s2, Lisp_Object s3)
Richard M. Stallman's avatar
Richard M. Stallman committed
391 392 393 394 395 396 397 398
{
  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
399
DEFUN ("append", Fappend, Sappend, 0, MANY, 0,
400
       doc: /* Concatenate all the arguments and make the result a list.
Gerd Moellmann's avatar
Gerd Moellmann committed
401 402
The result is a list whose elements are the elements of all the arguments.
Each argument may be a list, vector or string.
403 404
The last argument is not copied, just used as the tail of the new list.
usage: (append &rest SEQUENCES)  */)
405
  (ptrdiff_t nargs, Lisp_Object *args)
Jim Blandy's avatar
Jim Blandy committed
406 407 408 409
{
  return concat (nargs, args, Lisp_Cons, 1);
}

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

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

430

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

  if (CHAR_TABLE_P (arg))
    {
441
      return copy_char_table (arg);
442 443 444 445 446
    }

  if (BOOL_VECTOR_P (arg))
    {
      Lisp_Object val;
447
      ptrdiff_t size_in_chars
448 449
	= ((XBOOL_VECTOR (arg)->size + BOOL_VECTOR_BITS_PER_CHAR - 1)
	   / BOOL_VECTOR_BITS_PER_CHAR);
450 451

      val = Fmake_bool_vector (Flength (arg), Qnil);
452 453
      memcpy (XBOOL_VECTOR (val)->data, XBOOL_VECTOR (arg)->data,
	      size_in_chars);
454 455 456
      return val;
    }

457
  if (!CONSP (arg) && !VECTORP (arg) && !STRINGP (arg))
458 459
    wrong_type_argument (Qsequencep, arg);

Jim Blandy's avatar
Jim Blandy committed
460 461 462
  return concat (1, &arg, CONSP (arg) ? Lisp_Cons : XTYPE (arg), 0);
}

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

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

497 498
  tail = Qnil;

Jim Blandy's avatar
Jim Blandy committed
499 500 501 502 503 504 505 506 507
  /* 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;

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

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

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

      result_len += len;
583 584
      if (MOST_POSITIVE_FIXNUM < result_len)
	memory_full (SIZE_MAX);
Jim Blandy's avatar
Jim Blandy committed
585 586
    }

587 588
  if (! some_multibyte)
    result_len_byte = result_len;
Jim Blandy's avatar
Jim Blandy committed
589

590
  /* Create the output object.  */
Jim Blandy's avatar
Jim Blandy committed
591
  if (target_type == Lisp_Cons)
592
    val = Fmake_list (make_number (result_len), Qnil);
593
  else if (target_type == Lisp_Vectorlike)
594
    val = Fmake_vector (make_number (result_len), Qnil);
595
  else if (some_multibyte)
596
    val = make_uninit_multibyte_string (result_len, result_len_byte);
597 598
  else
    val = make_uninit_string (result_len);
Jim Blandy's avatar
Jim Blandy committed
599

600 601 602
  /* 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
603

604
  /* Copy the contents of the args into the result.  */
Jim Blandy's avatar
Jim Blandy committed
605
  if (CONSP (val))
606
    tail = val, toindex = -1; /* -1 in toindex is flag we are making a list */
Jim Blandy's avatar
Jim Blandy committed
607
  else
608
    toindex = 0, toindex_byte = 0;
Jim Blandy's avatar
Jim Blandy committed
609 610

  prev = Qnil;
611
  if (STRINGP (val))
612
    SAFE_NALLOCA (textprops, 1, nargs);
Jim Blandy's avatar
Jim Blandy committed
613 614 615 616

  for (argnum = 0; argnum < nargs; argnum++)
    {
      Lisp_Object thislen;
617 618 619
      ptrdiff_t thisleni = 0;
      register ptrdiff_t thisindex = 0;
      register ptrdiff_t thisindex_byte = 0;
Jim Blandy's avatar
Jim Blandy committed
620 621 622 623 624

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

625 626 627
      /* 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
628
	{
629
	  ptrdiff_t thislen_byte = SBYTES (this);
630

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

699 700
	    /* Store this element into the result.  */
	    if (toindex < 0)
Jim Blandy's avatar
Jim Blandy committed
701
	      {
702
		XSETCAR (tail, elt);
703
		prev = tail;
704
		tail = XCDR (tail);
Jim Blandy's avatar
Jim Blandy committed
705
	      }
706
	    else if (VECTORP (val))
707 708 709 710
	      {
		ASET (val, toindex, elt);
		toindex++;
	      }
711 712
	    else
	      {
713 714 715
		int c;
		CHECK_CHARACTER (elt);
		c = XFASTINT (elt);
716
		if (some_multibyte)
717
		  toindex_byte += CHAR_STRING (c, SDATA (val) + toindex_byte);
718
		else
719
		  SSET (val, toindex_byte++, c);
720
		toindex++;
721 722
	      }
	  }
Jim Blandy's avatar
Jim Blandy committed
723
    }
Jim Blandy's avatar
Jim Blandy committed
724
  if (!NILP (prev))
725
    XSETCDR (prev, last_tail);
Jim Blandy's avatar
Jim Blandy committed
726

Kenichi Handa's avatar
Kenichi Handa committed
727
  if (num_textprops > 0)
728
    {
729
      Lisp_Object props;
730
      ptrdiff_t last_to_end = -1;
731

Kenichi Handa's avatar
Kenichi Handa committed
732
      for (argnum = 0; argnum < num_textprops; argnum++)
733
	{
Kenichi Handa's avatar
Kenichi Handa committed
734
	  this = args[textprops[argnum].argnum];
735 736
	  props = text_property_list (this,
				      make_number (0),
737
				      make_number (SCHARS (this)),
738
				      Qnil);
Paul Eggert's avatar
Paul Eggert committed
739
	  /* If successive arguments have properties, be sure that the
740
	     value of `composition' property be the copy.  */
741
	  if (last_to_end == textprops[argnum].to)
742 743 744
	    make_composition_value_copy (props);
	  add_text_properties_from_list (val, props,
					 make_number (textprops[argnum].to));