fns.c 132 KB
Newer Older
Jim Blandy's avatar
Jim Blandy committed
1
/* Random utility Lisp functions.
2 3
   Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995, 1997,
                 1998, 1999, 2000, 2001, 2002, 2003, 2004,
Juanma Barranquero's avatar
Juanma Barranquero committed
4 5
                 2005, 2006, 2007, 2008, 2009, 2010
		 Free Software Foundation, Inc.
Jim Blandy's avatar
Jim Blandy committed
6 7 8

This file is part of GNU Emacs.

9
GNU Emacs is free software: you can redistribute it and/or modify
Jim Blandy's avatar
Jim Blandy committed
10
it under the terms of the GNU General Public License as published by
11 12
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
Jim Blandy's avatar
Jim Blandy committed
13 14 15 16 17 18 19

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
20
along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.  */
Jim Blandy's avatar
Jim Blandy committed
21

22
#include <config.h>
Jim Blandy's avatar
Jim Blandy committed
23

Andreas Schwab's avatar
Andreas Schwab committed
24 25 26
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif
Andreas Schwab's avatar
Andreas Schwab committed
27
#include <time.h>
28
#include <setjmp.h>
Andreas Schwab's avatar
Andreas Schwab committed
29

Jim Blandy's avatar
Jim Blandy committed
30 31 32 33
/* Note on some machines this defines `vector' as a typedef,
   so make sure we don't use that name in this file.  */
#undef vector
#define vector *****
34

Jim Blandy's avatar
Jim Blandy committed
35 36
#include "lisp.h"
#include "commands.h"
37
#include "character.h"
38
#include "coding.h"
Jim Blandy's avatar
Jim Blandy committed
39
#include "buffer.h"
Jim Blandy's avatar
Jim Blandy committed
40
#include "keyboard.h"
Stefan Monnier's avatar
Stefan Monnier committed
41
#include "keymap.h"
42
#include "intervals.h"
43 44
#include "frame.h"
#include "window.h"
Gerd Moellmann's avatar
Gerd Moellmann committed
45
#include "blockinput.h"
46 47
#ifdef HAVE_MENUS
#if defined (HAVE_X_WINDOWS)
Andreas Schwab's avatar
Andreas Schwab committed
48 49
#include "xterm.h"
#endif
50
#endif /* HAVE_MENUS */
Jim Blandy's avatar
Jim Blandy committed
51

Karl Heuer's avatar
Karl Heuer committed
52
#ifndef NULL
53
#define NULL ((POINTER_TYPE *)0)
Karl Heuer's avatar
Karl Heuer committed
54 55
#endif

56 57 58 59
/* Nonzero enables use of dialog boxes for questions
   asked by mouse commands.  */
int use_dialog_box;

Kenichi Handa's avatar
Kenichi Handa committed
60 61 62 63
/* Nonzero enables use of a file dialog for file name
   questions asked by mouse commands.  */
int use_file_dialog;

64
Lisp_Object Qstring_lessp, Qprovide, Qrequire;
65
Lisp_Object Qyes_or_no_p_history;
66
Lisp_Object Qcursor_in_echo_area;
Karl Heuer's avatar
Karl Heuer committed
67
Lisp_Object Qwidget_type;
68
Lisp_Object Qcodeset, Qdays, Qmonths, Qpaper;
Jim Blandy's avatar
Jim Blandy committed
69

70
static int internal_equal (Lisp_Object , Lisp_Object, int, int);
71

72
extern long get_random (void);
73
extern void seed_random (long);
74 75 76 77

#ifndef HAVE_UNISTD_H
extern long time ();
#endif
78

