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 52
#ifdef HAVE_MENUS
#if defined (HAVE_X_WINDOWS)
Andreas Schwab's avatar
Andreas Schwab committed
53
#include "xterm.h"
54 55 56
#elif defined (MAC_OS)
#include "macterm.h"
#endif
Andreas Schwab's avatar
Andreas Schwab committed
57
#endif
Jim Blandy's avatar
Jim Blandy committed
58

Karl Heuer's avatar
Karl Heuer committed
59
#ifndef NULL
60
#define NULL ((POINTER_TYPE *)0)
Karl Heuer's avatar
Karl Heuer committed
61 62
#endif

63 64 65 66
/* Nonzero enables use of dialog boxes for questions
   asked by mouse commands.  */
int use_dialog_box;

67 68 69 70
/* Nonzero enables use of a file dialog for file name
   questions asked by mouse commands.  */
int use_file_dialog;

71 72
extern int minibuffer_auto_raise;
extern Lisp_Object minibuf_window;
73
extern Lisp_Object Vlocale_coding_system;
74
extern int load_in_progress;
75

76
Lisp_Object Qstring_lessp, Qprovide, Qrequire;
77
Lisp_Object Qyes_or_no_p_history;
78
Lisp_Object Qcursor_in_echo_area;
Karl Heuer's avatar
Karl Heuer committed
79
Lisp_Object Qwidget_type;
80
Lisp_Object Qcodeset, Qdays, Qmonths, Qpaper;
Jim Blandy's avatar
Jim Blandy committed
81

82 83
extern Lisp_Object Qinput_method_function;

84
static int internal_equal P_ ((Lisp_Object , Lisp_Object, int, int));
85 86

extern long get_random ();
87
extern void seed_random P_ ((long));
88 89 90 91

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

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

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

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

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

	  if (!CONSP (sequence))
	    break;

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

179 180 181 182
      if (!NILP (sequence))
	wrong_type_argument (Qlistp, sequence);

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

194
/* This does not check for quits.  That is safe since it must terminate.  */
195 196

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

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

  XSETINT (length, len);
  return length;
}

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

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

246 247 248
  if (SCHARS (s1) != SCHARS (s2)
      || SBYTES (s1) != SBYTES (s2)
      || bcmp (SDATA (s1), SDATA (s2), SBYTES (s1)))
Jim Blandy's avatar
Jim Blandy committed
249 250 251 252
    return Qnil;
  return Qt;
}

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

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

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

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

293
  end1_char = SCHARS (str1);
294 295 296
  if (! NILP (end1) && end1_char > XINT (end1))
    end1_char = XINT (end1);

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

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

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

366
  if (SYMBOLP (s1))
367
    s1 = SYMBOL_NAME (s1);
368
  if (SYMBOLP (s2))
369
    s2 = SYMBOL_NAME (s2);
370 371
  CHECK_STRING (s1);
  CHECK_STRING (s2);
Jim Blandy's avatar
Jim Blandy committed
372

373 374
  i1 = i1_byte = i2 = i2_byte = 0;

375 376 377
  end = SCHARS (s1);
  if (end > SCHARS (s2))
    end = SCHARS (s2);
Jim Blandy's avatar
Jim Blandy committed
378

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

385 386
      FETCH_STRING_CHAR_ADVANCE (c1, s1, i1, i1_byte);
      FETCH_STRING_CHAR_ADVANCE (c2, s2, i2, i2_byte);
387 388 389

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

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

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

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

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

  if (CHAR_TABLE_P (arg))
    {
498
      int i;
499 500
      Lisp_Object copy;

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

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

      return copy;
    }

  if (BOOL_VECTOR_P (arg))
    {
      Lisp_Object val;
      int size_in_chars
522 523
	= ((XBOOL_VECTOR (arg)->size + BOOL_VECTOR_BITS_PER_CHAR - 1)
	   / BOOL_VECTOR_BITS_PER_CHAR);
524 525 526 527 528 529 530

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

531
  if (!CONSP (arg) && !VECTORP (arg) && !STRINGP (arg))
Jim Blandy's avatar
Jim Blandy committed
532 533 534 535
    arg = wrong_type_argument (Qsequencep, arg);
  return concat (1, &arg, CONSP (arg) ? Lisp_Cons : XTYPE (arg), 0);
}

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

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

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

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

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

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

		    toindex_byte += CHAR_STRING (c, p);
807 808 809 810
		    toindex++;
		  }
	      }
	  }
Jim Blandy's avatar
Jim Blandy committed
811
    }
Jim Blandy's avatar
Jim Blandy committed
812
  if (!NILP (prev))
813
    XSETCDR (prev, last_tail);
Jim Blandy's avatar
Jim Blandy committed
814

Kenichi Handa's avatar
Kenichi Handa committed
815
  if (num_textprops > 0)
816
    {
817
      Lisp_Object props;
818
      int last_to_end = -1;
819

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

  SAFE_FREE ();
Karl Heuer's avatar
Karl Heuer committed
838
  return val;
Jim Blandy's avatar
Jim Blandy committed
839 840
}

841 842 843 844
static Lisp_Object string_char_byte_cache_string;
static int string_char_byte_cache_charpos;
static int string_char_byte_cache_bytepos;

845 846 847 848 849 850
void
clear_string_char_byte_cache ()
{
  string_char_byte_cache_string = Qnil;
}

851 852 853 854 855 856 857
/* Return the character index corresponding to CHAR_INDEX in STRING.  */

int
string_char_to_byte (string, char_index)
     Lisp_Object string;
     int char_index;
{
858 859 860
  int i, i_byte;
  int best_below, best_below_byte;
  int best_above, best_above_byte;
861

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

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

916 917 918 919
  string_char_byte_cache_bytepos = i_byte;
  string_char_byte_cache_charpos = i;
  string_char_byte_cache_string = string;

920 921
  return i_byte;
}
922

923 924 925 926 927 928 929
/* Return the character index corresponding to BYTE_INDEX in STRING.  */

int
string_byte_to_char (string, byte_index)
     Lisp_Object string;
     int byte_index;
{