fns.c 152 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, 02, 03, 2004
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

29 30 31
#ifndef MAC_OSX
/* On Mac OS X, defining this conflicts with precompiled headers.  */

Jim Blandy's avatar
Jim Blandy committed
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 *****
36 37 38

#endif  /* ! MAC_OSX */

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

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

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

62 63 64 65
/* Nonzero enables use of a file dialog for file name
   questions asked by mouse commands.  */
int use_file_dialog;

66 67
extern int minibuffer_auto_raise;
extern Lisp_Object minibuf_window;
68
extern Lisp_Object Vlocale_coding_system;
69

70
Lisp_Object Qstring_lessp, Qprovide, Qrequire;
71
Lisp_Object Qyes_or_no_p_history;
72
Lisp_Object Qcursor_in_echo_area;
Karl Heuer's avatar
Karl Heuer committed
73
Lisp_Object Qwidget_type;
74
Lisp_Object Qcodeset, Qdays, Qmonths, Qpaper;
Jim Blandy's avatar
Jim Blandy committed
75

76 77
extern Lisp_Object Qinput_method_function;

78
static int internal_equal ();
79 80 81 82 83 84 85

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

#ifndef HAVE_UNISTD_H
extern long time ();
#endif
86

Jim Blandy's avatar
Jim Blandy committed
87
DEFUN ("identity", Fidentity, Sidentity, 1, 1, 0,
Pavel Janík's avatar
Pavel Janík committed
88
       doc: /* Return the argument unchanged.  */)
89
     (arg)
Jim Blandy's avatar
Jim Blandy committed
90 91 92 93 94 95
     Lisp_Object arg;
{
  return arg;
}

DEFUN ("random", Frandom, Srandom, 0, 1, 0,
96
       doc: /* Return a pseudo-random number.
Gerd Moellmann's avatar
Gerd Moellmann committed
97
All integers representable in Lisp are equally likely.
98
  On most systems, this is 29 bits' worth.
Gerd Moellmann's avatar
Gerd Moellmann committed
99
With positive integer argument N, return random number in interval [0,N).
100 101
With argument t, set the random number seed from the current time and pid. */)
     (n)
102
     Lisp_Object n;
