fns.c 143 KB
Newer Older
Jim Blandy's avatar
Jim Blandy committed
1
/* Random utility Lisp functions.
2
   Copyright (C) 1985, 86, 87, 93, 94, 95, 97, 98, 99, 2000, 2001
Gerd Moellmann's avatar
Gerd Moellmann committed
3
   Free Software Foundation, Inc.
Jim Blandy's avatar
Jim Blandy committed
4 5 6 7 8

This file is part of GNU Emacs.

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

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
along with GNU Emacs; see the file COPYING.  If not, write to
19 20
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.  */
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>
Andreas Schwab's avatar
Andreas Schwab committed
28

Jim Blandy's avatar
Jim Blandy committed
29 30 31 32 33 34 35
/* 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 *****

#include "lisp.h"
#include "commands.h"
36
#include "charset.h"
Jim Blandy's avatar
Jim Blandy committed
37 38

#include "buffer.h"
Jim Blandy's avatar
Jim Blandy committed
39
#include "keyboard.h"
Stefan Monnier's avatar
Stefan Monnier committed
40
#include "keymap.h"
41
#include "intervals.h"
42 43
#include "frame.h"
#include "window.h"
Gerd Moellmann's avatar
Gerd Moellmann committed
44
#include "blockinput.h"
45
#if defined (HAVE_MENUS) && defined (HAVE_X_WINDOWS)
Andreas Schwab's avatar
Andreas Schwab committed
46 47
#include "xterm.h"
#endif
Jim Blandy's avatar
Jim Blandy committed
48

Karl Heuer's avatar
Karl Heuer committed
49 50 51 52
#ifndef NULL
#define NULL (void *)0
#endif

53 54 55 56
/* Nonzero enables use of dialog boxes for questions
   asked by mouse commands.  */
int use_dialog_box;

57 58 59
extern int minibuffer_auto_raise;
extern Lisp_Object minibuf_window;

60
Lisp_Object Qstring_lessp, Qprovide, Qrequire;
61
Lisp_Object Qyes_or_no_p_history;
62
Lisp_Object Qcursor_in_echo_area;
Karl Heuer's avatar
Karl Heuer committed
63
Lisp_Object Qwidget_type;
Jim Blandy's avatar
Jim Blandy committed
64

65 66
extern Lisp_Object Qinput_method_function;

67
static int internal_equal ();
68 69 70 71 72 73 74

extern long get_random ();
extern void seed_random ();

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

DEFUN ("random", Frandom, Srandom, 0, 1, 0,
85
       doc: /* Return a pseudo-random number.
Gerd Moellmann's avatar
Gerd Moellmann committed
86 87 88
All integers representable in Lisp are equally likely.
  On most systems, this is 28 bits' worth.
With positive integer argument N, return random number in interval [0,N).
89 90
With argument t, set the random number seed from the current time and pid. */)
     (n)
91
     Lisp_Object n;
Jim Blandy's avatar
Jim Blandy committed
92
{
93 94
  EMACS_INT val;
  Lisp_Object lispy_val;
95
  unsigned long denominator;
Jim Blandy's avatar
Jim Blandy committed
96

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

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

 retry:
134
  if (STRINGP (sequence))
135
    XSETFASTINT (val, SCHARS (sequence));
136 137 138
  else if (VECTORP (sequence))
    XSETFASTINT (val, XVECTOR (sequence)->size);
  else if (CHAR_TABLE_P (sequence))
139
    XSETFASTINT (val, MAX_CHAR);
140 141 142 143 144
  else if (BOOL_VECTOR_P (sequence))
    XSETFASTINT (val, XBOOL_VECTOR (sequence)->size);
  else if (COMPILEDP (sequence))
    XSETFASTINT (val, XVECTOR (sequence)->size & PSEUDOVECTOR_SIZE_MASK);
  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 161 162 163
      if (!NILP (sequence))
	wrong_type_argument (Qlistp, sequence);

      val = make_number (i);
Jim Blandy's avatar
Jim Blandy committed
164
    }