Jim Blandy's avatar
Jim Blandy committed
79
DEFUN ("identity", Fidentity, Sidentity, 1, 1, 0,
Pavel Janík's avatar
Pavel Janík committed
80
       doc: /* Return the argument unchanged.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
81
  (Lisp_Object arg)
Jim Blandy's avatar
Jim Blandy committed
82 83 84 85 86
{
  return arg;
}

DEFUN ("random", Frandom, Srandom, 0, 1, 0,
87
       doc: /* Return a pseudo-random number.
Gerd Moellmann's avatar
Gerd Moellmann committed
88
All integers representable in Lisp are equally likely.
Kenichi Handa's avatar
Kenichi Handa committed
89
  On most systems, this is 29 bits' worth.
90 91 92
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
93
  (Lisp_Object limit)
Jim Blandy's avatar
Jim Blandy committed
94
{
95 96
  EMACS_INT val;
  Lisp_Object lispy_val;
97
  unsigned long denominator;
Jim Blandy's avatar
Jim Blandy committed
98

99
  if (EQ (limit, Qt))
100
    seed_random (getpid () + time (NULL));
101
  if (NATNUMP (limit) && XFASTINT (limit) != 0)
Jim Blandy's avatar
Jim Blandy committed
102
    {
103 104 105 106
      /* 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
107
	 it's possible to get a quotient larger than n; discarding
108
	 these values eliminates the bias that would otherwise appear
109
	 when using a large n.  */
110
      denominator = ((unsigned long)1 << VALBITS) / XFASTINT (limit);
111
      do
112
	val = get_random () / denominator;
113
      while (val >= XFASTINT (limit));
Jim Blandy's avatar
Jim Blandy committed
114
    }
115
  else
116
    val = get_random ();
117 118
  XSETINT (lispy_val, val);
  return lispy_val;
Jim Blandy's avatar
Jim Blandy committed
119 120 121 122 123
}

/* Random data-structure functions */

DEFUN ("length", Flength, Slength, 1, 1, 0,
124
       doc: /* Return the length of vector, list or string SEQUENCE.
Gerd Moellmann's avatar
Gerd Moellmann committed
125
A byte-code function object is also allowed.
John Paul Wallington's avatar
John Paul Wallington committed
126
If the string contains multibyte characters, this is not necessarily
Gerd Moellmann's avatar
Gerd Moellmann committed
127
the number of bytes in the string; it is the number of characters.
128
To get the number of bytes, use `string-bytes'.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
129
  (register Lisp_Object sequence)
Jim Blandy's avatar
Jim Blandy committed
130
{
131
  register Lisp_Object val;
Jim Blandy's avatar
Jim Blandy committed
132 133
  register int i;

134
  if (STRINGP (sequence))
135
    XSETFASTINT (val, SCHARS (sequence));
136
  else if (VECTORP (sequence))
Stefan Monnier's avatar
Stefan Monnier committed
137
    XSETFASTINT (val, ASIZE (sequence));
138
  else if (CHAR_TABLE_P (sequence))
139
    XSETFASTINT (val, MAX_CHAR);
140 141 142
  else if (BOOL_VECTOR_P (sequence))
    XSETFASTINT (val, XBOOL_VECTOR (sequence)->size);
  else if (COMPILEDP (sequence))
Stefan Monnier's avatar
Stefan Monnier committed
143
    XSETFASTINT (val, ASIZE (sequence) & PSEUDOVECTOR_SIZE_MASK);
144
  else if (CONSP (sequence))
Jim Blandy's avatar
Jim Blandy committed
145
    {
146 147
      i = 0;
      while (CONSP (sequence))
Jim Blandy's avatar
Jim Blandy committed
148
	{
149
	  sequence = XCDR (sequence);
150 151 152 153 154 155 156 157
	  ++i;

	  if (!CONSP (sequence))
	    break;

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

160
      CHECK_LIST_END (sequence, sequence);
161 162

      val = make_number (i);
Jim Blandy's avatar
Jim Blandy committed
163
    }
164
  else if (NILP (sequence))
165
    XSETFASTINT (val, 0);
Jim Blandy's avatar
Jim Blandy committed
166
  else
167
    wrong_type_argument (Qsequencep, sequence);
168

169
  return val;
Jim Blandy's avatar
Jim Blandy committed
170 171
}

172
/* This does not check for quits.  That is safe since it must terminate.  */
173 174

DEFUN ("safe-length", Fsafe_length, Ssafe_length, 1, 1, 0,
175
       doc: /* Return the length of a list, but avoid error or infinite loop.
Gerd Moellmann's avatar
Gerd Moellmann committed
176 177
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
178
which is at least the number of distinct elements.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
179
  (Lisp_Object list)
180 181 182 183 184 185
{
  Lisp_Object tail, halftail, length;
  int len = 0;

  /* halftail is used to detect circular lists.  */
  halftail = list;
186
  for (tail = list; CONSP (tail); tail = XCDR (tail))
187 188
    {
      if (EQ (tail, halftail) && len != 0)
189
	break;
190
      len++;
191
      if ((len & 1) == 0)
192
	halftail = XCDR (halftail);
193 194 195 196 197 198
    }

  XSETINT (length, len);
  return length;
}

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

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

221 222
  if (SCHARS (s1) != SCHARS (s2)
      || SBYTES (s1) != SBYTES (s2)
223
      || memcmp (SDATA (s1), SDATA (s2), SBYTES (s1)))
Jim Blandy's avatar
Jim Blandy committed
224 225 226 227
    return Qnil;
  return Qt;
}

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