Jim Blandy's avatar
Jim Blandy committed
103
{
104 105
  EMACS_INT val;
  Lisp_Object lispy_val;
106
  unsigned long denominator;
Jim Blandy's avatar
Jim Blandy committed
107

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

DEFUN ("length", Flength, Slength, 1, 1, 0,
133
       doc: /* Return the length of vector, list or string SEQUENCE.
Gerd Moellmann's avatar
Gerd Moellmann committed
134
A byte-code function object is also allowed.
John Paul Wallington's avatar
John Paul Wallington committed
135
If the string contains multibyte characters, this is not necessarily
Gerd Moellmann's avatar
Gerd Moellmann committed
136
the number of bytes in the string; it is the number of characters.
137 138
To get the number of bytes, use `string-bytes'. */)
     (sequence)
139
     register Lisp_Object sequence;
Jim Blandy's avatar
Jim Blandy committed
140
{
141
  register Lisp_Object val;
Jim Blandy's avatar
Jim Blandy committed
142 143 144
  register int i;

 retry:
145
  if (STRINGP (sequence))
146
    XSETFASTINT (val, SCHARS (sequence));
147 148
  else if (VECTORP (sequence))
    XSETFASTINT (val, XVECTOR (sequence)->size);
149 150
  else if (SUB_CHAR_TABLE_P (sequence))
    XSETFASTINT (val, SUB_CHAR_TABLE_ORDINARY_SLOTS);
151
  else if (CHAR_TABLE_P (sequence))
152
    XSETFASTINT (val, MAX_CHAR);
153 154 155 156 157
  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
158
    {
159 160
      i = 0;
      while (CONSP (sequence))
Jim Blandy's avatar
Jim Blandy committed
161
	{
162
	  sequence = XCDR (sequence);
163 164 165 166 167 168 169 170
	  ++i;

	  if (!CONSP (sequence))
	    break;

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

173 174 175 176
      if (!NILP (sequence))
	wrong_type_argument (Qlistp, sequence);

      val = make_number (i);
Jim Blandy's avatar
Jim Blandy committed
177
    }
178
  else if (NILP (sequence))
179
    XSETFASTINT (val, 0);
Jim Blandy's avatar
Jim Blandy committed
180 181
  else
    {
182
      sequence = wrong_type_argument (Qsequencep, sequence);
Jim Blandy's avatar
Jim Blandy committed
183 184
      goto retry;
    }
185
  return val;
Jim Blandy's avatar
Jim Blandy committed
186 187
}

188 189 190 191
/* This does not check for quits.  That is safe
   since it must terminate.  */

DEFUN ("safe-length", Fsafe_length, Ssafe_length, 1, 1, 0,
192
       doc: /* Return the length of a list, but avoid error or infinite loop.
Gerd Moellmann's avatar
Gerd Moellmann committed
193 194
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
195 196
which is at least the number of distinct elements. */)
     (list)
197 198 199 200 201 202 203
     Lisp_Object list;
{
  Lisp_Object tail, halftail, length;
  int len = 0;

  /* halftail is used to detect circular lists.  */
  halftail = list;
204
  for (tail = list; CONSP (tail); tail = XCDR (tail))
205 206
    {
      if (EQ (tail, halftail) && len != 0)
207
	break;
208
      len++;
209
      if ((len & 1) == 0)
210
	halftail = XCDR (halftail);
211 212 213 214 215 216
    }

  XSETINT (length, len);
  return length;
}

217
DEFUN ("string-bytes", Fstring_bytes, Sstring_bytes, 1, 1, 0,
218 219 220
       doc: /* Return the number of bytes in STRING.
If STRING is a multibyte string, this is greater than the length of STRING. */)
     (string)
221
     Lisp_Object string;
222
{
223
  CHECK_STRING (string);
224
  return make_number (SBYTES (string));
225 226
}

Jim Blandy's avatar
Jim Blandy committed
227
DEFUN ("string-equal", Fstring_equal, Sstring_equal, 2, 2, 0,
228
       doc: /* Return t if two strings have identical contents.
Gerd Moellmann's avatar
Gerd Moellmann committed
229
Case is significant, but text properties are ignored.
230 231
Symbols are also allowed; their print names are used instead. */)
     (s1, s2)
Jim Blandy's avatar
Jim Blandy committed
232 233
     register Lisp_Object s1, s2;
{
234
  if (SYMBOLP (s1))
235
    s1 = SYMBOL_NAME (s1);
236
  if (SYMBOLP (s2))
237
    s2 = SYMBOL_NAME (s2);
238 239
  CHECK_STRING (s1);
  CHECK_STRING (s2);
Jim Blandy's avatar
Jim Blandy committed
240

241 242 243
  if (SCHARS (s1) != SCHARS (s2)
      || SBYTES (s1) != SBYTES (s2)
      || bcmp (SDATA (s1), SDATA (s2), SBYTES (s1)))
Jim Blandy's avatar
Jim Blandy committed
244 245 246 247
    return Qnil;
  return Qt;
}

248
DEFUN ("compare-strings", Fcompare_strings,
249
       Scompare_strings, 6, 7, 0,
250
doc: /* Compare the contents of two strings, converting to multibyte if needed.
Gerd Moellmann's avatar
Gerd Moellmann committed
251 252 253 254 255 256 257 258 259 260 261
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;
262 263
  N - 1 is the number of characters that match at the beginning. */)
     (str1, start1, end1, str2, start2, end2, ignore_case)
264 265 266 267 268
     Lisp_Object str1, start1, end1, start2, str2, end2, ignore_case;
{
  register int end1_char, end2_char;
  register int i1, i1_byte, i2, i2_byte;

269 270
  CHECK_STRING (str1);
  CHECK_STRING (str2);
271 272 273 274
  if (NILP (start1))
    start1 = make_number (0);
  if (NILP (start2))
    start2 = make_number (0);
275 276
  CHECK_NATNUM (start1);
  CHECK_NATNUM (start2);
277
  if (! NILP (end1))
278
    CHECK_NATNUM (end1);
279
  if (! NILP (end2))
280
    CHECK_NATNUM (end2);
281 282 283 284 285 286 287

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

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

288
  end1_char = SCHARS (str1);
289 290 291
  if (! NILP (end1) && end1_char > XINT (end1))
    end1_char = XINT (end1);

292
  end2_char = SCHARS (str2);
293 294 295 296 297 298 299 300 301 302
  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))
303
	FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1, str1, i1, i1_byte);
304 305
      else
	{
306
	  c1 = SREF (str1, i1++);
307 308 309 310
	  c1 = unibyte_char_to_multibyte (c1);
	}

      if (STRING_MULTIBYTE (str2))
311
	FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2, str2, i2, i2_byte);
312 313
      else
	{
314
	  c2 = SREF (str2, i2++);
315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337
	  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)
338
	return make_number (- i1 + XINT (start1));
339
      else
340
	return make_number (i1 - XINT (start1));
341 342 343 344 345 346 347 348 349 350
    }

  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