165
  else if (NILP (sequence))
166
    XSETFASTINT (val, 0);
Jim Blandy's avatar
Jim Blandy committed
167 168
  else
    {
169
      sequence = wrong_type_argument (Qsequencep, sequence);
Jim Blandy's avatar
Jim Blandy committed
170 171
      goto retry;
    }
172
  return val;
Jim Blandy's avatar
Jim Blandy committed
173 174
}

175 176 177 178
/* This does not check for quits.  That is safe
   since it must terminate.  */

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

  /* halftail is used to detect circular lists.  */
  halftail = list;
191
  for (tail = list; CONSP (tail); tail = XCDR (tail))
192 193
    {
      if (EQ (tail, halftail) && len != 0)
194
	break;
195
      len++;
196
      if ((len & 1) == 0)
197
	halftail = XCDR (halftail);
198 199 200 201 202 203
    }

  XSETINT (length, len);
  return length;
}

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

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

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

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

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 295 296 297
	  c1 = unibyte_char_to_multibyte (c1);
	}

      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 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324
	  c2 = unibyte_char_to_multibyte (c2);
	}

      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;
}

Jim Blandy's avatar
Jim Blandy 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 342
Symbols are also allowed; their print names are used instead. */)
     (s1, s2)
Jim Blandy's avatar
Jim Blandy committed
343 344 345
     register Lisp_Object s1, s2;
{
  register int end;
346
  register int i1, i1_byte, i2, i2_byte;
Jim Blandy's avatar
Jim Blandy committed
347

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

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

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

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

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

      if (c1 != c2)
	return c1 < c2 ? Qt : Qnil;
Jim Blandy's avatar
Jim Blandy committed
372
    }
373
  return i1 < SCHARS (s2) ? Qt : Qnil;
Jim Blandy's avatar
Jim Blandy committed
374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392
}

static Lisp_Object concat ();

/* ARGSUSED */
Lisp_Object
concat2 (s1, s2)
     Lisp_Object s1, s2;
{
#ifdef NO_ARG_ARRAY
  Lisp_Object args[2];
  args[0] = s1;
  args[1] = s2;
  return concat (2, args, Lisp_String, 0);
#else
  return concat (2, &s1, Lisp_String, 0);
#endif /* NO_ARG_ARRAY */
}

Richard M. Stallman's avatar
Richard M. Stallman committed
393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408
/* ARGSUSED */
Lisp_Object
concat3 (s1, s2, s3)
     Lisp_Object s1, s2, s3;
{
#ifdef NO_ARG_ARRAY
  Lisp_Object args[3];
  args[0] = s1;
  args[1] = s2;
  args[2] = s3;
  return concat (3, args, Lisp_String, 0);
#else
  return concat (3, &s1, Lisp_String, 0);
#endif /* NO_ARG_ARRAY */
}

Jim Blandy's avatar
Jim Blandy committed
409
DEFUN ("append", Fappend, Sappend, 0, MANY, 0,
410
       doc: /* Concatenate all the arguments and make the result a list.
Gerd Moellmann's avatar
Gerd Moellmann committed
411 412
The result is a list whose elements are the elements of all the arguments.
Each argument may be a list, vector or string.
413 414
The last argument is not copied, just used as the tail of the new list.
usage: (append &rest SEQUENCES)  */)
415
     (nargs, args)
Jim Blandy's avatar
Jim Blandy committed
416 417 418 419 420 421 422
     int nargs;
     Lisp_Object *args;
{
  return concat (nargs, args, Lisp_Cons, 1);
}

DEFUN ("concat", Fconcat, Sconcat, 0, MANY, 0,
423
       doc: /* Concatenate all the arguments and make the result a string.
Gerd Moellmann's avatar
Gerd Moellmann committed
424
The result is a string whose elements are the elements of all the arguments.
425 426
Each argument may be a string or a list or vector of characters (integers).
usage: (concat &rest SEQUENCES)  */)
427
     (nargs, args)