247 248
  CHECK_STRING (str1);
  CHECK_STRING (str2);
249 250 251 252
  if (NILP (start1))
    start1 = make_number (0);
  if (NILP (start2))
    start2 = make_number (0);
253 254
  CHECK_NATNUM (start1);
  CHECK_NATNUM (start2);
255
  if (! NILP (end1))
256
    CHECK_NATNUM (end1);
257
  if (! NILP (end2))
258
    CHECK_NATNUM (end2);
259 260 261 262 263 264 265

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

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

266
  end1_char = SCHARS (str1);
267 268 269
  if (! NILP (end1) && end1_char > XINT (end1))
    end1_char = XINT (end1);

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

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

      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)
316
	return make_number (- i1 + XINT (start1));
317
      else
318
	return make_number (i1 - XINT (start1));
319 320 321 322 323 324 325 326 327 328
    }

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

  return Qt;
}

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

338
  if (SYMBOLP (s1))
339
    s1 = SYMBOL_NAME (s1);
340
  if (SYMBOLP (s2))
341
    s2 = SYMBOL_NAME (s2);
342 343
  CHECK_STRING (s1);
  CHECK_STRING (s2);
Jim Blandy's avatar
Jim Blandy committed
344

345 346
  i1 = i1_byte = i2 = i2_byte = 0;

347 348 349
  end = SCHARS (s1);
  if (end > SCHARS (s2))
    end = SCHARS (s2);
Jim Blandy's avatar
Jim Blandy committed
350

351
  while (i1 < end)
Jim Blandy's avatar
Jim Blandy committed
352
    {
353 354 355 356
      /* When we find a mismatch, we must compare the
	 characters, not just the bytes.  */
      int c1, c2;

357 358
      FETCH_STRING_CHAR_ADVANCE (c1, s1, i1, i1_byte);
      FETCH_STRING_CHAR_ADVANCE (c2, s2, i2, i2_byte);
359 360 361

      if (c1 != c2)
	return c1 < c2 ? Qt : Qnil;
Jim Blandy's avatar
Jim Blandy committed
362
    }
363
  return i1 < SCHARS (s2) ? Qt : Qnil;
Jim Blandy's avatar
Jim Blandy committed
364 365
}

366 367
static Lisp_Object concat (int nargs, Lisp_Object *args,
			   enum Lisp_Type target_type, int last_special);
Jim Blandy's avatar
Jim Blandy committed
368 369 370

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

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

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

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

421

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

  if (CHAR_TABLE_P (arg))
    {
432
      return copy_char_table (arg);
433 434 435 436 437 438
    }

  if (BOOL_VECTOR_P (arg))
    {
      Lisp_Object val;
      int size_in_chars
439 440
	= ((XBOOL_VECTOR (arg)->size + BOOL_VECTOR_BITS_PER_CHAR - 1)
	   / BOOL_VECTOR_BITS_PER_CHAR);
441 442

      val = Fmake_bool_vector (Flength (arg), Qnil);
443 444
      memcpy (XBOOL_VECTOR (val)->data, XBOOL_VECTOR (arg)->data,
	      size_in_chars);
445 446 447
      return val;
    }

448
  if (!CONSP (arg) && !VECTORP (arg) && !STRINGP (arg))
449 450
    wrong_type_argument (Qsequencep, arg);

Jim Blandy's avatar
Jim Blandy committed
451 452 453
  return concat (1, &arg, CONSP (arg) ? Lisp_Cons : XTYPE (arg), 0);
}

