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-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;
Jim Blandy's avatar
Jim Blandy committed
82

83
  if (EQ (limit, Qt))
84 85 86 87 88 89
    {
      EMACS_TIME t;
      EMACS_GET_TIME (t);
      seed_random (getpid () ^ EMACS_SECS (t) ^ EMACS_USECS (t));
    }

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

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

126
  if (STRINGP (sequence))
127
    XSETFASTINT (val, SCHARS (sequence));
128
  else if (VECTORP (sequence))
Stefan Monnier's avatar
Stefan Monnier committed
129
    XSETFASTINT (val, ASIZE (sequence));
130
  else if (CHAR_TABLE_P (sequence))
131
    XSETFASTINT (val, MAX_CHAR);
132 133
  else if (BOOL_VECTOR_P (sequence))
    XSETFASTINT (val, XBOOL_VECTOR (sequence)->size);
Stefan Monnier's avatar
Stefan Monnier committed
134 135
  else if (COMPILEDP (sequence))
    XSETFASTINT (val, ASIZE (sequence) & PSEUDOVECTOR_SIZE_MASK);
136
  else if (CONSP (sequence))
Jim Blandy's avatar
Jim Blandy committed
137
    {
138 139 140
      EMACS_INT i = 0;

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

153
      CHECK_LIST_END (sequence, sequence);
154 155

      val = make_number (i);
Jim Blandy's avatar
Jim Blandy committed
156
    }
157
  else if (NILP (sequence))
158
    XSETFASTINT (val, 0);
Jim Blandy's avatar
Jim Blandy committed
159
  else
160
    wrong_type_argument (Qsequencep, sequence);
161

162
  return val;
Jim Blandy's avatar
Jim Blandy committed
163 164
}

165
/* This does not check for quits.  That is safe since it must terminate.  */
166 167

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

  if (! CONSP (list))
179
    return make_number (0);
180 181

  /* halftail is used to detect circular lists.  */
182
  for (tail = halftail = list; ; )
183
    {
184 185
      tail = XCDR (tail);
      if (! CONSP (tail))
186
	break;
187 188 189 190 191 192 193 194 195 196 197 198 199
      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;
	    }
	}
200 201
    }

202 203 204 205
  /* 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);
206 207
}

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

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

230 231
  if (SCHARS (s1) != SCHARS (s2)
      || SBYTES (s1) != SBYTES (s2)
232
      || memcmp (SDATA (s1), SDATA (s2), SBYTES (s1)))
Jim Blandy's avatar
Jim Blandy committed
233 234 235 236
    return Qnil;
  return Qt;
}

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

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

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

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

275
  end1_char = SCHARS (str1);
276 277 278
  if (! NILP (end1) && end1_char > XINT (end1))
    end1_char = XINT (end1);

279
  end2_char = SCHARS (str2);
280 281 282 283 284 285 286 287 288 289
  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))
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 EMACS_INT end;
  register EMACS_INT 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
  EMACS_INT from;		/* refer to ARGS[argnum] (argument string) */
  EMACS_INT 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 481 482
  EMACS_INT toindex;
  EMACS_INT toindex_byte = 0;
  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
	  EMACS_INT i;
534
	  Lisp_Object ch;
535
	  int c;
536
	  EMACS_INT 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
		result_len_byte += this_len_byte;
546
		if (! ASCII_CHAR_P (c) && ! CHAR_BYTE8_P (c))
547
		  some_multibyte = 1;
548
	      }
549 550
	  else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size > 0)
	    wrong_type_argument (Qintegerp, Faref (this, make_number (0)));
551
	  else if (CONSP (this))
552
	    for (; CONSP (this); this = XCDR (this))
553
	      {
554
		ch = XCAR (this);
Miles Bader's avatar
Miles Bader committed
555
		CHECK_CHARACTER (ch);
556 557
		c = XFASTINT (ch);
		this_len_byte = CHAR_BYTES (c);
558
		result_len_byte += this_len_byte;
559
		if (! ASCII_CHAR_P (c) && ! CHAR_BYTE8_P (c))
560
		  some_multibyte = 1;
561
	      }
562
	  else if (STRINGP (this))
563
	    {
564
	      if (STRING_MULTIBYTE (this))
565 566
		{
		  some_multibyte = 1;
567
		  result_len_byte += SBYTES (this);
568 569
		}
	      else
570 571
		result_len_byte += count_size_as_multibyte (SDATA (this),
							    SCHARS (this));
572
	    }
573
	}
574 575

      result_len += len;
576 577
      if (STRING_BYTES_BOUND < result_len)
	string_overflow ();
Jim Blandy's avatar
Jim Blandy committed
578 579
    }

580 581
  if (! some_multibyte)
    result_len_byte = result_len;
Jim Blandy's avatar
Jim Blandy committed
582

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

593 594 595
  /* 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
596

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

  prev = Qnil;
604
  if (STRINGP (val))
605
    SAFE_NALLOCA (textprops, 1, nargs);
Jim Blandy's avatar
Jim Blandy committed
606 607 608 609

  for (argnum = 0; argnum < nargs; argnum++)
    {
      Lisp_Object thislen;
610 611 612
      EMACS_INT thisleni = 0;
      register EMACS_INT thisindex = 0;
      register EMACS_INT thisindex_byte = 0;
Jim Blandy's avatar
Jim Blandy committed
613 614 615 616 617

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

618 619 620
      /* 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
621
	{
622
	  EMACS_INT thislen_byte = SBYTES (this);
623

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

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

Kenichi Handa's avatar
Kenichi Handa committed
720
  if (num_textprops > 0)
721
    {
722
      Lisp_Object props;
723
      EMACS_INT last_to_end = -1;
724

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

  SAFE_FREE ();
Karl Heuer's avatar
Karl Heuer committed
743
  return val;
Jim Blandy's avatar
Jim Blandy committed
744 745
}

746
static Lisp_Object string_char_byte_cache_string;
747 748
static EMACS_INT string_char_byte_cache_charpos;
static EMACS_INT string_char_byte_cache_bytepos;
749

750
void
751
clear_string_char_byte_cache (void)
752 753 754 755
{
  string_char_byte_cache_string = Qnil;
}

756
/* Return the byte index corresponding to CHAR_INDEX in STRING.  */
757

758
EMACS_INT
759
string_char_to_byte (Lisp_Object string, EMACS_INT char_index)
760
{
761 762 763
  EMACS_INT i_byte;
  EMACS_INT best_below, best_below_byte;
  EMACS_INT best_above, best_above_byte;
764

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

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

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

800 801
      while (best_above > char_index)
	{
802 803
	  p--;
	  while (!CHAR_HEAD_P (*p)) p--;
804 805
	  best_above--;
	}
Kenichi Handa's avatar
Kenichi Handa committed
806
      i_byte = p - SDATA (string);
807 808
    }