Jim Blandy's avatar
Jim Blandy committed
428 429 430 431 432 433 434
     int nargs;
     Lisp_Object *args;
{
  return concat (nargs, args, Lisp_String, 0);
}

DEFUN ("vconcat", Fvconcat, Svconcat, 0, MANY, 0,
435
       doc: /* Concatenate all the arguments and make the result a vector.
Gerd Moellmann's avatar
Gerd Moellmann committed
436
The result is a vector whose elements are the elements of all the arguments.
437 438
Each argument may be a list, vector or string.
usage: (vconcat &rest SEQUENCES)   */)
439
     (nargs, args)
Jim Blandy's avatar
Jim Blandy committed
440 441 442
     int nargs;
     Lisp_Object *args;
{
443
  return concat (nargs, args, Lisp_Vectorlike, 0);
Jim Blandy's avatar
Jim Blandy committed
444 445
}

John Paul Wallington's avatar
John Paul Wallington committed
446
/* Return a copy of a sub char table ARG.  The elements except for a
447 448 449
   nested sub char table are not copied.  */
static Lisp_Object
copy_sub_char_table (arg)
450
     Lisp_Object arg;
451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467
{
  Lisp_Object copy = make_sub_char_table (XCHAR_TABLE (arg)->defalt);
  int i;

  /* Copy all the contents.  */
  bcopy (XCHAR_TABLE (arg)->contents, XCHAR_TABLE (copy)->contents,
	 SUB_CHAR_TABLE_ORDINARY_SLOTS * sizeof (Lisp_Object));
  /* Recursively copy any sub char-tables in the ordinary slots.  */
  for (i = 32; i < SUB_CHAR_TABLE_ORDINARY_SLOTS; i++)
    if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg)->contents[i]))
      XCHAR_TABLE (copy)->contents[i]
	= copy_sub_char_table (XCHAR_TABLE (copy)->contents[i]);

  return copy;
}


Jim Blandy's avatar
Jim Blandy committed
468
DEFUN ("copy-sequence", Fcopy_sequence, Scopy_sequence, 1, 1, 0,
469
       doc: /* Return a copy of a list, vector or string.
Gerd Moellmann's avatar
Gerd Moellmann committed
470
The elements of a list or vector are not copied; they are shared
471 472
with the original. */)
     (arg)
Jim Blandy's avatar
Jim Blandy committed
473 474
     Lisp_Object arg;
{
Jim Blandy's avatar
Jim Blandy committed
475
  if (NILP (arg)) return arg;
476 477 478

  if (CHAR_TABLE_P (arg))
    {
479
      int i;
480 481
      Lisp_Object copy;

482
      copy = Fmake_char_table (XCHAR_TABLE (arg)->purpose, Qnil);
483
      /* Copy all the slots, including the extra ones.  */
484
      bcopy (XVECTOR (arg)->contents, XVECTOR (copy)->contents,
485 486
	     ((XCHAR_TABLE (arg)->size & PSEUDOVECTOR_SIZE_MASK)
	      * sizeof (Lisp_Object)));
487

488 489 490 491 492
      /* Recursively copy any sub char tables in the ordinary slots
         for multibyte characters.  */
      for (i = CHAR_TABLE_SINGLE_BYTE_SLOTS;
	   i < CHAR_TABLE_ORDINARY_SLOTS; i++)
	if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg)->contents[i]))
493
	  XCHAR_TABLE (copy)->contents[i]
494
	    = copy_sub_char_table (XCHAR_TABLE (copy)->contents[i]);
495 496 497 498 499 500 501 502

      return copy;
    }

  if (BOOL_VECTOR_P (arg))
    {
      Lisp_Object val;
      int size_in_chars
503
	= (XBOOL_VECTOR (arg)->size + BITS_PER_CHAR - 1) / BITS_PER_CHAR;
504 505 506 507 508 509 510

      val = Fmake_bool_vector (Flength (arg), Qnil);
      bcopy (XBOOL_VECTOR (arg)->data, XBOOL_VECTOR (val)->data,
	     size_in_chars);
      return val;
    }