351
DEFUN ("string-lessp", Fstring_lessp, Sstring_lessp, 2, 2, 0,
352
       doc: /* Return t if first arg string is less than second in lexicographic order.
Gerd Moellmann's avatar
Gerd Moellmann committed
353
Case is significant.
354 355
Symbols are also allowed; their print names are used instead. */)
     (s1, s2)
Jim Blandy's avatar
Jim Blandy committed
356 357 358
     register Lisp_Object s1, s2;
{
  register int end;
359
  register int i1, i1_byte, i2, i2_byte;
Jim Blandy's avatar
Jim Blandy committed
360

361
  if (SYMBOLP (s1))
362
    s1 = SYMBOL_NAME (s1);
363
  if (SYMBOLP (s2))
364
    s2 = SYMBOL_NAME (s2);
365 366
  CHECK_STRING (s1);
  CHECK_STRING (s2);
Jim Blandy's avatar
Jim Blandy committed
367

368 369
  i1 = i1_byte = i2 = i2_byte = 0;

370 371 372
  end = SCHARS (s1);
  if (end > SCHARS (s2))
    end = SCHARS (s2);
Jim Blandy's avatar
Jim Blandy committed
373

374
  while (i1 < end)
Jim Blandy's avatar
Jim Blandy committed
375
    {
376 377 378 379
      /* When we find a mismatch, we must compare the
	 characters, not just the bytes.  */
      int c1, c2;

380 381
      FETCH_STRING_CHAR_ADVANCE (c1, s1, i1, i1_byte);
      FETCH_STRING_CHAR_ADVANCE (c2, s2, i2, i2_byte);
382 383 384

      if (c1 != c2)
	return c1 < c2 ? Qt : Qnil;
Jim Blandy's avatar
Jim Blandy committed
385
    }
386
  return i1 < SCHARS (s2) ? Qt : Qnil;
Jim Blandy's avatar
Jim Blandy committed
387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405
}

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
406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421
/* 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
422
DEFUN ("append", Fappend, Sappend, 0, MANY, 0,
423
       doc: /* Concatenate all the arguments and make the result a list.
Gerd Moellmann's avatar
Gerd Moellmann committed
424 425
The result is a list whose elements are the elements of all the arguments.
Each argument may be a list, vector or string.
426 427
The last argument is not copied, just used as the tail of the new list.
usage: (append &rest SEQUENCES)  */)
428
     (nargs, args)
Jim Blandy's avatar
Jim Blandy committed
429 430 431 432 433 434 435
     int nargs;
     Lisp_Object *args;
{
  return concat (nargs, args, Lisp_Cons, 1);
}

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

DEFUN ("vconcat", Fvconcat, Svconcat, 0, MANY, 0,
448
       doc: /* Concatenate all the arguments and make the result a vector.
Gerd Moellmann's avatar
Gerd Moellmann committed
449
The result is a vector whose elements are the elements of all the arguments.
450 451
Each argument may be a list, vector or string.
usage: (vconcat &rest SEQUENCES)   */)
452
     (nargs, args)
Jim Blandy's avatar
Jim Blandy committed
453 454 455
     int nargs;
     Lisp_Object *args;
{
456
  return concat (nargs, args, Lisp_Vectorlike, 0);
Jim Blandy's avatar
Jim Blandy committed
457 458
}

John Paul Wallington's avatar
John Paul Wallington committed
459
/* Return a copy of a sub char table ARG.  The elements except for a
460 461 462
   nested sub char table are not copied.  */
static Lisp_Object
copy_sub_char_table (arg)
463
     Lisp_Object arg;
