fns.c 157 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,
4
                 2005, 2006 Free Software Foundation, Inc.
Jim Blandy's avatar
Jim Blandy committed
5 6 7 8 9

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
10
the Free Software Foundation; either version 2, or (at your option)
Jim Blandy's avatar
Jim Blandy committed
11 12 13 14 15 16 17 18 19
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
Lute Kamstra's avatar
Lute Kamstra committed
20 21
the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
Boston, MA 02110-1301, USA.  */
Jim Blandy's avatar
Jim Blandy committed
22

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

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

30 31
#ifndef MAC_OS
/* On Mac OS, defining this conflicts with precompiled headers.  */
32

Jim Blandy's avatar
Jim Blandy committed
33 34 35 36
/* 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 *****
37 38 39

#endif  /* ! MAC_OSX */

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

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

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

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

67 68
extern int minibuffer_auto_raise;
extern Lisp_Object minibuf_window;
69
extern Lisp_Object Vlocale_coding_system;
70
extern int load_in_progress;
71

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

78 79
extern Lisp_Object Qinput_method_function;

80
static int internal_equal P_ ((Lisp_Object , Lisp_Object, int, int));
81 82

extern long get_random ();
83
extern void seed_random P_ ((long));
84 85 86 87

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

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

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

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

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

	  if (!CONSP (sequence))
	    break;

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

175 176 177 178
      if (!NILP (sequence))
	wrong_type_argument (Qlistp, sequence);

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

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

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

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

  XSETINT (length, len);
  return length;
}

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

John Paul Wallington's avatar
John Paul Wallington committed
460
/* Return a copy of a sub char table ARG.  The elements except for a
461 462 463
   nested sub char table are not copied.  */
static Lisp_Object
copy_sub_char_table (arg)
464
     Lisp_Object arg;
465
{
466
  Lisp_Object copy = make_sub_char_table (Qnil);
467 468
  int i;

469
  XCHAR_TABLE (copy)->defalt = XCHAR_TABLE (arg)->defalt;
470 471 472 473 474 475 476 477 478 479 480 481 482
  /* 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
483
DEFUN ("copy-sequence", Fcopy_sequence, Scopy_sequence, 1, 1, 0,
Dave Love's avatar
Dave Love committed
484
       doc: /* Return a copy of a list, vector, string or char-table.
Gerd Moellmann's avatar
Gerd Moellmann committed
485
The elements of a list or vector are not copied; they are shared
486 487
with the original. */)
     (arg)
Jim Blandy's avatar
Jim Blandy committed
488 489
     Lisp_Object arg;
{
Jim Blandy's avatar
Jim Blandy committed
490
  if (NILP (arg)) return arg;
491 492 493

  if (CHAR_TABLE_P (arg))
    {
494
      int i;
495 496
      Lisp_Object copy;

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

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

      return copy;
    }

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

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

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

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

569 570
  tail = Qnil;

Jim Blandy's avatar
Jim Blandy committed
571 572 573 574 575 576 577 578 579
  /* 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;

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

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

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

      result_len += len;
Jim Blandy's avatar
Jim Blandy committed
649 650
    }

651 652
  if (! some_multibyte)
    result_len_byte = result_len;
Jim Blandy's avatar
Jim Blandy committed
653

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

664 665 666
  /* 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
667

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

  prev = Qnil;
675
  if (STRINGP (val))
Kim F. Storm's avatar
Kim F. Storm committed
676
    SAFE_ALLOCA (textprops, struct textprop_rec *, sizeof (struct textprop_rec) * nargs);
Jim Blandy's avatar
Jim Blandy committed
677 678 679 680

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

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

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

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

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

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

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

Kenichi Handa's avatar
Kenichi Handa committed
816
      for (argnum = 0; argnum < num_textprops; argnum++)
817
	{
Kenichi Handa's avatar
Kenichi Handa committed
818
	  this = args[textprops[argnum].argnum];
819 820
	  props = text_property_list (this,
				      make_number (0),
821
				      make_number (SCHARS (this)),
822 823 824
				      Qnil);
	  /* If successive arguments have properites, be sure that the
	     value of `composition' property be the copy.  */
825
	  if (last_to_end == textprops[argnum].to)
826 827 828
	    make_composition_value_copy (props);
	  add_text_properties_from_list (val, props,
					 make_number (textprops[argnum].to));
829
	  last_to_end = textprops[argnum].to + SCHARS (this);
830 831
	}
    }
Kim F. Storm's avatar
Kim F. Storm committed
832 833

  SAFE_FREE ();
Karl Heuer's avatar
Karl Heuer committed
834
  return val;
Jim Blandy's avatar
Jim Blandy committed
835 836
}

837 838 839 840
static Lisp_Object string_char_byte_cache_string;
static int string_char_byte_cache_charpos;
static int string_char_byte_cache_bytepos;

841 842 843 844 845 846
void
clear_string_char_byte_cache ()
{
  string_char_byte_cache_string = Qnil;
}

847 848 849 850 851 852 853
/* Return the character index corresponding to CHAR_INDEX in STRING.  */

int
string_char_to_byte (string, char_index)
     Lisp_Object string;
     int char_index;
{
854 855 856
  int i, i_byte;
  int best_below, best_below_byte;
  int best_above, best_above_byte;
857

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

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

912 913 914 915
  string_char_byte_cache_bytepos = i_byte;
  string_char_byte_cache_charpos = i;
  string_char_byte_cache_string = string;

916 917
  return i_byte;
}
918

919 920 921 922 923 924 925
/* Return the character index corresponding to BYTE_INDEX in STRING.  */

int
string_byte_to_char (string, byte_index)
     Lisp_Object string;
     int byte_index;
{
926 927 928
  int i, i_byte;
  int best_below, best_below_byte;
  int best_above, best_above_byte;
929