511
  if (!CONSP (arg) && !VECTORP (arg) && !STRINGP (arg))
Jim Blandy's avatar
Jim Blandy committed
512 513 514 515
    arg = wrong_type_argument (Qsequencep, arg);
  return concat (1, &arg, CONSP (arg) ? Lisp_Cons : XTYPE (arg), 0);
}

516 517 518 519 520 521 522 523 524 525
/* In string STR of length LEN, see if bytes before STR[I] combine
   with bytes after STR[I] to form a single character.  If so, return
   the number of bytes after STR[I] which combine in this way.
   Otherwize, return 0.  */

static int
count_combining (str, len, i)
     unsigned char *str;
     int len, i;
{
526
  int j = i - 1, bytes;
527 528 529 530 531 532

  if (i == 0 || i == len || CHAR_HEAD_P (str[i]))
    return 0;
  while (j >= 0 && !CHAR_HEAD_P (str[j])) j--;
  if (j < 0 || ! BASE_LEADING_CODE_P (str[j]))
    return 0;
533 534
  PARSE_MULTIBYTE_SEQ (str + j, len - j, bytes);
  return (bytes <= i - j ? 0 : bytes - (i - j));
535 536 537 538
}

/* 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
539
struct textprop_rec
540 541 542 543 544 545
{
  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
546 547 548 549 550 551 552 553 554 555 556
static Lisp_Object
concat (nargs, args, target_type, last_special)
     int nargs;
     Lisp_Object *args;
     enum Lisp_Type target_type;
     int last_special;
{
  Lisp_Object val;
  register Lisp_Object tail;
  register Lisp_Object this;
  int toindex;
557
  int toindex_byte = 0;
558 559
  register int result_len;
  register int result_len_byte;
Jim Blandy's avatar
Jim Blandy committed
560 561 562
  register int argnum;
  Lisp_Object last_tail;
  Lisp_Object prev;
563
  int some_multibyte;
564 565 566 567 568
  /* 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.  */
569
  struct textprop_rec  *textprops = NULL;
Kenichi Handa's avatar
Kenichi Handa committed
570 571
  /* Number of elments in textprops.  */
  int num_textprops = 0;
Jim Blandy's avatar
Jim Blandy committed
572

573 574
  tail = Qnil;

Jim Blandy's avatar
Jim Blandy committed
575 576 577 578 579 580 581 582 583
  /* 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;

584
  /* Canonicalize each argument.  */
Jim Blandy's avatar
Jim Blandy committed
585 586 587
  for (argnum = 0; argnum < nargs; argnum++)
    {
      this = args[argnum];
588
      if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
589
	    || COMPILEDP (this) || BOOL_VECTOR_P (this)))
Jim Blandy's avatar
Jim Blandy committed
590 591 592 593 594
	{
	    args[argnum] = wrong_type_argument (Qsequencep, this);
	}
    }

595 596 597 598 599 600 601 602
  /* 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
603
    {
604
      int len;
Jim Blandy's avatar
Jim Blandy committed
605
      this = args[argnum];
606 607
      len = XFASTINT (Flength (this));
      if (target_type == Lisp_String)
608
	{
609 610
	  /* We must count the number of bytes needed in the string
	     as well as the number of characters.  */
611 612
	  int i;
	  Lisp_Object ch;
613
	  int this_len_byte;
614

615
	  if (VECTORP (this))
616
	    for (i = 0; i < len; i++)
617 618 619 620
	      {
		ch = XVECTOR (this)->contents[i];
		if (! INTEGERP (ch))
		  wrong_type_argument (Qintegerp, ch);
621
		this_len_byte = CHAR_BYTES (XINT (ch));
622
		result_len_byte += this_len_byte;
623
		if (!SINGLE_BYTE_CHAR_P (XINT (ch)))
624
		  some_multibyte = 1;
625
	      }
626 627
	  else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size > 0)
	    wrong_type_argument (Qintegerp, Faref (this, make_number (0)));