464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480
{
  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
481
DEFUN ("copy-sequence", Fcopy_sequence, Scopy_sequence, 1, 1, 0,
Dave Love's avatar
Dave Love committed
482
       doc: /* Return a copy of a list, vector, string or char-table.
Gerd Moellmann's avatar
Gerd Moellmann committed
483
The elements of a list or vector are not copied; they are shared
484 485
with the original. */)
     (arg)
Jim Blandy's avatar
Jim Blandy committed
486 487
     Lisp_Object arg;
{
Jim Blandy's avatar
Jim Blandy committed
488
  if (NILP (arg)) return arg;
489 490 491

  if (CHAR_TABLE_P (arg))
    {
492
      int i;
493 494
      Lisp_Object copy;

495
      copy = Fmake_char_table (XCHAR_TABLE (arg)->purpose, Qnil);
496
      /* Copy all the slots, including the extra ones.  */
497
      bcopy (XVECTOR (arg)->contents, XVECTOR (copy)->contents,
498 499
	     ((XCHAR_TABLE (arg)->size & PSEUDOVECTOR_SIZE_MASK)
	      * sizeof (Lisp_Object)));
500

501 502 503 504 505
      /* 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]))
506
	  XCHAR_TABLE (copy)->contents[i]
507
	    = copy_sub_char_table (XCHAR_TABLE (copy)->contents[i]);
508 509 510 511 512 513 514 515

      return copy;
    }

  if (BOOL_VECTOR_P (arg))
    {
      Lisp_Object val;
      int size_in_chars
516 517
	= ((XBOOL_VECTOR (arg)->size + BOOL_VECTOR_BITS_PER_CHAR - 1)
	   / BOOL_VECTOR_BITS_PER_CHAR);
518 519 520 521 522 523 524

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

525
  if (!CONSP (arg) && !VECTORP (arg) && !STRINGP (arg))
Jim Blandy's avatar
Jim Blandy committed
526 527 528 529
    arg = wrong_type_argument (Qsequencep, arg);
  return concat (1, &arg, CONSP (arg) ? Lisp_Cons : XTYPE (arg), 0);
}

530 531
/* 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
532
struct textprop_rec
533 534 535 536 537 538
{
  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
539 540 541 542 543 544 545 546 547 548 549
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;
550
  int toindex_byte = 0;
551 552
  register int result_len;
  register int result_len_byte;
Jim Blandy's avatar
Jim Blandy committed
553 554 555
  register int argnum;
  Lisp_Object last_tail;
  Lisp_Object prev;
556
  int some_multibyte;
557 558 559 560 561
  /* 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.  */
562
  struct textprop_rec  *textprops = NULL;
Kenichi Handa's avatar
Kenichi Handa committed
563 564
  /* Number of elments in textprops.  */
  int num_textprops = 0;
Jim Blandy's avatar
Jim Blandy committed
565

566 567
  tail = Qnil;

Jim Blandy's avatar
Jim Blandy committed
568 569 570 571 572 573 574 575 576
  /* 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;

577
  /* Canonicalize each argument.  */
Jim Blandy's avatar
Jim Blandy committed
578 579 580
  for (argnum = 0; argnum < nargs; argnum++)
    {
      this = args[argnum];
581
      if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
582
	    || COMPILEDP (this) || BOOL_VECTOR_P (this)))
Jim Blandy's avatar
Jim Blandy committed
583 584 585 586 587
	{
	    args[argnum] = wrong_type_argument (Qsequencep, this);
	}
    }

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

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

      result_len += len;
Jim Blandy's avatar
Jim Blandy committed
646 647
    }

648 649
  if (! some_multibyte)
    result_len_byte = result_len;
Jim Blandy's avatar
Jim Blandy committed
650

651
  /* Create the output object.  */
Jim Blandy's avatar
Jim Blandy committed
652
  if (target_type == Lisp_Cons)
653
    val = Fmake_list (make_number (result_len), Qnil);
654
  else if (target_type == Lisp_Vectorlike)
655
    val = Fmake_vector (make_number (result_len), Qnil);
656
  else if (some_multibyte)
657
    val = make_uninit_multibyte_string (result_len, result_len_byte);
658 659
  else
    val = make_uninit_string (result_len);
Jim Blandy's avatar
Jim Blandy committed
660

661 662 663
  /* 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
664

665
  /* Copy the contents of the args into the result.  */
Jim Blandy's avatar
Jim Blandy committed
666
  if (CONSP (val))
667
    tail = val, toindex = -1; /* -1 in toindex is flag we are making a list */
Jim Blandy's avatar
Jim Blandy committed
668
  else
669
    toindex = 0, toindex_byte = 0;
Jim Blandy's avatar
Jim Blandy committed
670 671

  prev = Qnil;
672
  if (STRINGP (val))
Kenichi Handa's avatar
Kenichi Handa committed
673 674
    textprops
      = (struct textprop_rec *) alloca (sizeof (struct textprop_rec) * nargs);