454 455
/* 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
456
struct textprop_rec
457 458 459 460 461 462
{
  int argnum;			/* refer to ARGS (arguments of `concat') */
  int from;			/* refer to ARGS[argnum] (argument string) */
  int to;			/* refer to VAL (the target string) */
};

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

487 488
  tail = Qnil;

Jim Blandy's avatar
Jim Blandy committed
489 490 491 492 493 494 495 496 497
  /* 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;

498
  /* Check each argument.  */
Jim Blandy's avatar
Jim Blandy committed
499 500 501
  for (argnum = 0; argnum < nargs; argnum++)
    {
      this = args[argnum];
502
      if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
503
	    || COMPILEDP (this) || BOOL_VECTOR_P (this)))
504
	wrong_type_argument (Qsequencep, this);
Jim Blandy's avatar
Jim Blandy committed
505 506
    }

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

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

      result_len += len;
563 564
      if (result_len < 0)
	error ("String overflow");
Jim Blandy's avatar
Jim Blandy committed
565 566
    }

567 568
  if (! some_multibyte)
    result_len_byte = result_len;
Jim Blandy's avatar
Jim Blandy committed
569

570
  /* Create the output object.  */
Jim Blandy's avatar
Jim Blandy committed
571
  if (target_type == Lisp_Cons)
572
    val = Fmake_list (make_number (result_len), Qnil);
573
  else if (target_type == Lisp_Vectorlike)
574
    val = Fmake_vector (make_number (result_len), Qnil);
575
  else if (some_multibyte)
576
    val = make_uninit_multibyte_string (result_len, result_len_byte);
577 578
  else
    val = make_uninit_string (result_len);
Jim Blandy's avatar
Jim Blandy committed
579

580 581 582
  /* 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
583

584
  /* Copy the contents of the args into the result.  */
Jim Blandy's avatar
Jim Blandy committed
585
  if (CONSP (val))
586
    tail = val, toindex = -1; /* -1 in toindex is flag we are making a list */
Jim Blandy's avatar
Jim Blandy committed
587
  else
588
    toindex = 0, toindex_byte = 0;
Jim Blandy's avatar
Jim Blandy committed
589 590

  prev = Qnil;
591
  if (STRINGP (val))
Kim F. Storm's avatar
Kim F. Storm committed
592
    SAFE_ALLOCA (textprops, struct textprop_rec *, sizeof (struct textprop_rec) * nargs);
Jim Blandy's avatar
Jim Blandy committed
593 594 595 596

  for (argnum = 0; argnum < nargs; argnum++)
    {
      Lisp_Object thislen;
597
      int thisleni = 0;
598
      register unsigned int thisindex = 0;
599
      register unsigned int thisindex_byte = 0;
Jim Blandy's avatar
Jim Blandy committed
600 601 602 603 604

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

605 606 607
      /* 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
608
	{
609
	  int thislen_byte = SBYTES (this);
610

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

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

Kenichi Handa's avatar
Kenichi Handa committed
713
  if (num_textprops > 0)
714
    {
715
      Lisp_Object props;
716
      int last_to_end = -1;
717

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

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

743
void
744
clear_string_char_byte_cache (void)
745 746 747 748
{
  string_char_byte_cache_string = Qnil;
}

749
/* Return the byte index corresponding to CHAR_INDEX in STRING.  */
750

751
EMACS_INT
752
string_char_to_byte (Lisp_Object string, EMACS_INT char_index)
753
{
754 755 756
  EMACS_INT i_byte;
  EMACS_INT best_below, best_below_byte;
  EMACS_INT best_above, best_above_byte;
757

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

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

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

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

802
  string_char_byte_cache_bytepos = i_byte;
803
  string_char_byte_cache_charpos = char_index;
804 805
  string_char_byte_cache_string = string;

806 807
  return i_byte;
}
808

809 810
/* Return the character index corresponding to BYTE_INDEX in STRING.  */

811
EMACS_INT
812
string_byte_to_char (Lisp_Object string, EMACS_INT byte_index)
813
{
814 815 816
  EMACS_INT i, i_byte;
  EMACS_INT best_below, best_below_byte;
  EMACS_INT best_above, best_above_byte;