628
	  else if (CONSP (this))
629
	    for (; CONSP (this); this = XCDR (this))
630
	      {
631
		ch = XCAR (this);
632 633
		if (! INTEGERP (ch))
		  wrong_type_argument (Qintegerp, ch);
634
		this_len_byte = CHAR_BYTES (XINT (ch));
635
		result_len_byte += this_len_byte;
636
		if (!SINGLE_BYTE_CHAR_P (XINT (ch)))
637
		  some_multibyte = 1;
638
	      }
639
	  else if (STRINGP (this))
640
	    {
641
	      if (STRING_MULTIBYTE (this))
642 643
		{
		  some_multibyte = 1;
644
		  result_len_byte += SBYTES (this);
645 646
		}
	      else
647 648
		result_len_byte += count_size_as_multibyte (SDATA (this),
							    SCHARS (this));
649
	    }
650
	}
651 652

      result_len += len;
Jim Blandy's avatar
Jim Blandy committed
653 654
    }

655 656
  if (! some_multibyte)
    result_len_byte = result_len;
Jim Blandy's avatar
Jim Blandy committed
657

658
  /* Create the output object.  */
Jim Blandy's avatar
Jim Blandy committed
659
  if (target_type == Lisp_Cons)
660
    val = Fmake_list (make_number (result_len), Qnil);
661
  else if (target_type == Lisp_Vectorlike)
662
    val = Fmake_vector (make_number (result_len), Qnil);
663
  else if (some_multibyte)
664
    val = make_uninit_multibyte_string (result_len, result_len_byte);
665 666
  else
    val = make_uninit_string (result_len);
Jim Blandy's avatar
Jim Blandy committed
667

668 669 670
  /* 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
671

672
  /* Copy the contents of the args into the result.  */
Jim Blandy's avatar
Jim Blandy committed
673
  if (CONSP (val))
674
    tail = val, toindex = -1; /* -1 in toindex is flag we are making a list */
Jim Blandy's avatar
Jim Blandy committed
675
  else
676
    toindex = 0, toindex_byte = 0;
Jim Blandy's avatar
Jim Blandy committed
677 678

  prev = Qnil;
679
  if (STRINGP (val))
Kenichi Handa's avatar
Kenichi Handa committed
680 681
    textprops
      = (struct textprop_rec *) alloca (sizeof (struct textprop_rec) * nargs);
Jim Blandy's avatar
Jim Blandy committed
682 683 684 685

  for (argnum = 0; argnum < nargs; argnum++)
    {
      Lisp_Object thislen;
686
      int thisleni = 0;
687
      register unsigned int thisindex = 0;
688
      register unsigned int thisindex_byte = 0;
Jim Blandy's avatar
Jim Blandy committed
689 690 691 692 693

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

694 695 696
      /* 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
697
	{
698
	  int thislen_byte = SBYTES (this);
699 700
	  int combined;

701 702
	  bcopy (SDATA (this), SDATA (val) + toindex_byte,
		 SBYTES (this));
703
	  combined =  (some_multibyte && toindex_byte > 0
704
		       ? count_combining (SDATA (val),
705 706 707
					  toindex_byte + thislen_byte,
					  toindex_byte)
		       : 0);
708
	  if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
709
	    {
Kenichi Handa's avatar
Kenichi Handa committed
710
	      textprops[num_textprops].argnum = argnum;
711
	      /* We ignore text properties on characters being combined.  */
Kenichi Handa's avatar
Kenichi Handa committed
712 713
	      textprops[num_textprops].from = combined;
	      textprops[num_textprops++].to = toindex;
714
	    }
715
	  toindex_byte += thislen_byte;
716
	  toindex += thisleni - combined;
717
	  STRING_SET_CHARS (val, SCHARS (val) - combined);
718
	}