Jim Blandy's avatar
Jim Blandy committed
675 676 677 678

  for (argnum = 0; argnum < nargs; argnum++)
    {
      Lisp_Object thislen;
679
      int thisleni = 0;
680
      register unsigned int thisindex = 0;
681
      register unsigned int thisindex_byte = 0;
Jim Blandy's avatar
Jim Blandy committed
682 683 684 685 686

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

687 688 689
      /* 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
690
	{
691
	  int thislen_byte = SBYTES (this);
692

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

769 770
	    /* Store this element into the result.  */
	    if (toindex < 0)
Jim Blandy's avatar
Jim Blandy committed
771
	      {
772
		XSETCAR (tail, elt);
773
		prev = tail;
774
		tail = XCDR (tail);
Jim Blandy's avatar
Jim Blandy committed
775
	      }
776 777 778 779
	    else if (VECTORP (val))
	      XVECTOR (val)->contents[toindex++] = elt;
	    else
	      {
780
		CHECK_NUMBER (elt);
781 782
		if (SINGLE_BYTE_CHAR_P (XINT (elt)))
		  {
783 784 785
		    if (some_multibyte)
		      toindex_byte
			+= CHAR_STRING (XINT (elt),
786
					SDATA (val) + toindex_byte);
787
		    else
Ken Raeburn's avatar
Ken Raeburn committed
788
		      SSET (val, toindex_byte++, XINT (elt));
Kenichi Handa's avatar
Kenichi Handa committed
789
		    toindex++;
790 791 792 793 794 795 796 797
		  }
		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
798
		    unsigned char *p = SDATA (val) + toindex_byte;
799 800

		    toindex_byte += CHAR_STRING (c, p);
801 802 803 804
		    toindex++;
		  }
	      }
	  }
Jim Blandy's avatar
Jim Blandy committed
805
    }
Jim Blandy's avatar
Jim Blandy committed
806
  if (!NILP (prev))
807
    XSETCDR (prev, last_tail);
Jim Blandy's avatar
Jim Blandy committed
808

Kenichi Handa's avatar
Kenichi Handa committed
809
  if (num_textprops > 0)
810
    {
811
      Lisp_Object props;
812
      int last_to_end = -1;
813

Kenichi Handa's avatar
Kenichi Handa committed
814
      for (argnum = 0; argnum < num_textprops; argnum++)
815
	{
Kenichi Handa's avatar
Kenichi Handa committed
816
	  this = args[textprops[argnum].argnum];
817 818
	  props = text_property_list (this,
				      make_number (0),
819
				      make_number (SCHARS (this)),
820 821 822
				      Qnil);
	  /* If successive arguments have properites, be sure that the
	     value of `composition' property be the copy.  */
823
	  if (last_to_end == textprops[argnum].to)
824 825 826
	    make_composition_value_copy (props);
	  add_text_properties_from_list (val, props,
					 make_number (textprops[argnum].to));
827
	  last_to_end = textprops[argnum].to + SCHARS (this);
828 829
	}
    }
Karl Heuer's avatar
Karl Heuer committed
830
  return val;
Jim Blandy's avatar
Jim Blandy committed
831 832
}

833 834 835 836
static Lisp_Object string_char_byte_cache_string;
static int string_char_byte_cache_charpos;
static int string_char_byte_cache_bytepos;

837 838 839 840 841 842
void
clear_string_char_byte_cache ()
{
  string_char_byte_cache_string = Qnil;
}

843 844 845 846 847 848 849
/* Return the character index corresponding to CHAR_INDEX in STRING.  */

int
string_char_to_byte (string, char_index)
     Lisp_Object string;
     int char_index;
{
850 851 852
  int i, i_byte;
  int best_below, best_below_byte;
  int best_above, best_above_byte;
853

854
  best_below = best_below_byte = 0;
855 856
  best_above = SCHARS (string);
  best_above_byte = SBYTES (string);
857 858
  if (best_above == best_above_byte)
    return char_index;
859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878

  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;
879 880
	  FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c, string,
					      best_below, best_below_byte);
881 882 883 884 885
	}
      i = best_below;
      i_byte = best_below_byte;
    }
  else
886
    {
887 888
      while (best_above > char_index)
	{
889
	  unsigned char *pend = SDATA (string) + best_above_byte;
890 891 892 893 894 895 896 897 898 899 900
	  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
901 902 903 904 905
	    best_above_byte--;
	  best_above--;
	}
      i = best_above;
      i_byte = best_above_byte;
906 907
    }

908 909 910 911
  string_char_byte_cache_bytepos = i_byte;
  string_char_byte_cache_charpos = i;
  string_char_byte_cache_string = string;

912 913
  return i_byte;
}
914

915 916 917 918 919 920 921
/* Return the character index corresponding to BYTE_INDEX in STRING.  */

int
string_byte_to_char (string, byte_index)
     Lisp_Object string;
     int byte_index;
{
922 923 924
  int i, i_byte;
  int best_below, best_below_byte;
  int best_above, best_above_byte;
925

926
  best_below = best_below_byte = 0;
927 928
  best_above = SCHARS (string);
  best_above_byte = SBYTES (string);
929 930
  if (best_above == best_above_byte)
    return byte_index;
931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950

  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;
951 952
	  FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c, string,
					      best_below, best_below_byte);