719 720 721
      /* Copy a single-byte string to a multibyte string.  */
      else if (STRINGP (this) && STRINGP (val))
	{
722
	  if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
723
	    {
Kenichi Handa's avatar
Kenichi Handa committed
724 725 726
	      textprops[num_textprops].argnum = argnum;
	      textprops[num_textprops].from = 0;
	      textprops[num_textprops++].to = toindex;
727
	    }
728 729 730
	  toindex_byte += copy_text (SDATA (this),
				     SDATA (val) + toindex_byte,
				     SCHARS (this), 0, 1);
731 732
	  toindex += thisleni;
	}
733 734 735 736 737 738 739 740 741 742
      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))
743
	      elt = XCAR (this), this = XCDR (this);
744 745 746
	    else if (thisindex >= thisleni)
	      break;
	    else if (STRINGP (this))
747
	      {
748
		int c;
749
		if (STRING_MULTIBYTE (this))
750
		  {
751 752 753
		    FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c, this,
							thisindex,
							thisindex_byte);
754
		    XSETFASTINT (elt, c);
755
		  }
756
		else
757
		  {
758
		    XSETFASTINT (elt, SREF (this, thisindex++));
759 760
		    if (some_multibyte
			&& (XINT (elt) >= 0240
761 762
			    || (XINT (elt) >= 0200
				&& ! NILP (Vnonascii_translation_table)))
763 764
			&& XINT (elt) < 0400)
		      {
765
			c = unibyte_char_to_multibyte (XINT (elt));
766 767
			XSETINT (elt, c);
		      }
768
		  }
769 770 771 772 773 774 775
	      }
	    else if (BOOL_VECTOR_P (this))
	      {
		int byte;
		byte = XBOOL_VECTOR (this)->data[thisindex / BITS_PER_CHAR];
		if (byte & (1 << (thisindex % BITS_PER_CHAR)))
		  elt = Qt;
776
		else
777 778
		  elt = Qnil;
		thisindex++;
779
	      }
780 781
	    else
	      elt = XVECTOR (this)->contents[thisindex++];
Jim Blandy's avatar
Jim Blandy committed
782

783 784
	    /* Store this element into the result.  */
	    if (toindex < 0)
Jim Blandy's avatar
Jim Blandy committed
785
	      {
786
		XSETCAR (tail, elt);
787
		prev = tail;
788
		tail = XCDR (tail);
Jim Blandy's avatar
Jim Blandy committed
789
	      }
790 791 792 793
	    else if (VECTORP (val))
	      XVECTOR (val)->contents[toindex++] = elt;
	    else
	      {
794
		CHECK_NUMBER (elt);
795 796
		if (SINGLE_BYTE_CHAR_P (XINT (elt)))
		  {
797 798 799
		    if (some_multibyte)
		      toindex_byte
			+= CHAR_STRING (XINT (elt),
800
					SDATA (val) + toindex_byte);
801
		    else
Ken Raeburn's avatar
Ken Raeburn committed
802
		      SSET (val, toindex_byte++, XINT (elt));
803 804
		    if (some_multibyte
			&& toindex_byte > 0
805
			&& count_combining (SDATA (val),
806
					    toindex_byte, toindex_byte - 1))
807
		      STRING_SET_CHARS (val, SCHARS (val) - 1);
808 809
		    else
		      toindex++;
810 811 812 813 814 815 816 817
		  }
		else
		  /* If we have any multibyte characters,
		     we already decided to make a multibyte string.  */
		  {
		    int c = XINT (elt);
		    /* P exists as a variable
		       to avoid a bug on the Masscomp C compiler.  */
Ken Raeburn's avatar
Ken Raeburn committed
818
		    unsigned char *p = SDATA (val) + toindex_byte;
819 820

		    toindex_byte += CHAR_STRING (c, p);
821 822 823 824
		    toindex++;
		  }
	      }
	  }
Jim Blandy's avatar
Jim Blandy committed
825
    }
Jim Blandy's avatar
Jim Blandy committed
826
  if (!NILP (prev))
827
    XSETCDR (prev, last_tail);
Jim Blandy's avatar
Jim Blandy committed
828

Kenichi Handa's avatar
Kenichi Handa committed
829
  if (num_textprops > 0)
830
    {
831
      Lisp_Object props;
832
      int last_to_end = -1;
833

Kenichi Handa's avatar
Kenichi Handa committed
834
      for (argnum = 0; argnum < num_textprops; argnum++)
835
	{
Kenichi Handa's avatar
Kenichi Handa committed
836
	  this = args[textprops[argnum].argnum];
837 838
	  props = text_property_list (this,
				      make_number (0),
839
				      make_number (SCHARS (this)),
840 841 842
				      Qnil);
	  /* If successive arguments have properites, be sure that the
	     value of `composition' property be the copy.  */
843
	  if (last_to_end == textprops[argnum].to)
844 845 846
	    make_composition_value_copy (props);
	  add_text_properties_from_list (val, props,
					 make_number (textprops[argnum].to));
847
	  last_to_end = textprops[argnum].to + SCHARS (this);
848 849
	}
    }
Karl Heuer's avatar
Karl Heuer committed
850
  return val;
Jim Blandy's avatar
Jim Blandy committed
851 852
}

853 854 855 856
static Lisp_Object string_char_byte_cache_string;
static int string_char_byte_cache_charpos;
static int string_char_byte_cache_bytepos;

857 858 859 860 861 862
void
clear_string_char_byte_cache ()
{
  string_char_byte_cache_string = Qnil;
}

863 864 865 866 867 868 869
/* Return the character index corresponding to CHAR_INDEX in STRING.  */

int
string_char_to_byte (string, char_index)
     Lisp_Object string;
     int char_index;
{
870 871 872
  int i, i_byte;
  int best_below, best_below_byte;
  int best_above, best_above_byte;
873 874 875 876

  if (! STRING_MULTIBYTE (string))
    return char_index;

877
  best_below = best_below_byte = 0;
878 879
  best_above = SCHARS (string);
  best_above_byte = SBYTES (string);
880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899

  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)
    {
      while (best_below < char_index)
	{
	  int c;
900 901
	  FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c, string,
					      best_below, best_below_byte);
902 903 904 905 906
	}
      i = best_below;
      i_byte = best_below_byte;
    }
  else
907
    {
908 909
      while (best_above > char_index)
	{
910
	  unsigned char *pend = SDATA (string) + best_above_byte;
911 912 913 914 915 916 917 918 919 920 921
	  unsigned char *pbeg = pend - best_above_byte;
	  unsigned char *p = pend - 1;
	  int bytes;

	  while (p > pbeg  && !CHAR_HEAD_P (*p)) p--;
	  PARSE_MULTIBYTE_SEQ (p, pend - p, bytes);
	  if (bytes == pend - p)
	    best_above_byte -= bytes;
	  else if (bytes > pend - p)
	    best_above_byte -= (pend - p);
	  else
922 923 924 925 926
	    best_above_byte--;
	  best_above--;
	}
      i = best_above;
      i_byte = best_above_byte;
927 928
    }

929 930 931 932
  string_char_byte_cache_bytepos = i_byte;
  string_char_byte_cache_charpos = i;
  string_char_byte_cache_string = string;

933 934
  return i_byte;
}
935

936 937 938 939 940 941 942
/* Return the character index corresponding to BYTE_INDEX in STRING.  */

int
string_byte_to_char (string, byte_index)
     Lisp_Object string;
     int byte_index;
{
943 944 945
  int i, i_byte;
  int best_below, best_below_byte;
  int best_above, best_above_byte;
946 947 948 949

  if (! STRING_MULTIBYTE (string))
    return byte_index;

950
  best_below = best_below_byte = 0;
951 952
  best_above = SCHARS (string);
  best_above_byte = SBYTES (string);
953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972

  if (EQ (string, string_char_byte_cache_string))
    {
      if (string_char_byte_cache_bytepos < byte_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 (byte_index - best_below_byte < best_above_byte - byte_index)
    {
      while (best_below_byte < byte_index)
	{
	  int c;
973 974
	  FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c, string,
					      best_below, best_below_byte);