(search_command): Check LIM in valid range
[bpt/emacs.git] / src / editfns.c
CommitLineData
35692fe0 1/* Lisp functions pertaining to editing.
31c8f881 2 Copyright (C) 1985,86,87,89,93,94,95,96,97,98 Free Software Foundation, Inc.
35692fe0
JB
3
4This file is part of GNU Emacs.
5
6GNU Emacs is free software; you can redistribute it and/or modify
7it under the terms of the GNU General Public License as published by
7c938215 8the Free Software Foundation; either version 2, or (at your option)
35692fe0
JB
9any later version.
10
11GNU Emacs is distributed in the hope that it will be useful,
12but WITHOUT ANY WARRANTY; without even the implied warranty of
13MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14GNU General Public License for more details.
15
16You should have received a copy of the GNU General Public License
17along with GNU Emacs; see the file COPYING. If not, write to
5a7670bf
RS
18the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
19Boston, MA 02111-1307, USA. */
35692fe0
JB
20
21
738429d1
JB
22#include <sys/types.h>
23
18160b98 24#include <config.h>
bfb61299
JB
25
26#ifdef VMS
956ace37 27#include "vms-pwd.h"
bfb61299 28#else
35692fe0 29#include <pwd.h>
bfb61299
JB
30#endif
31
35692fe0 32#include "lisp.h"
74d6d8c5 33#include "intervals.h"
35692fe0 34#include "buffer.h"
fb8106e8 35#include "charset.h"
35692fe0
JB
36#include "window.h"
37
956ace37 38#include "systime.h"
35692fe0
JB
39
40#define min(a, b) ((a) < (b) ? (a) : (b))
41#define max(a, b) ((a) > (b) ? (a) : (b))
42
a03eaf1c
RS
43#ifndef NULL
44#define NULL 0
45#endif
46
c59b5089
PE
47extern char **environ;
48extern Lisp_Object make_time ();
b1b0ee5a 49extern void insert_from_buffer ();
94751666 50static int tm_diff ();
260e2e2a 51static void update_buffer_properties ();
b771d0da 52size_t emacs_strftime ();
a92ae0ce 53void set_time_zone_rule ();
260e2e2a
KH
54
55Lisp_Object Vbuffer_access_fontify_functions;
56Lisp_Object Qbuffer_access_fontify_functions;
57Lisp_Object Vbuffer_access_fontified_property;
b1b0ee5a 58
e3ed8469
KH
59Lisp_Object Fuser_full_name ();
60
35692fe0
JB
61/* Some static data, and a function to initialize it for each run */
62
63Lisp_Object Vsystem_name;
35b34f72
KH
64Lisp_Object Vuser_real_login_name; /* login name of current user ID */
65Lisp_Object Vuser_full_name; /* full name of current user */
66Lisp_Object Vuser_login_name; /* user name from LOGNAME or USER */
35692fe0
JB
67
68void
69init_editfns ()
70{
52b14ac0 71 char *user_name;
35692fe0
JB
72 register unsigned char *p, *q, *r;
73 struct passwd *pw; /* password entry for the current user */
35692fe0
JB
74 Lisp_Object tem;
75
76 /* Set up system_name even when dumping. */
ac988277 77 init_system_name ();
35692fe0
JB
78
79#ifndef CANNOT_DUMP
80 /* Don't bother with this on initial start when just dumping out */
81 if (!initialized)
82 return;
83#endif /* not CANNOT_DUMP */
84
85 pw = (struct passwd *) getpwuid (getuid ());
87485d6f
MW
86#ifdef MSDOS
87 /* We let the real user name default to "root" because that's quite
88 accurate on MSDOG and because it lets Emacs find the init file.
89 (The DVX libraries override the Djgpp libraries here.) */
35b34f72 90 Vuser_real_login_name = build_string (pw ? pw->pw_name : "root");
87485d6f 91#else
35b34f72 92 Vuser_real_login_name = build_string (pw ? pw->pw_name : "unknown");
87485d6f 93#endif
35692fe0 94
52b14ac0
JB
95 /* Get the effective user name, by consulting environment variables,
96 or the effective uid if those are unset. */
2c9ae24e 97 user_name = (char *) getenv ("LOGNAME");
35692fe0 98 if (!user_name)
4691c06d
RS
99#ifdef WINDOWSNT
100 user_name = (char *) getenv ("USERNAME"); /* it's USERNAME on NT */
101#else /* WINDOWSNT */
2c9ae24e 102 user_name = (char *) getenv ("USER");
4691c06d 103#endif /* WINDOWSNT */
52b14ac0
JB
104 if (!user_name)
105 {
106 pw = (struct passwd *) getpwuid (geteuid ());
107 user_name = (char *) (pw ? pw->pw_name : "unknown");
108 }
35b34f72 109 Vuser_login_name = build_string (user_name);
35692fe0 110
52b14ac0
JB
111 /* If the user name claimed in the environment vars differs from
112 the real uid, use the claimed name to find the full name. */
35b34f72 113 tem = Fstring_equal (Vuser_login_name, Vuser_real_login_name);
3415b0e9
RS
114 Vuser_full_name = Fuser_full_name (NILP (tem)? make_number (geteuid())
115 : Vuser_login_name);
35692fe0 116
8f1e2d16 117 p = (unsigned char *) getenv ("NAME");
9d36d071
RS
118 if (p)
119 Vuser_full_name = build_string (p);
3347526c
RS
120 else if (NILP (Vuser_full_name))
121 Vuser_full_name = build_string ("unknown");
35692fe0
JB
122}
123\f
124DEFUN ("char-to-string", Fchar_to_string, Schar_to_string, 1, 1, 0,
fb8106e8 125 "Convert arg CHAR to a string containing multi-byte form of that character.")
2591ec64
EN
126 (character)
127 Lisp_Object character;
35692fe0 128{
fb8106e8 129 int len;
d11ba98c 130 unsigned char workbuf[4], *str;
fb8106e8 131
2591ec64 132 CHECK_NUMBER (character, 0);
35692fe0 133
fb8106e8 134 len = CHAR_STRING (XFASTINT (character), workbuf, str);
1f24f4fd 135 return make_multibyte_string (str, 1, len);
35692fe0
JB
136}
137
138DEFUN ("string-to-char", Fstring_to_char, Sstring_to_char, 1, 1, 0,
fb8106e8
KH
139 "Convert arg STRING to a character, the first character of that string.\n\
140A multibyte character is handled correctly.")
2591ec64
EN
141 (string)
142 register Lisp_Object string;
35692fe0
JB
143{
144 register Lisp_Object val;
145 register struct Lisp_String *p;
2591ec64 146 CHECK_STRING (string, 0);
2591ec64 147 p = XSTRING (string);
35692fe0 148 if (p->size)
84246b95 149 XSETFASTINT (val, STRING_CHAR (p->data, p->size_byte));
35692fe0 150 else
55561c63 151 XSETFASTINT (val, 0);
35692fe0
JB
152 return val;
153}
154\f
155static Lisp_Object
ec1c14f6
RS
156buildmark (charpos, bytepos)
157 int charpos, bytepos;
35692fe0
JB
158{
159 register Lisp_Object mark;
160 mark = Fmake_marker ();
ec1c14f6 161 set_marker_both (mark, Qnil, charpos, bytepos);
35692fe0
JB
162 return mark;
163}
164
165DEFUN ("point", Fpoint, Spoint, 0, 0, 0,
166 "Return value of point, as an integer.\n\
167Beginning of buffer is position (point-min)")
168 ()
169{
170 Lisp_Object temp;
6ec8bbd2 171 XSETFASTINT (temp, PT);
35692fe0
JB
172 return temp;
173}
174
175DEFUN ("point-marker", Fpoint_marker, Spoint_marker, 0, 0, 0,
176 "Return value of point, as a marker object.")
177 ()
178{
ec1c14f6 179 return buildmark (PT, PT_BYTE);
35692fe0
JB
180}
181
182int
183clip_to_bounds (lower, num, upper)
184 int lower, num, upper;
185{
186 if (num < lower)
187 return lower;
188 else if (num > upper)
189 return upper;
190 else
191 return num;
192}
193
194DEFUN ("goto-char", Fgoto_char, Sgoto_char, 1, 1, "NGoto char: ",
195 "Set point to POSITION, a number or marker.\n\
fb8106e8
KH
196Beginning of buffer is position (point-min), end is (point-max).\n\
197If the position is in the middle of a multibyte form,\n\
198the actual point is set at the head of the multibyte form\n\
199except in the case that `enable-multibyte-characters' is nil.")
2591ec64
EN
200 (position)
201 register Lisp_Object position;
35692fe0 202{
fb8106e8
KH
203 int pos;
204 unsigned char *p;
205
ec1c14f6
RS
206 if (MARKERP (position))
207 {
208 pos = marker_position (position);
209 if (pos < BEGV)
210 SET_PT_BOTH (BEGV, BEGV_BYTE);
211 else if (pos > ZV)
212 SET_PT_BOTH (ZV, ZV_BYTE);
213 else
214 SET_PT_BOTH (pos, marker_byte_position (position));
215
216 return position;
217 }
218
2591ec64 219 CHECK_NUMBER_COERCE_MARKER (position, 0);
35692fe0 220
fb8106e8 221 pos = clip_to_bounds (BEGV, XINT (position), ZV);
fb8106e8 222 SET_PT (pos);
2591ec64 223 return position;
35692fe0
JB
224}
225
226static Lisp_Object
227region_limit (beginningp)
228 int beginningp;
229{
646d9d18 230 extern Lisp_Object Vmark_even_if_inactive; /* Defined in callint.c. */
35692fe0 231 register Lisp_Object m;
c9dd14e1
RM
232 if (!NILP (Vtransient_mark_mode) && NILP (Vmark_even_if_inactive)
233 && NILP (current_buffer->mark_active))
234 Fsignal (Qmark_inactive, Qnil);
35692fe0 235 m = Fmarker_position (current_buffer->mark);
56a98455 236 if (NILP (m)) error ("There is no region now");
6ec8bbd2
KH
237 if ((PT < XFASTINT (m)) == beginningp)
238 return (make_number (PT));
35692fe0
JB
239 else
240 return (m);
241}
242
243DEFUN ("region-beginning", Fregion_beginning, Sregion_beginning, 0, 0, 0,
244 "Return position of beginning of region, as an integer.")
245 ()
246{
247 return (region_limit (1));
248}
249
250DEFUN ("region-end", Fregion_end, Sregion_end, 0, 0, 0,
251 "Return position of end of region, as an integer.")
252 ()
253{
254 return (region_limit (0));
255}
256
35692fe0
JB
257DEFUN ("mark-marker", Fmark_marker, Smark_marker, 0, 0, 0,
258 "Return this buffer's mark, as a marker object.\n\
259Watch out! Moving this marker changes the mark position.\n\
260If you set the marker not to point anywhere, the buffer will have no mark.")
261 ()
262{
263 return current_buffer->mark;
264}
c9ed721d
RS
265\f
266DEFUN ("line-beginning-position", Fline_beginning_position, Sline_beginning_position,
267 0, 1, 0,
268 "Return the character position of the first character on the current line.\n\
269With argument N not nil or 1, move forward N - 1 lines first.\n\
270If scan reaches end of buffer, return that position.\n\
271This function does not move point.")
272 (n)
273 Lisp_Object n;
274{
ec1c14f6 275 register int orig, orig_byte, end;
c9ed721d
RS
276
277 if (NILP (n))
278 XSETFASTINT (n, 1);
279 else
280 CHECK_NUMBER (n, 0);
281
282 orig = PT;
ec1c14f6 283 orig_byte = PT_BYTE;
c9ed721d
RS
284 Fforward_line (make_number (XINT (n) - 1));
285 end = PT;
ec1c14f6 286 SET_PT_BOTH (orig, orig_byte);
35692fe0 287
c9ed721d
RS
288 return make_number (end);
289}
290
291DEFUN ("line-end-position", Fline_end_position, Sline_end_position,
292 0, 1, 0,
293 "Return the character position of the last character on the current line.\n\
294With argument N not nil or 1, move forward N - 1 lines first.\n\
295If scan reaches end of buffer, return that position.\n\
296This function does not move point.")
297 (n)
298 Lisp_Object n;
299{
300 if (NILP (n))
301 XSETFASTINT (n, 1);
302 else
303 CHECK_NUMBER (n, 0);
304
305 return make_number (find_before_next_newline
306 (PT, 0, XINT (n) - (XINT (n) <= 0)));
307}
308\f
35692fe0
JB
309Lisp_Object
310save_excursion_save ()
311{
0e2c9c70
JB
312 register int visible = (XBUFFER (XWINDOW (selected_window)->buffer)
313 == current_buffer);
35692fe0
JB
314
315 return Fcons (Fpoint_marker (),
aea4a109 316 Fcons (Fcopy_marker (current_buffer->mark, Qnil),
9772455e
RS
317 Fcons (visible ? Qt : Qnil,
318 current_buffer->mark_active)));
35692fe0
JB
319}
320
321Lisp_Object
322save_excursion_restore (info)
4ad8681a 323 Lisp_Object info;
35692fe0 324{
4ad8681a
RS
325 Lisp_Object tem, tem1, omark, nmark;
326 struct gcpro gcpro1, gcpro2, gcpro3;
35692fe0
JB
327
328 tem = Fmarker_buffer (Fcar (info));
329 /* If buffer being returned to is now deleted, avoid error */
330 /* Otherwise could get error here while unwinding to top level
331 and crash */
332 /* In that case, Fmarker_buffer returns nil now. */
56a98455 333 if (NILP (tem))
35692fe0 334 return Qnil;
4ad8681a
RS
335
336 omark = nmark = Qnil;
337 GCPRO3 (info, omark, nmark);
338
35692fe0
JB
339 Fset_buffer (tem);
340 tem = Fcar (info);
341 Fgoto_char (tem);
342 unchain_marker (tem);
343 tem = Fcar (Fcdr (info));
03d18690 344 omark = Fmarker_position (current_buffer->mark);
35692fe0 345 Fset_marker (current_buffer->mark, tem, Fcurrent_buffer ());
03d18690 346 nmark = Fmarker_position (tem);
35692fe0
JB
347 unchain_marker (tem);
348 tem = Fcdr (Fcdr (info));
ef580991
RS
349#if 0 /* We used to make the current buffer visible in the selected window
350 if that was true previously. That avoids some anomalies.
351 But it creates others, and it wasn't documented, and it is simpler
352 and cleaner never to alter the window/buffer connections. */
9772455e
RS
353 tem1 = Fcar (tem);
354 if (!NILP (tem1)
0e2c9c70 355 && current_buffer != XBUFFER (XWINDOW (selected_window)->buffer))
35692fe0 356 Fswitch_to_buffer (Fcurrent_buffer (), Qnil);
ef580991 357#endif /* 0 */
9772455e
RS
358
359 tem1 = current_buffer->mark_active;
360 current_buffer->mark_active = Fcdr (tem);
9fed2b18
RS
361 if (!NILP (Vrun_hooks))
362 {
03d18690
RS
363 /* If mark is active now, and either was not active
364 or was at a different place, run the activate hook. */
9fed2b18 365 if (! NILP (current_buffer->mark_active))
03d18690
RS
366 {
367 if (! EQ (omark, nmark))
368 call1 (Vrun_hooks, intern ("activate-mark-hook"));
369 }
370 /* If mark has ceased to be active, run deactivate hook. */
9fed2b18
RS
371 else if (! NILP (tem1))
372 call1 (Vrun_hooks, intern ("deactivate-mark-hook"));
373 }
4ad8681a 374 UNGCPRO;
35692fe0
JB
375 return Qnil;
376}
377
378DEFUN ("save-excursion", Fsave_excursion, Ssave_excursion, 0, UNEVALLED, 0,
379 "Save point, mark, and current buffer; execute BODY; restore those things.\n\
380Executes BODY just like `progn'.\n\
381The values of point, mark and the current buffer are restored\n\
9772455e
RS
382even in case of abnormal exit (throw or error).\n\
383The state of activation of the mark is also restored.")
35692fe0
JB
384 (args)
385 Lisp_Object args;
386{
387 register Lisp_Object val;
388 int count = specpdl_ptr - specpdl;
389
390 record_unwind_protect (save_excursion_restore, save_excursion_save ());
4bc8c7d2
RS
391
392 val = Fprogn (args);
393 return unbind_to (count, val);
394}
395
396DEFUN ("save-current-buffer", Fsave_current_buffer, Ssave_current_buffer, 0, UNEVALLED, 0,
397 "Save the current buffer; execute BODY; restore the current buffer.\n\
398Executes BODY just like `progn'.")
399 (args)
400 Lisp_Object args;
401{
402 register Lisp_Object val;
403 int count = specpdl_ptr - specpdl;
404
cb5e5f74 405 record_unwind_protect (set_buffer_if_live, Fcurrent_buffer ());
4bc8c7d2 406
35692fe0
JB
407 val = Fprogn (args);
408 return unbind_to (count, val);
409}
410\f
411DEFUN ("buffer-size", Fbufsize, Sbufsize, 0, 0, 0,
412 "Return the number of characters in the current buffer.")
413 ()
414{
415 Lisp_Object temp;
55561c63 416 XSETFASTINT (temp, Z - BEG);
35692fe0
JB
417 return temp;
418}
419
420DEFUN ("point-min", Fpoint_min, Spoint_min, 0, 0, 0,
421 "Return the minimum permissible value of point in the current buffer.\n\
4c390850 422This is 1, unless narrowing (a buffer restriction) is in effect.")
35692fe0
JB
423 ()
424{
425 Lisp_Object temp;
55561c63 426 XSETFASTINT (temp, BEGV);
35692fe0
JB
427 return temp;
428}
429
430DEFUN ("point-min-marker", Fpoint_min_marker, Spoint_min_marker, 0, 0, 0,
431 "Return a marker to the minimum permissible value of point in this buffer.\n\
4c390850 432This is the beginning, unless narrowing (a buffer restriction) is in effect.")
35692fe0
JB
433 ()
434{
ec1c14f6 435 return buildmark (BEGV, BEGV_BYTE);
35692fe0
JB
436}
437
438DEFUN ("point-max", Fpoint_max, Spoint_max, 0, 0, 0,
439 "Return the maximum permissible value of point in the current buffer.\n\
4c390850
RS
440This is (1+ (buffer-size)), unless narrowing (a buffer restriction)\n\
441is in effect, in which case it is less.")
35692fe0
JB
442 ()
443{
444 Lisp_Object temp;
55561c63 445 XSETFASTINT (temp, ZV);
35692fe0
JB
446 return temp;
447}
448
449DEFUN ("point-max-marker", Fpoint_max_marker, Spoint_max_marker, 0, 0, 0,
450 "Return a marker to the maximum permissible value of point in this buffer.\n\
4c390850
RS
451This is (1+ (buffer-size)), unless narrowing (a buffer restriction)\n\
452is in effect, in which case it is less.")
35692fe0
JB
453 ()
454{
ec1c14f6 455 return buildmark (ZV, ZV_BYTE);
35692fe0
JB
456}
457
7df74da6
RS
458DEFUN ("position-bytes", Fposition_bytes, Sposition_bytes, 1, 1, 0,
459 "Return the byte position for character position POSITION.")
460 (position)
80e01f8d 461 Lisp_Object position;
7df74da6 462{
fa8a5a15
KH
463 CHECK_NUMBER_COERCE_MARKER (position, 1);
464 return make_number (CHAR_TO_BYTE (XINT (position)));
7df74da6
RS
465}
466\f
850a8179
JB
467DEFUN ("following-char", Ffollowing_char, Sfollowing_char, 0, 0, 0,
468 "Return the character following point, as a number.\n\
fb8106e8
KH
469At the end of the buffer or accessible region, return 0.\n\
470If `enable-multibyte-characters' is nil or point is not\n\
471 at character boundary, multibyte form is ignored,\n\
472 and only one byte following point is returned as a character.")
35692fe0
JB
473 ()
474{
475 Lisp_Object temp;
6ec8bbd2 476 if (PT >= ZV)
55561c63 477 XSETFASTINT (temp, 0);
850a8179 478 else
ec1c14f6 479 XSETFASTINT (temp, FETCH_CHAR (PT_BYTE));
35692fe0
JB
480 return temp;
481}
482
850a8179
JB
483DEFUN ("preceding-char", Fprevious_char, Sprevious_char, 0, 0, 0,
484 "Return the character preceding point, as a number.\n\
fb8106e8
KH
485At the beginning of the buffer or accessible region, return 0.\n\
486If `enable-multibyte-characters' is nil or point is not\n\
487 at character boundary, multi-byte form is ignored,\n\
488 and only one byte preceding point is returned as a character.")
35692fe0
JB
489 ()
490{
491 Lisp_Object temp;
6ec8bbd2 492 if (PT <= BEGV)
55561c63 493 XSETFASTINT (temp, 0);
fb8106e8
KH
494 else if (!NILP (current_buffer->enable_multibyte_characters))
495 {
ec1c14f6 496 int pos = PT_BYTE;
fb8106e8
KH
497 DEC_POS (pos);
498 XSETFASTINT (temp, FETCH_CHAR (pos));
499 }
35692fe0 500 else
ec1c14f6 501 XSETFASTINT (temp, FETCH_BYTE (PT_BYTE - 1));
35692fe0
JB
502 return temp;
503}
504
505DEFUN ("bobp", Fbobp, Sbobp, 0, 0, 0,
ec1c14f6 506 "Return t if point is at the beginning of the buffer.\n\
35692fe0
JB
507If the buffer is narrowed, this means the beginning of the narrowed part.")
508 ()
509{
6ec8bbd2 510 if (PT == BEGV)
35692fe0
JB
511 return Qt;
512 return Qnil;
513}
514
515DEFUN ("eobp", Feobp, Seobp, 0, 0, 0,
ec1c14f6 516 "Return t if point is at the end of the buffer.\n\
35692fe0
JB
517If the buffer is narrowed, this means the end of the narrowed part.")
518 ()
519{
6ec8bbd2 520 if (PT == ZV)
35692fe0
JB
521 return Qt;
522 return Qnil;
523}
524
525DEFUN ("bolp", Fbolp, Sbolp, 0, 0, 0,
ec1c14f6 526 "Return t if point is at the beginning of a line.")
35692fe0
JB
527 ()
528{
ec1c14f6 529 if (PT == BEGV || FETCH_BYTE (PT_BYTE - 1) == '\n')
35692fe0
JB
530 return Qt;
531 return Qnil;
532}
533
534DEFUN ("eolp", Feolp, Seolp, 0, 0, 0,
ec1c14f6 535 "Return t if point is at the end of a line.\n\
35692fe0
JB
536`End of a line' includes point being at the end of the buffer.")
537 ()
538{
ec1c14f6 539 if (PT == ZV || FETCH_BYTE (PT_BYTE) == '\n')
35692fe0
JB
540 return Qt;
541 return Qnil;
542}
543
fa1d3816 544DEFUN ("char-after", Fchar_after, Schar_after, 0, 1, 0,
35692fe0
JB
545 "Return character in current buffer at position POS.\n\
546POS is an integer or a buffer pointer.\n\
fb8106e8
KH
547If POS is out of range, the value is nil.\n\
548If `enable-multibyte-characters' is nil or POS is not at character boundary,\n\
549 multi-byte form is ignored, and only one byte at POS\n\
550 is returned as a character.")
35692fe0
JB
551 (pos)
552 Lisp_Object pos;
553{
ec1c14f6 554 register int pos_byte;
35692fe0 555 register Lisp_Object val;
35692fe0 556
fa1d3816 557 if (NILP (pos))
ec1c14f6
RS
558 return make_number (FETCH_CHAR (PT_BYTE));
559
560 if (MARKERP (pos))
561 pos_byte = marker_byte_position (pos);
fa1d3816
RS
562 else
563 {
564 CHECK_NUMBER_COERCE_MARKER (pos, 0);
ec1c14f6
RS
565
566 pos_byte = CHAR_TO_BYTE (XINT (pos));
fa1d3816 567 }
35692fe0 568
9d1af5be 569 if (pos_byte < BEGV_BYTE || pos_byte >= ZV_BYTE)
ec1c14f6
RS
570 return Qnil;
571
572 return make_number (FETCH_CHAR (pos_byte));
35692fe0 573}
fb8106e8 574
fa1d3816 575DEFUN ("char-before", Fchar_before, Schar_before, 0, 1, 0,
fb8106e8
KH
576 "Return character in current buffer preceding position POS.\n\
577POS is an integer or a buffer pointer.\n\
578If POS is out of range, the value is nil.\n\
579If `enable-multibyte-characters' is nil or POS is not at character boundary,\n\
580multi-byte form is ignored, and only one byte preceding POS\n\
581is returned as a character.")
582 (pos)
583 Lisp_Object pos;
584{
585 register Lisp_Object val;
ec1c14f6 586 register int pos_byte;
fb8106e8 587
fa1d3816 588 if (NILP (pos))
ec1c14f6
RS
589 pos_byte = PT_BYTE;
590 else if (MARKERP (pos))
591 pos_byte = marker_byte_position (pos);
fa1d3816
RS
592 else
593 {
594 CHECK_NUMBER_COERCE_MARKER (pos, 0);
fb8106e8 595
ec1c14f6 596 pos_byte = CHAR_TO_BYTE (XINT (pos));
fa1d3816 597 }
fb8106e8 598
ec1c14f6 599 if (pos_byte <= BEGV_BYTE || pos_byte > ZV_BYTE)
20713324
RS
600 return Qnil;
601
fb8106e8
KH
602 if (!NILP (current_buffer->enable_multibyte_characters))
603 {
ec1c14f6
RS
604 DEC_POS (pos_byte);
605 XSETFASTINT (val, FETCH_CHAR (pos_byte));
fb8106e8
KH
606 }
607 else
608 {
ec1c14f6
RS
609 pos_byte--;
610 XSETFASTINT (val, FETCH_BYTE (pos_byte));
fb8106e8
KH
611 }
612 return val;
613}
35692fe0 614\f
87485d6f 615DEFUN ("user-login-name", Fuser_login_name, Suser_login_name, 0, 1, 0,
35692fe0
JB
616 "Return the name under which the user logged in, as a string.\n\
617This is based on the effective uid, not the real uid.\n\
2c9ae24e 618Also, if the environment variable LOGNAME or USER is set,\n\
87485d6f
MW
619that determines the value of this function.\n\n\
620If optional argument UID is an integer, return the login name of the user\n\
621with that uid, or nil if there is no such user.")
622 (uid)
623 Lisp_Object uid;
35692fe0 624{
87485d6f
MW
625 struct passwd *pw;
626
f8a0e364
RS
627 /* Set up the user name info if we didn't do it before.
628 (That can happen if Emacs is dumpable
629 but you decide to run `temacs -l loadup' and not dump. */
35b34f72 630 if (INTEGERP (Vuser_login_name))
f8a0e364 631 init_editfns ();
87485d6f
MW
632
633 if (NILP (uid))
35b34f72 634 return Vuser_login_name;
87485d6f
MW
635
636 CHECK_NUMBER (uid, 0);
637 pw = (struct passwd *) getpwuid (XINT (uid));
638 return (pw ? build_string (pw->pw_name) : Qnil);
35692fe0
JB
639}
640
641DEFUN ("user-real-login-name", Fuser_real_login_name, Suser_real_login_name,
642 0, 0, 0,
643 "Return the name of the user's real uid, as a string.\n\
9658bdd0 644This ignores the environment variables LOGNAME and USER, so it differs from\n\
b1da234a 645`user-login-name' when running under `su'.")
35692fe0
JB
646 ()
647{
f8a0e364
RS
648 /* Set up the user name info if we didn't do it before.
649 (That can happen if Emacs is dumpable
650 but you decide to run `temacs -l loadup' and not dump. */
35b34f72 651 if (INTEGERP (Vuser_login_name))
f8a0e364 652 init_editfns ();
35b34f72 653 return Vuser_real_login_name;
35692fe0
JB
654}
655
656DEFUN ("user-uid", Fuser_uid, Suser_uid, 0, 0, 0,
657 "Return the effective uid of Emacs, as an integer.")
658 ()
659{
660 return make_number (geteuid ());
661}
662
663DEFUN ("user-real-uid", Fuser_real_uid, Suser_real_uid, 0, 0, 0,
664 "Return the real uid of Emacs, as an integer.")
665 ()
666{
667 return make_number (getuid ());
668}
669
c9ed721d
RS
670DEFUN ("user-full-name", Fuser_full_name, Suser_full_name, 0, 1, 0,
671 "Return the full name of the user logged in, as a string.\n\
672If optional argument UID is an integer, return the full name of the user\n\
ca38bbb2 673with that uid, or \"unknown\" if there is no such user.\n\
3415b0e9
RS
674If UID is a string, return the full name of the user with that login\n\
675name, or \"unknown\" if no such user could be found.")
c9ed721d
RS
676 (uid)
677 Lisp_Object uid;
35692fe0 678{
c9ed721d 679 struct passwd *pw;
b0e92acd 680 register unsigned char *p, *q;
3415b0e9
RS
681 extern char *index ();
682 Lisp_Object full;
c9ed721d
RS
683
684 if (NILP (uid))
3415b0e9
RS
685 return Vuser_full_name;
686 else if (NUMBERP (uid))
687 pw = (struct passwd *) getpwuid (XINT (uid));
688 else if (STRINGP (uid))
689 pw = (struct passwd *) getpwnam (XSTRING (uid)->data);
690 else
691 error ("Invalid UID specification");
c9ed721d 692
3415b0e9 693 if (!pw)
3347526c 694 return Qnil;
3415b0e9
RS
695
696 p = (unsigned char *) USER_FULL_NAME;
697 /* Chop off everything after the first comma. */
698 q = (unsigned char *) index (p, ',');
699 full = make_string (p, q ? q - p : strlen (p));
700
701#ifdef AMPERSAND_FULL_NAME
702 p = XSTRING (full)->data;
703 q = (unsigned char *) index (p, '&');
704 /* Substitute the login name for the &, upcasing the first character. */
705 if (q)
706 {
b0e92acd 707 register unsigned char *r;
3415b0e9
RS
708 Lisp_Object login;
709
710 login = Fuser_login_name (make_number (pw->pw_uid));
711 r = (unsigned char *) alloca (strlen (p) + XSTRING (login)->size + 1);
712 bcopy (p, r, q - p);
713 r[q - p] = 0;
714 strcat (r, XSTRING (login)->data);
715 r[q - p] = UPCASE (r[q - p]);
716 strcat (r, q + 1);
717 full = build_string (r);
718 }
719#endif /* AMPERSAND_FULL_NAME */
720
721 return full;
35692fe0
JB
722}
723
724DEFUN ("system-name", Fsystem_name, Ssystem_name, 0, 0, 0,
725 "Return the name of the machine you are running on, as a string.")
726 ()
727{
728 return Vsystem_name;
729}
730
ac988277
KH
731/* For the benefit of callers who don't want to include lisp.h */
732char *
733get_system_name ()
734{
3d976a9a
RS
735 if (STRINGP (Vsystem_name))
736 return (char *) XSTRING (Vsystem_name)->data;
737 else
738 return "";
ac988277
KH
739}
740
7fd233b3
RS
741DEFUN ("emacs-pid", Femacs_pid, Semacs_pid, 0, 0, 0,
742 "Return the process ID of Emacs, as an integer.")
743 ()
744{
745 return make_number (getpid ());
746}
747
d940e0e4 748DEFUN ("current-time", Fcurrent_time, Scurrent_time, 0, 0, 0,
e983fdb2 749 "Return the current time, as the number of seconds since 1970-01-01 00:00:00.\n\
956ace37
JB
750The time is returned as a list of three integers. The first has the\n\
751most significant 16 bits of the seconds, while the second has the\n\
752least significant 16 bits. The third integer gives the microsecond\n\
753count.\n\
754\n\
755The microsecond count is zero on systems that do not provide\n\
756resolution finer than a second.")
d940e0e4
JB
757 ()
758{
956ace37
JB
759 EMACS_TIME t;
760 Lisp_Object result[3];
761
762 EMACS_GET_TIME (t);
d2fd0445
KH
763 XSETINT (result[0], (EMACS_SECS (t) >> 16) & 0xffff);
764 XSETINT (result[1], (EMACS_SECS (t) >> 0) & 0xffff);
765 XSETINT (result[2], EMACS_USECS (t));
956ace37
JB
766
767 return Flist (3, result);
d940e0e4
JB
768}
769\f
770
e3120ab5
JB
771static int
772lisp_time_argument (specified_time, result)
773 Lisp_Object specified_time;
774 time_t *result;
775{
776 if (NILP (specified_time))
777 return time (result) != -1;
778 else
779 {
780 Lisp_Object high, low;
781 high = Fcar (specified_time);
782 CHECK_NUMBER (high, 0);
783 low = Fcdr (specified_time);
ae683129 784 if (CONSP (low))
e3120ab5
JB
785 low = Fcar (low);
786 CHECK_NUMBER (low, 0);
787 *result = (XINT (high) << 16) + (XINT (low) & 0xffff);
788 return *result >> 16 == XINT (high);
789 }
790}
791
3efcc98a 792/*
b48382a0
RS
793DEFUN ("format-time-string", Fformat_time_string, Sformat_time_string, 1, 3, 0,
794 "Use FORMAT-STRING to format the time TIME, or now if omitted.\n\
795TIME is specified as (HIGH LOW . IGNORED) or (HIGH . LOW), as returned by\n\
796`current-time' or `file-attributes'.\n\
797The third, optional, argument UNIVERSAL, if non-nil, means describe TIME\n\
798as Universal Time; nil means describe TIME in the local time zone.\n\
799The value is a copy of FORMAT-STRING, but with certain constructs replaced\n\
800by text that describes the specified date and time in TIME:\n\
a82d387c 801\n\
b48382a0
RS
802%Y is the year, %y within the century, %C the century.\n\
803%G is the year corresponding to the ISO week, %g within the century.\n\
b771d0da
PE
804%m is the numeric month.\n\
805%b and %h are the locale's abbreviated month name, %B the full name.\n\
b48382a0
RS
806%d is the day of the month, zero-padded, %e is blank-padded.\n\
807%u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.\n\
b771d0da 808%a is the locale's abbreviated name of the day of week, %A the full name.\n\
b48382a0
RS
809%U is the week number starting on Sunday, %W starting on Monday,\n\
810 %V according to ISO 8601.\n\
811%j is the day of the year.\n\
812\n\
813%H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H\n\
814 only blank-padded, %l is like %I blank-padded.\n\
b771d0da 815%p is the locale's equivalent of either AM or PM.\n\
b48382a0
RS
816%M is the minute.\n\
817%S is the second.\n\
818%Z is the time zone name, %z is the numeric form.\n\
819%s is the number of seconds since 1970-01-01 00:00:00 +0000.\n\
820\n\
821%c is the locale's date and time format.\n\
822%x is the locale's \"preferred\" date format.\n\
823%D is like \"%m/%d/%y\".\n\
824\n\
825%R is like \"%H:%M\", %T is like \"%H:%M:%S\", %r is like \"%I:%M:%S %p\".\n\
826%X is the locale's \"preferred\" time format.\n\
827\n\
b771d0da 828Finally, %n is a newline, %t is a tab, %% is a literal %.\n\
b48382a0 829\n\
3efcc98a 830Certain flags and modifiers are available with some format controls.\n\
b48382a0
RS
831The flags are `_' and `-'. For certain characters X, %_X is like %X,\n\
832but padded with blanks; %-X is like %X, but without padding.\n\
833%NX (where N stands for an integer) is like %X,\n\
834but takes up at least N (a number) positions.\n\
835The modifiers are `E' and `O'. For certain characters X,\n\
836%EX is a locale's alternative version of %X;\n\
837%OX is like %X, but uses the locale's number symbols.\n\
838\n\
839For example, to produce full ISO 8601 format, use \"%Y-%m-%dT%T%z\".")
726ed0da 840 (format_string, time, universal)
3efcc98a
RS
841*/
842
843DEFUN ("format-time-string", Fformat_time_string, Sformat_time_string, 1, 3, 0,
844 0 /* See immediately above */)
b48382a0
RS
845 (format_string, time, universal)
846 Lisp_Object format_string, time, universal;
a82d387c
RS
847{
848 time_t value;
849 int size;
850
851 CHECK_STRING (format_string, 1);
852
853 if (! lisp_time_argument (time, &value))
854 error ("Invalid time specification");
855
856 /* This is probably enough. */
1f24f4fd 857 size = XSTRING (format_string)->size_byte * 6 + 50;
a82d387c
RS
858
859 while (1)
860 {
b48382a0
RS
861 char *buf = (char *) alloca (size + 1);
862 int result;
863
bfbcc5ee 864 buf[0] = '\1';
b48382a0
RS
865 result = emacs_strftime (buf, size, XSTRING (format_string)->data,
866 (NILP (universal) ? localtime (&value)
867 : gmtime (&value)));
bfbcc5ee 868 if ((result > 0 && result < size) || (result == 0 && buf[0] == '\0'))
a82d387c 869 return build_string (buf);
b48382a0
RS
870
871 /* If buffer was too small, make it bigger and try again. */
bfbcc5ee 872 result = emacs_strftime (NULL, 0x7fffffff, XSTRING (format_string)->data,
b48382a0
RS
873 (NILP (universal) ? localtime (&value)
874 : gmtime (&value)));
875 size = result + 1;
a82d387c
RS
876 }
877}
878
4691c06d
RS
879DEFUN ("decode-time", Fdecode_time, Sdecode_time, 0, 1, 0,
880 "Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST ZONE).\n\
881The optional SPECIFIED-TIME should be a list of (HIGH LOW . IGNORED)\n\
882or (HIGH . LOW), as from `current-time' and `file-attributes', or `nil'\n\
883to use the current time. The list has the following nine members:\n\
145b0681
RS
884SEC is an integer between 0 and 60; SEC is 60 for a leap second, which\n\
885only some operating systems support. MINUTE is an integer between 0 and 59.\n\
4691c06d
RS
886HOUR is an integer between 0 and 23. DAY is an integer between 1 and 31.\n\
887MONTH is an integer between 1 and 12. YEAR is an integer indicating the\n\
888four-digit year. DOW is the day of week, an integer between 0 and 6, where\n\
8890 is Sunday. DST is t if daylight savings time is effect, otherwise nil.\n\
890ZONE is an integer indicating the number of seconds east of Greenwich.\n\
2c6c7c72 891\(Note that Common Lisp has different meanings for DOW and ZONE.)")
4691c06d
RS
892 (specified_time)
893 Lisp_Object specified_time;
894{
895 time_t time_spec;
3c887943 896 struct tm save_tm;
4691c06d
RS
897 struct tm *decoded_time;
898 Lisp_Object list_args[9];
899
900 if (! lisp_time_argument (specified_time, &time_spec))
901 error ("Invalid time specification");
902
903 decoded_time = localtime (&time_spec);
3c887943
KH
904 XSETFASTINT (list_args[0], decoded_time->tm_sec);
905 XSETFASTINT (list_args[1], decoded_time->tm_min);
906 XSETFASTINT (list_args[2], decoded_time->tm_hour);
907 XSETFASTINT (list_args[3], decoded_time->tm_mday);
908 XSETFASTINT (list_args[4], decoded_time->tm_mon + 1);
236ebf35 909 XSETINT (list_args[5], decoded_time->tm_year + 1900);
3c887943 910 XSETFASTINT (list_args[6], decoded_time->tm_wday);
4691c06d 911 list_args[7] = (decoded_time->tm_isdst)? Qt : Qnil;
3c887943
KH
912
913 /* Make a copy, in case gmtime modifies the struct. */
914 save_tm = *decoded_time;
915 decoded_time = gmtime (&time_spec);
916 if (decoded_time == 0)
917 list_args[8] = Qnil;
918 else
94751666 919 XSETINT (list_args[8], tm_diff (&save_tm, decoded_time));
4691c06d
RS
920 return Flist (9, list_args);
921}
922
6ee9061c 923DEFUN ("encode-time", Fencode_time, Sencode_time, 6, MANY, 0,
2591ec64 924 "Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.\n\
6ee9061c
RS
925This is the reverse operation of `decode-time', which see.\n\
926ZONE defaults to the current time zone rule. This can\n\
085e9fcb 927be a string or t (as from `set-time-zone-rule'), or it can be a list\n\
7459d65b 928\(as from `current-time-zone') or an integer (as from `decode-time')\n\
c59b5089 929applied without consideration for daylight savings time.\n\
6ee9061c
RS
930\n\
931You can pass more than 7 arguments; then the first six arguments\n\
932are used as SECOND through YEAR, and the *last* argument is used as ZONE.\n\
933The intervening arguments are ignored.\n\
934This feature lets (apply 'encode-time (decode-time ...)) work.\n\
935\n\
c59b5089
PE
936Out-of-range values for SEC, MINUTE, HOUR, DAY, or MONTH are allowed;\n\
937for example, a DAY of 0 means the day preceding the given month.\n\
01ba8cce 938Year numbers less than 100 are treated just like other year numbers.\n\
c59b5089 939If you want them to stand for years in this century, you must do that yourself.")
6ee9061c
RS
940 (nargs, args)
941 int nargs;
942 register Lisp_Object *args;
cce7b8a0 943{
1b8fa736 944 time_t time;
c59b5089 945 struct tm tm;
60653898 946 Lisp_Object zone = (nargs > 6 ? args[nargs - 1] : Qnil);
6ee9061c
RS
947
948 CHECK_NUMBER (args[0], 0); /* second */
949 CHECK_NUMBER (args[1], 1); /* minute */
950 CHECK_NUMBER (args[2], 2); /* hour */
951 CHECK_NUMBER (args[3], 3); /* day */
952 CHECK_NUMBER (args[4], 4); /* month */
953 CHECK_NUMBER (args[5], 5); /* year */
954
955 tm.tm_sec = XINT (args[0]);
956 tm.tm_min = XINT (args[1]);
957 tm.tm_hour = XINT (args[2]);
958 tm.tm_mday = XINT (args[3]);
959 tm.tm_mon = XINT (args[4]) - 1;
960 tm.tm_year = XINT (args[5]) - 1900;
c59b5089
PE
961 tm.tm_isdst = -1;
962
963 if (CONSP (zone))
964 zone = Fcar (zone);
1b8fa736 965 if (NILP (zone))
c59b5089
PE
966 time = mktime (&tm);
967 else
1b8fa736 968 {
c59b5089
PE
969 char tzbuf[100];
970 char *tzstring;
971 char **oldenv = environ, **newenv;
972
2e34157c 973 if (EQ (zone, Qt))
085e9fcb
EN
974 tzstring = "UTC0";
975 else if (STRINGP (zone))
4d4c1514 976 tzstring = (char *) XSTRING (zone)->data;
c59b5089 977 else if (INTEGERP (zone))
1b8fa736 978 {
c59b5089
PE
979 int abszone = abs (XINT (zone));
980 sprintf (tzbuf, "XXX%s%d:%02d:%02d", "-" + (XINT (zone) < 0),
981 abszone / (60*60), (abszone/60) % 60, abszone % 60);
982 tzstring = tzbuf;
1b8fa736 983 }
c59b5089
PE
984 else
985 error ("Invalid time zone specification");
986
987 /* Set TZ before calling mktime; merely adjusting mktime's returned
988 value doesn't suffice, since that would mishandle leap seconds. */
989 set_time_zone_rule (tzstring);
990
991 time = mktime (&tm);
992
993 /* Restore TZ to previous value. */
994 newenv = environ;
995 environ = oldenv;
c0efcacf 996 xfree (newenv);
c59b5089
PE
997#ifdef LOCALTIME_CACHE
998 tzset ();
999#endif
1b8fa736 1000 }
1b8fa736 1001
c59b5089
PE
1002 if (time == (time_t) -1)
1003 error ("Specified time is not representable");
1004
1005 return make_time (time);
cce7b8a0
RS
1006}
1007
2148f2b4 1008DEFUN ("current-time-string", Fcurrent_time_string, Scurrent_time_string, 0, 1, 0,
35692fe0 1009 "Return the current time, as a human-readable string.\n\
2148f2b4
RS
1010Programs can use this function to decode a time,\n\
1011since the number of columns in each field is fixed.\n\
1012The format is `Sun Sep 16 01:03:52 1973'.\n\
7a8630da
RS
1013However, see also the functions `decode-time' and `format-time-string'\n\
1014which provide a much more powerful and general facility.\n\
1015\n\
2148f2b4
RS
1016If an argument is given, it specifies a time to format\n\
1017instead of the current time. The argument should have the form:\n\
1018 (HIGH . LOW)\n\
1019or the form:\n\
1020 (HIGH LOW . IGNORED).\n\
1021Thus, you can use times obtained from `current-time'\n\
1022and from `file-attributes'.")
1023 (specified_time)
1024 Lisp_Object specified_time;
1025{
e3120ab5 1026 time_t value;
35692fe0 1027 char buf[30];
2148f2b4
RS
1028 register char *tem;
1029
e3120ab5
JB
1030 if (! lisp_time_argument (specified_time, &value))
1031 value = -1;
2148f2b4 1032 tem = (char *) ctime (&value);
35692fe0
JB
1033
1034 strncpy (buf, tem, 24);
1035 buf[24] = 0;
1036
1037 return build_string (buf);
1038}
c2662aea 1039
94751666 1040#define TM_YEAR_BASE 1900
e3120ab5 1041
94751666
PE
1042/* Yield A - B, measured in seconds.
1043 This function is copied from the GNU C Library. */
1044static int
1045tm_diff (a, b)
e3120ab5
JB
1046 struct tm *a, *b;
1047{
94751666
PE
1048 /* Compute intervening leap days correctly even if year is negative.
1049 Take care to avoid int overflow in leap day calculations,
1050 but it's OK to assume that A and B are close to each other. */
1051 int a4 = (a->tm_year >> 2) + (TM_YEAR_BASE >> 2) - ! (a->tm_year & 3);
1052 int b4 = (b->tm_year >> 2) + (TM_YEAR_BASE >> 2) - ! (b->tm_year & 3);
1053 int a100 = a4 / 25 - (a4 % 25 < 0);
1054 int b100 = b4 / 25 - (b4 % 25 < 0);
1055 int a400 = a100 >> 2;
1056 int b400 = b100 >> 2;
1057 int intervening_leap_days = (a4 - b4) - (a100 - b100) + (a400 - b400);
1058 int years = a->tm_year - b->tm_year;
1059 int days = (365 * years + intervening_leap_days
1060 + (a->tm_yday - b->tm_yday));
1061 return (60 * (60 * (24 * days + (a->tm_hour - b->tm_hour))
1062 + (a->tm_min - b->tm_min))
8e718b4e 1063 + (a->tm_sec - b->tm_sec));
e3120ab5
JB
1064}
1065
1066DEFUN ("current-time-zone", Fcurrent_time_zone, Scurrent_time_zone, 0, 1, 0,
1067 "Return the offset and name for the local time zone.\n\
1068This returns a list of the form (OFFSET NAME).\n\
1069OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).\n\
1070 A negative value means west of Greenwich.\n\
1071NAME is a string giving the name of the time zone.\n\
1072If an argument is given, it specifies when the time zone offset is determined\n\
1073instead of using the current time. The argument should have the form:\n\
1074 (HIGH . LOW)\n\
1075or the form:\n\
1076 (HIGH LOW . IGNORED).\n\
1077Thus, you can use times obtained from `current-time'\n\
1078and from `file-attributes'.\n\
773c1fd3
JB
1079\n\
1080Some operating systems cannot provide all this information to Emacs;\n\
2d88f747 1081in this case, `current-time-zone' returns a list containing nil for\n\
773c1fd3 1082the data it can't find.")
e3120ab5
JB
1083 (specified_time)
1084 Lisp_Object specified_time;
c2662aea 1085{
e3120ab5
JB
1086 time_t value;
1087 struct tm *t;
c2662aea 1088
e3120ab5 1089 if (lisp_time_argument (specified_time, &value)
2d88f747 1090 && (t = gmtime (&value)) != 0)
e3120ab5 1091 {
2d88f747 1092 struct tm gmt;
94751666 1093 int offset;
e3120ab5 1094 char *s, buf[6];
2d88f747
RS
1095
1096 gmt = *t; /* Make a copy, in case localtime modifies *t. */
1097 t = localtime (&value);
94751666 1098 offset = tm_diff (t, &gmt);
e3120ab5
JB
1099 s = 0;
1100#ifdef HAVE_TM_ZONE
1101 if (t->tm_zone)
5fd4de15 1102 s = (char *)t->tm_zone;
a7971c39
RS
1103#else /* not HAVE_TM_ZONE */
1104#ifdef HAVE_TZNAME
1105 if (t->tm_isdst == 0 || t->tm_isdst == 1)
1106 s = tzname[t->tm_isdst];
c2662aea 1107#endif
a7971c39 1108#endif /* not HAVE_TM_ZONE */
e3120ab5
JB
1109 if (!s)
1110 {
1111 /* No local time zone name is available; use "+-NNNN" instead. */
00fc94d0 1112 int am = (offset < 0 ? -offset : offset) / 60;
e3120ab5
JB
1113 sprintf (buf, "%c%02d%02d", (offset < 0 ? '-' : '+'), am/60, am%60);
1114 s = buf;
1115 }
1116 return Fcons (make_number (offset), Fcons (build_string (s), Qnil));
1117 }
1118 else
09dbcf71 1119 return Fmake_list (make_number (2), Qnil);
c2662aea
JB
1120}
1121
260e2e2a
KH
1122/* This holds the value of `environ' produced by the previous
1123 call to Fset_time_zone_rule, or 0 if Fset_time_zone_rule
1124 has never been called. */
1125static char **environbuf;
1126
143cb9a9
RS
1127DEFUN ("set-time-zone-rule", Fset_time_zone_rule, Sset_time_zone_rule, 1, 1, 0,
1128 "Set the local time zone using TZ, a string specifying a time zone rule.\n\
085e9fcb
EN
1129If TZ is nil, use implementation-defined default time zone information.\n\
1130If TZ is t, use Universal Time.")
143cb9a9
RS
1131 (tz)
1132 Lisp_Object tz;
1133{
143cb9a9
RS
1134 char *tzstring;
1135
1136 if (NILP (tz))
1137 tzstring = 0;
2e34157c 1138 else if (EQ (tz, Qt))
085e9fcb 1139 tzstring = "UTC0";
143cb9a9
RS
1140 else
1141 {
1142 CHECK_STRING (tz, 0);
4d4c1514 1143 tzstring = (char *) XSTRING (tz)->data;
143cb9a9
RS
1144 }
1145
c59b5089
PE
1146 set_time_zone_rule (tzstring);
1147 if (environbuf)
1148 free (environbuf);
1149 environbuf = environ;
1150
1151 return Qnil;
1152}
1153
e0bf9faf
PE
1154#ifdef LOCALTIME_CACHE
1155
1156/* These two values are known to load tz files in buggy implementations,
1157 i.e. Solaris 1 executables running under either Solaris 1 or Solaris 2.
1155c453
RS
1158 Their values shouldn't matter in non-buggy implementations.
1159 We don't use string literals for these strings,
1160 since if a string in the environment is in readonly
1161 storage, it runs afoul of bugs in SVR4 and Solaris 2.3.
1162 See Sun bugs 1113095 and 1114114, ``Timezone routines
1163 improperly modify environment''. */
1164
e0bf9faf
PE
1165static char set_time_zone_rule_tz1[] = "TZ=GMT+0";
1166static char set_time_zone_rule_tz2[] = "TZ=GMT+1";
1167
1168#endif
1155c453 1169
c59b5089
PE
1170/* Set the local time zone rule to TZSTRING.
1171 This allocates memory into `environ', which it is the caller's
1172 responsibility to free. */
a92ae0ce 1173void
c59b5089
PE
1174set_time_zone_rule (tzstring)
1175 char *tzstring;
1176{
1177 int envptrs;
1178 char **from, **to, **newenv;
1179
aafe5147 1180 /* Make the ENVIRON vector longer with room for TZSTRING. */
143cb9a9
RS
1181 for (from = environ; *from; from++)
1182 continue;
1183 envptrs = from - environ + 2;
1184 newenv = to = (char **) xmalloc (envptrs * sizeof (char *)
1185 + (tzstring ? strlen (tzstring) + 4 : 0));
aafe5147
RS
1186
1187 /* Add TZSTRING to the end of environ, as a value for TZ. */
143cb9a9
RS
1188 if (tzstring)
1189 {
1190 char *t = (char *) (to + envptrs);
1191 strcpy (t, "TZ=");
1192 strcat (t, tzstring);
1193 *to++ = t;
1194 }
1195
aafe5147
RS
1196 /* Copy the old environ vector elements into NEWENV,
1197 but don't copy the TZ variable.
1198 So we have only one definition of TZ, which came from TZSTRING. */
143cb9a9
RS
1199 for (from = environ; *from; from++)
1200 if (strncmp (*from, "TZ=", 3) != 0)
1201 *to++ = *from;
1202 *to = 0;
1203
1204 environ = newenv;
143cb9a9 1205
aafe5147
RS
1206 /* If we do have a TZSTRING, NEWENV points to the vector slot where
1207 the TZ variable is stored. If we do not have a TZSTRING,
1208 TO points to the vector slot which has the terminating null. */
1209
143cb9a9 1210#ifdef LOCALTIME_CACHE
aafe5147
RS
1211 {
1212 /* In SunOS 4.1.3_U1 and 4.1.4, if TZ has a value like
1213 "US/Pacific" that loads a tz file, then changes to a value like
1214 "XXX0" that does not load a tz file, and then changes back to
1215 its original value, the last change is (incorrectly) ignored.
1216 Also, if TZ changes twice in succession to values that do
1217 not load a tz file, tzset can dump core (see Sun bug#1225179).
1218 The following code works around these bugs. */
1219
aafe5147
RS
1220 if (tzstring)
1221 {
1222 /* Temporarily set TZ to a value that loads a tz file
1223 and that differs from tzstring. */
1224 char *tz = *newenv;
1155c453
RS
1225 *newenv = (strcmp (tzstring, set_time_zone_rule_tz1 + 3) == 0
1226 ? set_time_zone_rule_tz2 : set_time_zone_rule_tz1);
aafe5147
RS
1227 tzset ();
1228 *newenv = tz;
1229 }
1230 else
1231 {
1232 /* The implied tzstring is unknown, so temporarily set TZ to
1233 two different values that each load a tz file. */
1155c453 1234 *to = set_time_zone_rule_tz1;
aafe5147
RS
1235 to[1] = 0;
1236 tzset ();
1155c453 1237 *to = set_time_zone_rule_tz2;
aafe5147
RS
1238 tzset ();
1239 *to = 0;
1240 }
1241
1242 /* Now TZ has the desired value, and tzset can be invoked safely. */
1243 }
1244
143cb9a9
RS
1245 tzset ();
1246#endif
143cb9a9 1247}
35692fe0 1248\f
fb8106e8
KH
1249/* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC
1250 (if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a
1251 type of object is Lisp_String). INHERIT is passed to
1252 INSERT_FROM_STRING_FUNC as the last argument. */
1253
d11ba98c 1254void
fb8106e8
KH
1255general_insert_function (insert_func, insert_from_string_func,
1256 inherit, nargs, args)
d11ba98c 1257 void (*insert_func) P_ ((unsigned char *, int));
1f24f4fd 1258 void (*insert_from_string_func) P_ ((Lisp_Object, int, int, int, int, int));
fb8106e8
KH
1259 int inherit, nargs;
1260 register Lisp_Object *args;
1261{
1262 register int argnum;
1263 register Lisp_Object val;
1264
1265 for (argnum = 0; argnum < nargs; argnum++)
1266 {
1267 val = args[argnum];
1268 retry:
1269 if (INTEGERP (val))
1270 {
d11ba98c 1271 unsigned char workbuf[4], *str;
fb8106e8
KH
1272 int len;
1273
1274 if (!NILP (current_buffer->enable_multibyte_characters))
1275 len = CHAR_STRING (XFASTINT (val), workbuf, str);
1276 else
1277 workbuf[0] = XINT (val), str = workbuf, len = 1;
1278 (*insert_func) (str, len);
1279 }
1280 else if (STRINGP (val))
1281 {
1f24f4fd
RS
1282 (*insert_from_string_func) (val, 0, 0,
1283 XSTRING (val)->size,
1284 XSTRING (val)->size_byte,
1285 inherit);
fb8106e8
KH
1286 }
1287 else
1288 {
1289 val = wrong_type_argument (Qchar_or_string_p, val);
1290 goto retry;
1291 }
1292 }
1293}
1294
35692fe0
JB
1295void
1296insert1 (arg)
1297 Lisp_Object arg;
1298{
1299 Finsert (1, &arg);
1300}
1301
52b14ac0
JB
1302
1303/* Callers passing one argument to Finsert need not gcpro the
1304 argument "array", since the only element of the array will
1305 not be used after calling insert or insert_from_string, so
1306 we don't care if it gets trashed. */
1307
35692fe0
JB
1308DEFUN ("insert", Finsert, Sinsert, 0, MANY, 0,
1309 "Insert the arguments, either strings or characters, at point.\n\
fb8106e8
KH
1310Point and before-insertion-markers move forward so that it ends up\n\
1311 after the inserted text.\n\
35692fe0
JB
1312Any other markers at the point of insertion remain before the text.")
1313 (nargs, args)
1314 int nargs;
1315 register Lisp_Object *args;
1316{
fb8106e8 1317 general_insert_function (insert, insert_from_string, 0, nargs, args);
be91036a
RS
1318 return Qnil;
1319}
1320
1321DEFUN ("insert-and-inherit", Finsert_and_inherit, Sinsert_and_inherit,
1322 0, MANY, 0,
1323 "Insert the arguments at point, inheriting properties from adjoining text.\n\
fb8106e8
KH
1324Point and before-insertion-markers move forward so that it ends up\n\
1325 after the inserted text.\n\
be91036a
RS
1326Any other markers at the point of insertion remain before the text.")
1327 (nargs, args)
1328 int nargs;
1329 register Lisp_Object *args;
1330{
fb8106e8
KH
1331 general_insert_function (insert_and_inherit, insert_from_string, 1,
1332 nargs, args);
35692fe0
JB
1333 return Qnil;
1334}
1335
1336DEFUN ("insert-before-markers", Finsert_before_markers, Sinsert_before_markers, 0, MANY, 0,
1337 "Insert strings or characters at point, relocating markers after the text.\n\
fb8106e8
KH
1338Point and before-insertion-markers move forward so that it ends up\n\
1339 after the inserted text.\n\
35692fe0
JB
1340Any other markers at the point of insertion also end up after the text.")
1341 (nargs, args)
1342 int nargs;
1343 register Lisp_Object *args;
1344{
fb8106e8
KH
1345 general_insert_function (insert_before_markers,
1346 insert_from_string_before_markers, 0,
1347 nargs, args);
be91036a
RS
1348 return Qnil;
1349}
1350
a0d76c27
EN
1351DEFUN ("insert-before-markers-and-inherit", Finsert_and_inherit_before_markers,
1352 Sinsert_and_inherit_before_markers, 0, MANY, 0,
be91036a
RS
1353 "Insert text at point, relocating markers and inheriting properties.\n\
1354Point moves forward so that it ends up after the inserted text.\n\
1355Any other markers at the point of insertion also end up after the text.")
1356 (nargs, args)
1357 int nargs;
1358 register Lisp_Object *args;
1359{
fb8106e8
KH
1360 general_insert_function (insert_before_markers_and_inherit,
1361 insert_from_string_before_markers, 1,
1362 nargs, args);
35692fe0
JB
1363 return Qnil;
1364}
1365\f
e2eeabbb 1366DEFUN ("insert-char", Finsert_char, Sinsert_char, 2, 3, 0,
2591ec64 1367 "Insert COUNT (second arg) copies of CHARACTER (first arg).\n\
fb8106e8 1368Point and before-insertion-markers are affected as in the function `insert'.\n\
e2eeabbb
RS
1369Both arguments are required.\n\
1370The optional third arg INHERIT, if non-nil, says to inherit text properties\n\
1371from adjoining text, if those properties are sticky.")
2591ec64
EN
1372 (character, count, inherit)
1373 Lisp_Object character, count, inherit;
35692fe0
JB
1374{
1375 register unsigned char *string;
1376 register int strlen;
1377 register int i, n;
fb8106e8
KH
1378 int len;
1379 unsigned char workbuf[4], *str;
35692fe0 1380
2591ec64 1381 CHECK_NUMBER (character, 0);
35692fe0
JB
1382 CHECK_NUMBER (count, 1);
1383
fb8106e8
KH
1384 if (!NILP (current_buffer->enable_multibyte_characters))
1385 len = CHAR_STRING (XFASTINT (character), workbuf, str);
1386 else
1387 workbuf[0] = XFASTINT (character), str = workbuf, len = 1;
1388 n = XINT (count) * len;
35692fe0
JB
1389 if (n <= 0)
1390 return Qnil;
fb8106e8 1391 strlen = min (n, 256 * len);
35692fe0
JB
1392 string = (unsigned char *) alloca (strlen);
1393 for (i = 0; i < strlen; i++)
fb8106e8 1394 string[i] = str[i % len];
35692fe0
JB
1395 while (n >= strlen)
1396 {
54e42e2d 1397 QUIT;
e2eeabbb
RS
1398 if (!NILP (inherit))
1399 insert_and_inherit (string, strlen);
1400 else
1401 insert (string, strlen);
35692fe0
JB
1402 n -= strlen;
1403 }
1404 if (n > 0)
83951f1e
KH
1405 {
1406 if (!NILP (inherit))
1407 insert_and_inherit (string, n);
1408 else
1409 insert (string, n);
1410 }
35692fe0
JB
1411 return Qnil;
1412}
1413
1414\f
ffd56f97
JB
1415/* Making strings from buffer contents. */
1416
1417/* Return a Lisp_String containing the text of the current buffer from
74d6d8c5 1418 START to END. If text properties are in use and the current buffer
eb8c3be9 1419 has properties in the range specified, the resulting string will also
260e2e2a 1420 have them, if PROPS is nonzero.
ffd56f97
JB
1421
1422 We don't want to use plain old make_string here, because it calls
1423 make_uninit_string, which can cause the buffer arena to be
1424 compacted. make_string has no way of knowing that the data has
1425 been moved, and thus copies the wrong data into the string. This
1426 doesn't effect most of the other users of make_string, so it should
1427 be left as is. But we should use this function when conjuring
1428 buffer substrings. */
74d6d8c5 1429
ffd56f97 1430Lisp_Object
260e2e2a 1431make_buffer_string (start, end, props)
ffd56f97 1432 int start, end;
260e2e2a 1433 int props;
ffd56f97 1434{
36b0d50e 1435 Lisp_Object result, tem, tem1;
ec1c14f6
RS
1436 int start_byte = CHAR_TO_BYTE (start);
1437 int end_byte = CHAR_TO_BYTE (end);
ffd56f97
JB
1438
1439 if (start < GPT && GPT < end)
1440 move_gap (start);
1441
1f24f4fd 1442 result = make_uninit_multibyte_string (end - start, end_byte - start_byte);
ec1c14f6
RS
1443 bcopy (BYTE_POS_ADDR (start_byte), XSTRING (result)->data,
1444 end_byte - start_byte);
ffd56f97 1445
260e2e2a 1446 /* If desired, update and copy the text properties. */
60b96ee7 1447#ifdef USE_TEXT_PROPERTIES
260e2e2a
KH
1448 if (props)
1449 {
1450 update_buffer_properties (start, end);
1451
1452 tem = Fnext_property_change (make_number (start), Qnil, make_number (end));
1453 tem1 = Ftext_properties_at (make_number (start), Qnil);
1454
1455 if (XINT (tem) != end || !NILP (tem1))
ec1c14f6
RS
1456 copy_intervals_to_string (result, current_buffer, start,
1457 end - start);
260e2e2a 1458 }
60b96ee7 1459#endif
74d6d8c5 1460
ffd56f97
JB
1461 return result;
1462}
35692fe0 1463
260e2e2a
KH
1464/* Call Vbuffer_access_fontify_functions for the range START ... END
1465 in the current buffer, if necessary. */
1466
1467static void
1468update_buffer_properties (start, end)
1469 int start, end;
1470{
1471#ifdef USE_TEXT_PROPERTIES
1472 /* If this buffer has some access functions,
1473 call them, specifying the range of the buffer being accessed. */
1474 if (!NILP (Vbuffer_access_fontify_functions))
1475 {
1476 Lisp_Object args[3];
1477 Lisp_Object tem;
1478
1479 args[0] = Qbuffer_access_fontify_functions;
1480 XSETINT (args[1], start);
1481 XSETINT (args[2], end);
1482
1483 /* But don't call them if we can tell that the work
1484 has already been done. */
1485 if (!NILP (Vbuffer_access_fontified_property))
1486 {
1487 tem = Ftext_property_any (args[1], args[2],
1488 Vbuffer_access_fontified_property,
1489 Qnil, Qnil);
1490 if (! NILP (tem))
ced1d19a 1491 Frun_hook_with_args (3, args);
260e2e2a
KH
1492 }
1493 else
ced1d19a 1494 Frun_hook_with_args (3, args);
260e2e2a
KH
1495 }
1496#endif
1497}
1498
35692fe0
JB
1499DEFUN ("buffer-substring", Fbuffer_substring, Sbuffer_substring, 2, 2, 0,
1500 "Return the contents of part of the current buffer as a string.\n\
1501The two arguments START and END are character positions;\n\
1502they can be in either order.")
2591ec64
EN
1503 (start, end)
1504 Lisp_Object start, end;
35692fe0 1505{
2591ec64 1506 register int b, e;
35692fe0 1507
2591ec64
EN
1508 validate_region (&start, &end);
1509 b = XINT (start);
1510 e = XINT (end);
35692fe0 1511
2591ec64 1512 return make_buffer_string (b, e, 1);
260e2e2a
KH
1513}
1514
1515DEFUN ("buffer-substring-no-properties", Fbuffer_substring_no_properties,
1516 Sbuffer_substring_no_properties, 2, 2, 0,
1517 "Return the characters of part of the buffer, without the text properties.\n\
1518The two arguments START and END are character positions;\n\
1519they can be in either order.")
2591ec64
EN
1520 (start, end)
1521 Lisp_Object start, end;
260e2e2a 1522{
2591ec64 1523 register int b, e;
260e2e2a 1524
2591ec64
EN
1525 validate_region (&start, &end);
1526 b = XINT (start);
1527 e = XINT (end);
260e2e2a 1528
2591ec64 1529 return make_buffer_string (b, e, 0);
35692fe0
JB
1530}
1531
1532DEFUN ("buffer-string", Fbuffer_string, Sbuffer_string, 0, 0, 0,
af7bd86c
KH
1533 "Return the contents of the current buffer as a string.\n\
1534If narrowing is in effect, this function returns only the visible part\n\
1535of the buffer.")
35692fe0
JB
1536 ()
1537{
260e2e2a 1538 return make_buffer_string (BEGV, ZV, 1);
35692fe0
JB
1539}
1540
1541DEFUN ("insert-buffer-substring", Finsert_buffer_substring, Sinsert_buffer_substring,
1542 1, 3, 0,
83ea6fc2 1543 "Insert before point a substring of the contents of buffer BUFFER.\n\
35692fe0
JB
1544BUFFER may be a buffer or a buffer name.\n\
1545Arguments START and END are character numbers specifying the substring.\n\
1546They default to the beginning and the end of BUFFER.")
2591ec64
EN
1547 (buf, start, end)
1548 Lisp_Object buf, start, end;
35692fe0 1549{
2591ec64 1550 register int b, e, temp;
260e2e2a 1551 register struct buffer *bp, *obuf;
3fff2dfa 1552 Lisp_Object buffer;
35692fe0 1553
3fff2dfa
RS
1554 buffer = Fget_buffer (buf);
1555 if (NILP (buffer))
1556 nsberror (buf);
1557 bp = XBUFFER (buffer);
93b62e82
KH
1558 if (NILP (bp->name))
1559 error ("Selecting deleted buffer");
35692fe0 1560
2591ec64
EN
1561 if (NILP (start))
1562 b = BUF_BEGV (bp);
35692fe0
JB
1563 else
1564 {
2591ec64
EN
1565 CHECK_NUMBER_COERCE_MARKER (start, 0);
1566 b = XINT (start);
35692fe0 1567 }
2591ec64
EN
1568 if (NILP (end))
1569 e = BUF_ZV (bp);
35692fe0
JB
1570 else
1571 {
2591ec64
EN
1572 CHECK_NUMBER_COERCE_MARKER (end, 1);
1573 e = XINT (end);
35692fe0
JB
1574 }
1575
2591ec64
EN
1576 if (b > e)
1577 temp = b, b = e, e = temp;
35692fe0 1578
2591ec64
EN
1579 if (!(BUF_BEGV (bp) <= b && e <= BUF_ZV (bp)))
1580 args_out_of_range (start, end);
35692fe0 1581
260e2e2a
KH
1582 obuf = current_buffer;
1583 set_buffer_internal_1 (bp);
2591ec64 1584 update_buffer_properties (b, e);
260e2e2a
KH
1585 set_buffer_internal_1 (obuf);
1586
2591ec64 1587 insert_from_buffer (bp, b, e - b, 0);
35692fe0
JB
1588 return Qnil;
1589}
e9cf2084
RS
1590
1591DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings, Scompare_buffer_substrings,
1592 6, 6, 0,
1593 "Compare two substrings of two buffers; return result as number.\n\
1594the value is -N if first string is less after N-1 chars,\n\
1595+N if first string is greater after N-1 chars, or 0 if strings match.\n\
1596Each substring is represented as three arguments: BUFFER, START and END.\n\
1597That makes six args in all, three for each substring.\n\n\
1598The value of `case-fold-search' in the current buffer\n\
1599determines whether case is significant or ignored.")
1600 (buffer1, start1, end1, buffer2, start2, end2)
1601 Lisp_Object buffer1, start1, end1, buffer2, start2, end2;
1602{
1603 register int begp1, endp1, begp2, endp2, temp, len1, len2, length, i;
1604 register struct buffer *bp1, *bp2;
2a8b0ff0 1605 register Lisp_Object *trt
e9cf2084 1606 = (!NILP (current_buffer->case_fold_search)
2a8b0ff0 1607 ? XCHAR_TABLE (current_buffer->case_canon_table)->contents : 0);
ec1c14f6
RS
1608 int chars = 0;
1609 int beg1_byte, beg2_byte;
e9cf2084
RS
1610
1611 /* Find the first buffer and its substring. */
1612
1613 if (NILP (buffer1))
1614 bp1 = current_buffer;
1615 else
1616 {
3fff2dfa
RS
1617 Lisp_Object buf1;
1618 buf1 = Fget_buffer (buffer1);
1619 if (NILP (buf1))
1620 nsberror (buffer1);
1621 bp1 = XBUFFER (buf1);
93b62e82
KH
1622 if (NILP (bp1->name))
1623 error ("Selecting deleted buffer");
e9cf2084
RS
1624 }
1625
1626 if (NILP (start1))
1627 begp1 = BUF_BEGV (bp1);
1628 else
1629 {
1630 CHECK_NUMBER_COERCE_MARKER (start1, 1);
1631 begp1 = XINT (start1);
1632 }
1633 if (NILP (end1))
1634 endp1 = BUF_ZV (bp1);
1635 else
1636 {
1637 CHECK_NUMBER_COERCE_MARKER (end1, 2);
1638 endp1 = XINT (end1);
1639 }
1640
1641 if (begp1 > endp1)
1642 temp = begp1, begp1 = endp1, endp1 = temp;
1643
1644 if (!(BUF_BEGV (bp1) <= begp1
1645 && begp1 <= endp1
1646 && endp1 <= BUF_ZV (bp1)))
1647 args_out_of_range (start1, end1);
1648
1649 /* Likewise for second substring. */
1650
1651 if (NILP (buffer2))
1652 bp2 = current_buffer;
1653 else
1654 {
3fff2dfa
RS
1655 Lisp_Object buf2;
1656 buf2 = Fget_buffer (buffer2);
1657 if (NILP (buf2))
1658 nsberror (buffer2);
3b1fdd85 1659 bp2 = XBUFFER (buf2);
93b62e82
KH
1660 if (NILP (bp2->name))
1661 error ("Selecting deleted buffer");
e9cf2084
RS
1662 }
1663
1664 if (NILP (start2))
1665 begp2 = BUF_BEGV (bp2);
1666 else
1667 {
1668 CHECK_NUMBER_COERCE_MARKER (start2, 4);
1669 begp2 = XINT (start2);
1670 }
1671 if (NILP (end2))
1672 endp2 = BUF_ZV (bp2);
1673 else
1674 {
1675 CHECK_NUMBER_COERCE_MARKER (end2, 5);
1676 endp2 = XINT (end2);
1677 }
1678
1679 if (begp2 > endp2)
1680 temp = begp2, begp2 = endp2, endp2 = temp;
1681
1682 if (!(BUF_BEGV (bp2) <= begp2
1683 && begp2 <= endp2
1684 && endp2 <= BUF_ZV (bp2)))
1685 args_out_of_range (start2, end2);
1686
ec1c14f6
RS
1687 beg1_byte = buf_charpos_to_bytepos (bp1, begp1);
1688 beg2_byte = buf_charpos_to_bytepos (bp2, begp2);
1689 len1 = buf_charpos_to_bytepos (bp1, endp1) - begp1;
1690 len2 = buf_charpos_to_bytepos (bp2, endp2) - begp2;
e9cf2084
RS
1691 length = len1;
1692 if (len2 < length)
1693 length = len2;
1694
1695 for (i = 0; i < length; i++)
1696 {
ec1c14f6
RS
1697 unsigned char *p1 = BUF_BYTE_ADDRESS (bp1, beg1_byte + i);
1698 int c1 = *p1;
1699 int c2 = *BUF_BYTE_ADDRESS (bp2, beg2_byte + i);
1700
1701 /* If a character begins here,
1702 count the previous character now. */
1703 if (i > 0
1704 && (NILP (current_buffer->enable_multibyte_characters)
1705 || CHAR_HEAD_P (*p1)))
1706 chars++;
1707
e9cf2084
RS
1708 if (trt)
1709 {
1b10fb77
RS
1710 c1 = XINT (trt[c1]);
1711 c2 = XINT (trt[c2]);
e9cf2084
RS
1712 }
1713 if (c1 < c2)
ec1c14f6 1714 return make_number (- 1 - chars);
e9cf2084 1715 if (c1 > c2)
ec1c14f6 1716 return make_number (chars + 1);
e9cf2084
RS
1717 }
1718
1719 /* The strings match as far as they go.
1720 If one is shorter, that one is less. */
1721 if (length < len1)
ec1c14f6 1722 return make_number (chars + 1);
e9cf2084 1723 else if (length < len2)
ec1c14f6 1724 return make_number (- chars - 1);
e9cf2084
RS
1725
1726 /* Same length too => they are equal. */
1727 return make_number (0);
1728}
35692fe0 1729\f
d5a539cd
RS
1730static Lisp_Object
1731subst_char_in_region_unwind (arg)
1732 Lisp_Object arg;
1733{
1734 return current_buffer->undo_list = arg;
1735}
1736
c8e76b47
RS
1737static Lisp_Object
1738subst_char_in_region_unwind_1 (arg)
1739 Lisp_Object arg;
1740{
1741 return current_buffer->filename = arg;
1742}
1743
35692fe0
JB
1744DEFUN ("subst-char-in-region", Fsubst_char_in_region,
1745 Ssubst_char_in_region, 4, 5, 0,
1746 "From START to END, replace FROMCHAR with TOCHAR each time it occurs.\n\
1747If optional arg NOUNDO is non-nil, don't record this change for undo\n\
fb8106e8
KH
1748and don't mark the buffer as really changed.\n\
1749Both characters must have the same length of multi-byte form.")
35692fe0
JB
1750 (start, end, fromchar, tochar, noundo)
1751 Lisp_Object start, end, fromchar, tochar, noundo;
1752{
84246b95 1753 register int pos, pos_byte, stop, i, len, end_byte;
60b96ee7 1754 int changed = 0;
fb8106e8 1755 unsigned char fromwork[4], *fromstr, towork[4], *tostr, *p;
d5a539cd 1756 int count = specpdl_ptr - specpdl;
35692fe0
JB
1757
1758 validate_region (&start, &end);
1759 CHECK_NUMBER (fromchar, 2);
1760 CHECK_NUMBER (tochar, 3);
1761
fb8106e8
KH
1762 if (! NILP (current_buffer->enable_multibyte_characters))
1763 {
1764 len = CHAR_STRING (XFASTINT (fromchar), fromwork, fromstr);
1765 if (CHAR_STRING (XFASTINT (tochar), towork, tostr) != len)
1766 error ("Characters in subst-char-in-region have different byte-lengths");
1767 }
1768 else
1769 {
1770 len = 1;
1771 fromwork[0] = XFASTINT (fromchar), fromstr = fromwork;
1772 towork[0] = XFASTINT (tochar), tostr = towork;
1773 }
1774
84246b95
KH
1775 pos = XINT (start);
1776 pos_byte = CHAR_TO_BYTE (pos);
ec1c14f6
RS
1777 stop = CHAR_TO_BYTE (XINT (end));
1778 end_byte = stop;
35692fe0 1779
d5a539cd
RS
1780 /* If we don't want undo, turn off putting stuff on the list.
1781 That's faster than getting rid of things,
c8e76b47
RS
1782 and it prevents even the entry for a first change.
1783 Also inhibit locking the file. */
d5a539cd
RS
1784 if (!NILP (noundo))
1785 {
1786 record_unwind_protect (subst_char_in_region_unwind,
1787 current_buffer->undo_list);
1788 current_buffer->undo_list = Qt;
c8e76b47
RS
1789 /* Don't do file-locking. */
1790 record_unwind_protect (subst_char_in_region_unwind_1,
1791 current_buffer->filename);
1792 current_buffer->filename = Qnil;
d5a539cd
RS
1793 }
1794
84246b95 1795 if (pos_byte < GPT_BYTE)
ec1c14f6 1796 stop = min (stop, GPT_BYTE);
fb8106e8 1797 while (1)
35692fe0 1798 {
84246b95 1799 if (pos_byte >= stop)
fb8106e8 1800 {
84246b95 1801 if (pos_byte >= end_byte) break;
ec1c14f6 1802 stop = end_byte;
fb8106e8 1803 }
84246b95 1804 p = BYTE_POS_ADDR (pos_byte);
fb8106e8
KH
1805 if (p[0] == fromstr[0]
1806 && (len == 1
1807 || (p[1] == fromstr[1]
1808 && (len == 2 || (p[2] == fromstr[2]
1809 && (len == 3 || p[3] == fromstr[3]))))))
35692fe0 1810 {
60b96ee7
RS
1811 if (! changed)
1812 {
fb8106e8 1813 modify_region (current_buffer, XINT (start), XINT (end));
7653d030
RS
1814
1815 if (! NILP (noundo))
1816 {
1e158d25
RS
1817 if (MODIFF - 1 == SAVE_MODIFF)
1818 SAVE_MODIFF++;
7653d030
RS
1819 if (MODIFF - 1 == current_buffer->auto_save_modified)
1820 current_buffer->auto_save_modified++;
1821 }
1822
fb8106e8 1823 changed = 1;
60b96ee7
RS
1824 }
1825
56a98455 1826 if (NILP (noundo))
84246b95 1827 record_change (pos, 1);
fb8106e8 1828 for (i = 0; i < len; i++) *p++ = tostr[i];
35692fe0 1829 }
84246b95 1830 INC_BOTH (pos, pos_byte);
35692fe0
JB
1831 }
1832
60b96ee7
RS
1833 if (changed)
1834 signal_after_change (XINT (start),
84246b95 1835 XINT (end) - XINT (start), XINT (end) - XINT (start));
60b96ee7 1836
d5a539cd 1837 unbind_to (count, Qnil);
35692fe0
JB
1838 return Qnil;
1839}
1840
1841DEFUN ("translate-region", Ftranslate_region, Stranslate_region, 3, 3, 0,
1842 "From START to END, translate characters according to TABLE.\n\
1843TABLE is a string; the Nth character in it is the mapping\n\
1f24f4fd
RS
1844for the character with code N.\n\
1845This function does not alter multibyte characters.\n\
1846It returns the number of characters changed.")
35692fe0
JB
1847 (start, end, table)
1848 Lisp_Object start;
1849 Lisp_Object end;
1850 register Lisp_Object table;
1851{
ec1c14f6 1852 register int pos_byte, stop; /* Limits of the region. */
35692fe0 1853 register unsigned char *tt; /* Trans table. */
35692fe0
JB
1854 register int nc; /* New character. */
1855 int cnt; /* Number of changes made. */
35692fe0 1856 int size; /* Size of translate table. */
1f24f4fd 1857 int pos;
35692fe0
JB
1858
1859 validate_region (&start, &end);
1860 CHECK_STRING (table, 2);
1861
1f24f4fd 1862 size = XSTRING (table)->size_byte;
35692fe0
JB
1863 tt = XSTRING (table)->data;
1864
ec1c14f6
RS
1865 pos_byte = CHAR_TO_BYTE (XINT (start));
1866 stop = CHAR_TO_BYTE (XINT (end));
1867 modify_region (current_buffer, XINT (start), XINT (end));
1f24f4fd 1868 pos = XINT (start);
35692fe0
JB
1869
1870 cnt = 0;
1f24f4fd 1871 for (; pos_byte < stop; )
35692fe0 1872 {
ec1c14f6 1873 register unsigned char *p = BYTE_POS_ADDR (pos_byte);
1f24f4fd
RS
1874 int len;
1875 int oc;
ec1c14f6 1876
1f24f4fd
RS
1877 oc = STRING_CHAR_AND_LENGTH (p, stop - pos_byte, len);
1878 if (oc < size && len == 1)
35692fe0
JB
1879 {
1880 nc = tt[oc];
1881 if (nc != oc)
1882 {
1f24f4fd 1883 record_change (pos, 1);
ec1c14f6 1884 *p = nc;
1f24f4fd 1885 signal_after_change (pos, 1, 1);
35692fe0
JB
1886 ++cnt;
1887 }
1888 }
1f24f4fd
RS
1889 pos_byte += len;
1890 pos++;
35692fe0
JB
1891 }
1892
ec1c14f6 1893 return make_number (cnt);
35692fe0
JB
1894}
1895
1896DEFUN ("delete-region", Fdelete_region, Sdelete_region, 2, 2, "r",
1897 "Delete the text between point and mark.\n\
1898When called from a program, expects two arguments,\n\
1899positions (integers or markers) specifying the stretch to be deleted.")
2591ec64
EN
1900 (start, end)
1901 Lisp_Object start, end;
35692fe0 1902{
2591ec64
EN
1903 validate_region (&start, &end);
1904 del_range (XINT (start), XINT (end));
35692fe0
JB
1905 return Qnil;
1906}
1907\f
1908DEFUN ("widen", Fwiden, Swiden, 0, 0, "",
1909 "Remove restrictions (narrowing) from current buffer.\n\
1910This allows the buffer's full text to be seen and edited.")
1911 ()
1912{
2cad2e34
RS
1913 if (BEG != BEGV || Z != ZV)
1914 current_buffer->clip_changed = 1;
35692fe0 1915 BEGV = BEG;
ec1c14f6
RS
1916 BEGV_BYTE = BEG_BYTE;
1917 SET_BUF_ZV_BOTH (current_buffer, Z, Z_BYTE);
52b14ac0
JB
1918 /* Changing the buffer bounds invalidates any recorded current column. */
1919 invalidate_current_column ();
35692fe0
JB
1920 return Qnil;
1921}
1922
1923DEFUN ("narrow-to-region", Fnarrow_to_region, Snarrow_to_region, 2, 2, "r",
1924 "Restrict editing in this buffer to the current region.\n\
1925The rest of the text becomes temporarily invisible and untouchable\n\
1926but is not deleted; if you save the buffer in a file, the invisible\n\
1927text is included in the file. \\[widen] makes all visible again.\n\
1928See also `save-restriction'.\n\
1929\n\
1930When calling from a program, pass two arguments; positions (integers\n\
1931or markers) bounding the text that should remain visible.")
2591ec64
EN
1932 (start, end)
1933 register Lisp_Object start, end;
35692fe0 1934{
2591ec64
EN
1935 CHECK_NUMBER_COERCE_MARKER (start, 0);
1936 CHECK_NUMBER_COERCE_MARKER (end, 1);
35692fe0 1937
2591ec64 1938 if (XINT (start) > XINT (end))
35692fe0 1939 {
b5a6948e 1940 Lisp_Object tem;
2591ec64 1941 tem = start; start = end; end = tem;
35692fe0
JB
1942 }
1943
2591ec64
EN
1944 if (!(BEG <= XINT (start) && XINT (start) <= XINT (end) && XINT (end) <= Z))
1945 args_out_of_range (start, end);
35692fe0 1946
2cad2e34
RS
1947 if (BEGV != XFASTINT (start) || ZV != XFASTINT (end))
1948 current_buffer->clip_changed = 1;
1949
ec1c14f6 1950 SET_BUF_BEGV (current_buffer, XFASTINT (start));
2591ec64 1951 SET_BUF_ZV (current_buffer, XFASTINT (end));
6ec8bbd2 1952 if (PT < XFASTINT (start))
2591ec64 1953 SET_PT (XFASTINT (start));
6ec8bbd2 1954 if (PT > XFASTINT (end))
2591ec64 1955 SET_PT (XFASTINT (end));
52b14ac0
JB
1956 /* Changing the buffer bounds invalidates any recorded current column. */
1957 invalidate_current_column ();
35692fe0
JB
1958 return Qnil;
1959}
1960
1961Lisp_Object
1962save_restriction_save ()
1963{
1964 register Lisp_Object bottom, top;
1965 /* Note: I tried using markers here, but it does not win
1966 because insertion at the end of the saved region
1967 does not advance mh and is considered "outside" the saved region. */
55561c63
KH
1968 XSETFASTINT (bottom, BEGV - BEG);
1969 XSETFASTINT (top, Z - ZV);
35692fe0
JB
1970
1971 return Fcons (Fcurrent_buffer (), Fcons (bottom, top));
1972}
1973
1974Lisp_Object
1975save_restriction_restore (data)
1976 Lisp_Object data;
1977{
1978 register struct buffer *buf;
1979 register int newhead, newtail;
1980 register Lisp_Object tem;
2cad2e34 1981 int obegv, ozv;
35692fe0
JB
1982
1983 buf = XBUFFER (XCONS (data)->car);
1984
1985 data = XCONS (data)->cdr;
1986
1987 tem = XCONS (data)->car;
1988 newhead = XINT (tem);
1989 tem = XCONS (data)->cdr;
1990 newtail = XINT (tem);
1991 if (newhead + newtail > BUF_Z (buf) - BUF_BEG (buf))
1992 {
1993 newhead = 0;
1994 newtail = 0;
1995 }
2cad2e34
RS
1996
1997 obegv = BUF_BEGV (buf);
1998 ozv = BUF_ZV (buf);
1999
ec1c14f6 2000 SET_BUF_BEGV (buf, BUF_BEG (buf) + newhead);
35692fe0 2001 SET_BUF_ZV (buf, BUF_Z (buf) - newtail);
2cad2e34
RS
2002
2003 if (obegv != BUF_BEGV (buf) || ozv != BUF_ZV (buf))
2004 current_buffer->clip_changed = 1;
35692fe0
JB
2005
2006 /* If point is outside the new visible range, move it inside. */
ec1c14f6
RS
2007 SET_BUF_PT_BOTH (buf,
2008 clip_to_bounds (BUF_BEGV (buf), BUF_PT (buf), BUF_ZV (buf)),
2009 clip_to_bounds (BUF_BEGV_BYTE (buf), BUF_PT_BYTE (buf),
2010 BUF_ZV_BYTE (buf)));
35692fe0
JB
2011
2012 return Qnil;
2013}
2014
2015DEFUN ("save-restriction", Fsave_restriction, Ssave_restriction, 0, UNEVALLED, 0,
2016 "Execute BODY, saving and restoring current buffer's restrictions.\n\
2017The buffer's restrictions make parts of the beginning and end invisible.\n\
2018\(They are set up with `narrow-to-region' and eliminated with `widen'.)\n\
2019This special form, `save-restriction', saves the current buffer's restrictions\n\
2020when it is entered, and restores them when it is exited.\n\
2021So any `narrow-to-region' within BODY lasts only until the end of the form.\n\
2022The old restrictions settings are restored\n\
2023even in case of abnormal exit (throw or error).\n\
2024\n\
2025The value returned is the value of the last form in BODY.\n\
2026\n\
2027`save-restriction' can get confused if, within the BODY, you widen\n\
2028and then make changes outside the area within the saved restrictions.\n\
2029\n\
2030Note: if you are using both `save-excursion' and `save-restriction',\n\
2031use `save-excursion' outermost:\n\
2032 (save-excursion (save-restriction ...))")
2033 (body)
2034 Lisp_Object body;
2035{
2036 register Lisp_Object val;
2037 int count = specpdl_ptr - specpdl;
2038
2039 record_unwind_protect (save_restriction_restore, save_restriction_save ());
2040 val = Fprogn (body);
2041 return unbind_to (count, val);
2042}
2043\f
671fbc4d
KH
2044/* Buffer for the most recent text displayed by Fmessage. */
2045static char *message_text;
2046
2047/* Allocated length of that buffer. */
2048static int message_length;
2049
35692fe0
JB
2050DEFUN ("message", Fmessage, Smessage, 1, MANY, 0,
2051 "Print a one-line message at the bottom of the screen.\n\
98fc5c3c
RS
2052The first argument is a format control string, and the rest are data\n\
2053to be formatted under control of the string. See `format' for details.\n\
2054\n\
ccdac5be
JB
2055If the first argument is nil, clear any existing message; let the\n\
2056minibuffer contents show.")
35692fe0
JB
2057 (nargs, args)
2058 int nargs;
2059 Lisp_Object *args;
2060{
ccdac5be 2061 if (NILP (args[0]))
f0250249
JB
2062 {
2063 message (0);
2064 return Qnil;
2065 }
ccdac5be
JB
2066 else
2067 {
2068 register Lisp_Object val;
2069 val = Fformat (nargs, args);
671fbc4d
KH
2070 /* Copy the data so that it won't move when we GC. */
2071 if (! message_text)
2072 {
2073 message_text = (char *)xmalloc (80);
2074 message_length = 80;
2075 }
2076 if (XSTRING (val)->size > message_length)
2077 {
1f24f4fd 2078 message_length = XSTRING (val)->size_byte;
671fbc4d
KH
2079 message_text = (char *)xrealloc (message_text, message_length);
2080 }
1f24f4fd
RS
2081 bcopy (XSTRING (val)->data, message_text, XSTRING (val)->size_byte);
2082 message2 (message_text, XSTRING (val)->size_byte,
2083 STRING_MULTIBYTE (val));
ccdac5be
JB
2084 return val;
2085 }
35692fe0
JB
2086}
2087
cacc3e2c
RS
2088DEFUN ("message-box", Fmessage_box, Smessage_box, 1, MANY, 0,
2089 "Display a message, in a dialog box if possible.\n\
2090If a dialog box is not available, use the echo area.\n\
f8250f01
RS
2091The first argument is a format control string, and the rest are data\n\
2092to be formatted under control of the string. See `format' for details.\n\
2093\n\
cacc3e2c
RS
2094If the first argument is nil, clear any existing message; let the\n\
2095minibuffer contents show.")
2096 (nargs, args)
2097 int nargs;
2098 Lisp_Object *args;
2099{
2100 if (NILP (args[0]))
2101 {
2102 message (0);
2103 return Qnil;
2104 }
2105 else
2106 {
2107 register Lisp_Object val;
2108 val = Fformat (nargs, args);
f8250f01 2109#ifdef HAVE_MENUS
cacc3e2c
RS
2110 {
2111 Lisp_Object pane, menu, obj;
2112 struct gcpro gcpro1;
2113 pane = Fcons (Fcons (build_string ("OK"), Qt), Qnil);
2114 GCPRO1 (pane);
2115 menu = Fcons (val, pane);
2116 obj = Fx_popup_dialog (Qt, menu);
2117 UNGCPRO;
2118 return val;
2119 }
f8250f01 2120#else /* not HAVE_MENUS */
cacc3e2c
RS
2121 /* Copy the data so that it won't move when we GC. */
2122 if (! message_text)
2123 {
2124 message_text = (char *)xmalloc (80);
2125 message_length = 80;
2126 }
1f24f4fd 2127 if (XSTRING (val)->size_byte > message_length)
cacc3e2c 2128 {
1f24f4fd 2129 message_length = XSTRING (val)->size_byte;
cacc3e2c
RS
2130 message_text = (char *)xrealloc (message_text, message_length);
2131 }
1f24f4fd
RS
2132 bcopy (XSTRING (val)->data, message_text, XSTRING (val)->size_byte);
2133 message2 (message_text, XSTRING (val)->size_byte);
cacc3e2c 2134 return val;
f8250f01 2135#endif /* not HAVE_MENUS */
cacc3e2c
RS
2136 }
2137}
f8250f01 2138#ifdef HAVE_MENUS
cacc3e2c
RS
2139extern Lisp_Object last_nonmenu_event;
2140#endif
f8250f01 2141
cacc3e2c
RS
2142DEFUN ("message-or-box", Fmessage_or_box, Smessage_or_box, 1, MANY, 0,
2143 "Display a message in a dialog box or in the echo area.\n\
2144If this command was invoked with the mouse, use a dialog box.\n\
2145Otherwise, use the echo area.\n\
f8250f01
RS
2146The first argument is a format control string, and the rest are data\n\
2147to be formatted under control of the string. See `format' for details.\n\
cacc3e2c 2148\n\
cacc3e2c
RS
2149If the first argument is nil, clear any existing message; let the\n\
2150minibuffer contents show.")
2151 (nargs, args)
2152 int nargs;
2153 Lisp_Object *args;
2154{
f8250f01 2155#ifdef HAVE_MENUS
cacc3e2c 2156 if (NILP (last_nonmenu_event) || CONSP (last_nonmenu_event))
0a56ee6b 2157 return Fmessage_box (nargs, args);
cacc3e2c
RS
2158#endif
2159 return Fmessage (nargs, args);
2160}
2161
b14dda8a
RS
2162DEFUN ("current-message", Fcurrent_message, Scurrent_message, 0, 0, 0,
2163 "Return the string currently displayed in the echo area, or nil if none.")
2164 ()
2165{
2166 return (echo_area_glyphs
2167 ? make_string (echo_area_glyphs, echo_area_glyphs_length)
2168 : Qnil);
2169}
2170
1f24f4fd
RS
2171/* Number of bytes that STRING will occupy when put into the result.
2172 MULTIBYTE is nonzero if the result should be multibyte. */
2173
2174#define CONVERTED_BYTE_SIZE(MULTIBYTE, STRING) \
2175 (((MULTIBYTE) && ! STRING_MULTIBYTE (STRING)) \
8d6179dc
KH
2176 ? count_size_as_multibyte (XSTRING (STRING)->data, \
2177 XSTRING (STRING)->size_byte) \
2178 : XSTRING (STRING)->size_byte)
1f24f4fd 2179
35692fe0
JB
2180DEFUN ("format", Fformat, Sformat, 1, MANY, 0,
2181 "Format a string out of a control-string and arguments.\n\
2182The first argument is a control string.\n\
2183The other arguments are substituted into it to make the result, a string.\n\
2184It may contain %-sequences meaning to substitute the next argument.\n\
2185%s means print a string argument. Actually, prints any object, with `princ'.\n\
2186%d means print as number in decimal (%o octal, %x hex).\n\
9db1775a
RS
2187%e means print a number in exponential notation.\n\
2188%f means print a number in decimal-point notation.\n\
2189%g means print a number in exponential notation\n\
2190 or decimal-point notation, whichever uses fewer characters.\n\
35692fe0
JB
2191%c means print a number as a single character.\n\
2192%S means print any object as an s-expression (using prin1).\n\
9db1775a 2193 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.\n\
52b14ac0 2194Use %% to put a single % into the output.")
35692fe0
JB
2195 (nargs, args)
2196 int nargs;
2197 register Lisp_Object *args;
2198{
2199 register int n; /* The number of the next arg to substitute */
e781c49e 2200 register int total; /* An estimate of the final length */
1f24f4fd 2201 char *buf, *p;
35692fe0 2202 register unsigned char *format, *end;
1f24f4fd
RS
2203 int length, nchars;
2204 /* Nonzero if the output should be a multibyte string,
2205 which is true if any of the inputs is one. */
2206 int multibyte = 0;
2207 unsigned char *this_format;
e781c49e 2208 int longest_format;
8d6179dc 2209 Lisp_Object val;
1f24f4fd 2210
35692fe0 2211 extern char *index ();
1f24f4fd 2212
35692fe0
JB
2213 /* It should not be necessary to GCPRO ARGS, because
2214 the caller in the interpreter should take care of that. */
2215
e781c49e
RS
2216 /* Try to determine whether the result should be multibyte.
2217 This is not always right; sometimes the result needs to be multibyte
2218 because of an object that we will pass through prin1,
2219 and in that case, we won't know it here. */
1f24f4fd
RS
2220 for (n = 0; n < nargs; n++)
2221 if (STRINGP (args[n]) && STRING_MULTIBYTE (args[n]))
2222 multibyte = 1;
2223
35692fe0 2224 CHECK_STRING (args[0], 0);
e781c49e
RS
2225
2226 /* If we start out planning a unibyte result,
2227 and later find it has to be multibyte, we jump back to retry. */
2228 retry:
2229
35692fe0 2230 format = XSTRING (args[0])->data;
1f24f4fd 2231 end = format + XSTRING (args[0])->size_byte;
e781c49e 2232 longest_format = 0;
1f24f4fd
RS
2233
2234 /* Make room in result for all the non-%-codes in the control string. */
e781c49e 2235 total = 5 + CONVERTED_BYTE_SIZE (multibyte, args[0]);
1f24f4fd
RS
2236
2237 /* Add to TOTAL enough space to hold the converted arguments. */
35692fe0
JB
2238
2239 n = 0;
2240 while (format != end)
2241 if (*format++ == '%')
2242 {
1f24f4fd
RS
2243 int minlen, thissize = 0;
2244 unsigned char *this_format_start = format - 1;
35692fe0
JB
2245
2246 /* Process a numeric arg and skip it. */
2247 minlen = atoi (format);
537dfb13
RS
2248 if (minlen < 0)
2249 minlen = - minlen;
2250
35692fe0
JB
2251 while ((*format >= '0' && *format <= '9')
2252 || *format == '-' || *format == ' ' || *format == '.')
2253 format++;
2254
1f24f4fd
RS
2255 if (format - this_format_start + 1 > longest_format)
2256 longest_format = format - this_format_start + 1;
2257
35692fe0
JB
2258 if (*format == '%')
2259 format++;
2260 else if (++n >= nargs)
537dfb13 2261 error ("Not enough arguments for format string");
35692fe0
JB
2262 else if (*format == 'S')
2263 {
2264 /* For `S', prin1 the argument and then treat like a string. */
2265 register Lisp_Object tem;
2266 tem = Fprin1_to_string (args[n], Qnil);
e781c49e
RS
2267 if (STRING_MULTIBYTE (tem) && ! multibyte)
2268 {
2269 multibyte = 1;
2270 goto retry;
2271 }
35692fe0
JB
2272 args[n] = tem;
2273 goto string;
2274 }
ae683129 2275 else if (SYMBOLP (args[n]))
35692fe0 2276 {
d2fd0445 2277 XSETSTRING (args[n], XSYMBOL (args[n])->name);
7df74da6
RS
2278 if (STRING_MULTIBYTE (args[n]) && ! multibyte)
2279 {
2280 multibyte = 1;
2281 goto retry;
2282 }
35692fe0
JB
2283 goto string;
2284 }
ae683129 2285 else if (STRINGP (args[n]))
35692fe0
JB
2286 {
2287 string:
b22e7ecc
KH
2288 if (*format != 's' && *format != 'S')
2289 error ("format specifier doesn't match argument type");
1f24f4fd 2290 thissize = CONVERTED_BYTE_SIZE (multibyte, args[n]);
35692fe0
JB
2291 }
2292 /* Would get MPV otherwise, since Lisp_Int's `point' to low memory. */
ae683129 2293 else if (INTEGERP (args[n]) && *format != 's')
35692fe0 2294 {
4746118a 2295#ifdef LISP_FLOAT_TYPE
eb8c3be9 2296 /* The following loop assumes the Lisp type indicates
35692fe0
JB
2297 the proper way to pass the argument.
2298 So make sure we have a flonum if the argument should
2299 be a double. */
2300 if (*format == 'e' || *format == 'f' || *format == 'g')
2301 args[n] = Ffloat (args[n]);
4746118a 2302#endif
1f24f4fd 2303 thissize = 30;
35692fe0 2304 }
4746118a 2305#ifdef LISP_FLOAT_TYPE
ae683129 2306 else if (FLOATP (args[n]) && *format != 's')
35692fe0
JB
2307 {
2308 if (! (*format == 'e' || *format == 'f' || *format == 'g'))
247422ce 2309 args[n] = Ftruncate (args[n], Qnil);
1f24f4fd 2310 thissize = 60;
35692fe0 2311 }
4746118a 2312#endif
35692fe0
JB
2313 else
2314 {
2315 /* Anything but a string, convert to a string using princ. */
2316 register Lisp_Object tem;
2317 tem = Fprin1_to_string (args[n], Qt);
8d6179dc 2318 if (STRING_MULTIBYTE (tem))
e781c49e
RS
2319 {
2320 multibyte = 1;
2321 goto retry;
2322 }
35692fe0
JB
2323 args[n] = tem;
2324 goto string;
2325 }
1f24f4fd
RS
2326
2327 if (thissize < minlen)
2328 thissize = minlen;
2329
2330 total += thissize + 4;
35692fe0
JB
2331 }
2332
e781c49e
RS
2333 /* Now we can no longer jump to retry.
2334 TOTAL and LONGEST_FORMAT are known for certain. */
2335
1f24f4fd 2336 this_format = (unsigned char *) alloca (longest_format + 1);
50aa2f90 2337
1f24f4fd
RS
2338 /* Allocate the space for the result.
2339 Note that TOTAL is an overestimate. */
2340 if (total < 1000)
2341 buf = (unsigned char *) alloca (total + 1);
2342 else
2343 buf = (unsigned char *) xmalloc (total + 1);
35692fe0 2344
1f24f4fd
RS
2345 p = buf;
2346 nchars = 0;
2347 n = 0;
35692fe0 2348
1f24f4fd
RS
2349 /* Scan the format and store result in BUF. */
2350 format = XSTRING (args[0])->data;
2351 while (format != end)
2352 {
2353 if (*format == '%')
2354 {
2355 int minlen;
2356 unsigned char *this_format_start = format;
35692fe0 2357
1f24f4fd 2358 format++;
fb893977 2359
1f24f4fd
RS
2360 /* Process a numeric arg and skip it. */
2361 minlen = atoi (format);
2362 if (minlen < 0)
2363 minlen = - minlen;
35692fe0 2364
1f24f4fd
RS
2365 while ((*format >= '0' && *format <= '9')
2366 || *format == '-' || *format == ' ' || *format == '.')
2367 format++;
35692fe0 2368
1f24f4fd
RS
2369 if (*format++ == '%')
2370 {
2371 *p++ = '%';
2372 nchars++;
2373 continue;
2374 }
2375
2376 ++n;
2377
2378 if (STRINGP (args[n]))
2379 {
2380 int padding, nbytes;
2381
2382 nbytes = copy_text (XSTRING (args[n])->data, p,
2383 XSTRING (args[n])->size_byte,
2384 STRING_MULTIBYTE (args[n]), multibyte);
2385 p += nbytes;
2386 nchars += XSTRING (args[n])->size;
2387
2388 /* If spec requires it, pad on right with spaces. */
2389 padding = minlen - XSTRING (args[n])->size;
2390 while (padding-- > 0)
2391 {
2392 *p++ = ' ';
2393 nchars++;
2394 }
2395 }
2396 else if (INTEGERP (args[n]) || FLOATP (args[n]))
2397 {
2398 int this_nchars;
2399
2400 bcopy (this_format_start, this_format,
2401 format - this_format_start);
2402 this_format[format - this_format_start] = 0;
2403
2404 sprintf (p, this_format, XINT (args[n]));
2405
2406 this_nchars = strlen (p);
2407 p += this_nchars;
2408 nchars += this_nchars;
2409 }
2410 }
7df74da6
RS
2411 else if (STRING_MULTIBYTE (args[0]))
2412 {
2413 /* Copy a whole multibyte character. */
2414 *p++ = *format++;
2415 while (! CHAR_HEAD_P (*format)) *p++ = *format++;
2416 nchars++;
2417 }
2418 else if (multibyte)
1f24f4fd
RS
2419 {
2420 /* Convert a single-byte character to multibyte. */
2421 int len = copy_text (format, p, 1, 0, 1);
2422
2423 p += len;
2424 format++;
2425 nchars++;
2426 }
2427 else
2428 *p++ = *format++, nchars++;
2429 }
2430
8d6179dc
KH
2431 val = make_multibyte_string (buf, nchars, p - buf);
2432
1f24f4fd
RS
2433 /* If we allocated BUF with malloc, free it too. */
2434 if (total >= 1000)
2435 xfree (buf);
35692fe0 2436
8d6179dc 2437 return val;
35692fe0
JB
2438}
2439
2440/* VARARGS 1 */
2441Lisp_Object
2442#ifdef NO_ARG_ARRAY
2443format1 (string1, arg0, arg1, arg2, arg3, arg4)
679e18b1 2444 EMACS_INT arg0, arg1, arg2, arg3, arg4;
35692fe0
JB
2445#else
2446format1 (string1)
2447#endif
2448 char *string1;
2449{
2450 char buf[100];
2451#ifdef NO_ARG_ARRAY
679e18b1 2452 EMACS_INT args[5];
35692fe0
JB
2453 args[0] = arg0;
2454 args[1] = arg1;
2455 args[2] = arg2;
2456 args[3] = arg3;
2457 args[4] = arg4;
ea4d2909 2458 doprnt (buf, sizeof buf, string1, (char *)0, 5, args);
35692fe0 2459#else
ea4d2909 2460 doprnt (buf, sizeof buf, string1, (char *)0, 5, &string1 + 1);
35692fe0
JB
2461#endif
2462 return build_string (buf);
2463}
2464\f
2465DEFUN ("char-equal", Fchar_equal, Schar_equal, 2, 2, 0,
2466 "Return t if two characters match, optionally ignoring case.\n\
2467Both arguments must be characters (i.e. integers).\n\
2468Case is ignored if `case-fold-search' is non-nil in the current buffer.")
2469 (c1, c2)
2470 register Lisp_Object c1, c2;
2471{
1b5d98bb 2472 int i1, i2;
35692fe0
JB
2473 CHECK_NUMBER (c1, 0);
2474 CHECK_NUMBER (c2, 1);
2475
1b5d98bb 2476 if (XINT (c1) == XINT (c2))
35692fe0 2477 return Qt;
1b5d98bb
RS
2478 if (NILP (current_buffer->case_fold_search))
2479 return Qnil;
2480
2481 /* Do these in separate statements,
2482 then compare the variables.
2483 because of the way DOWNCASE uses temp variables. */
2484 i1 = DOWNCASE (XFASTINT (c1));
2485 i2 = DOWNCASE (XFASTINT (c2));
2486 return (i1 == i2 ? Qt : Qnil);
35692fe0 2487}
b229b8d1
RS
2488\f
2489/* Transpose the markers in two regions of the current buffer, and
2490 adjust the ones between them if necessary (i.e.: if the regions
2491 differ in size).
2492
ec1c14f6
RS
2493 START1, END1 are the character positions of the first region.
2494 START1_BYTE, END1_BYTE are the byte positions.
2495 START2, END2 are the character positions of the second region.
2496 START2_BYTE, END2_BYTE are the byte positions.
2497
b229b8d1
RS
2498 Traverses the entire marker list of the buffer to do so, adding an
2499 appropriate amount to some, subtracting from some, and leaving the
2500 rest untouched. Most of this is copied from adjust_markers in insdel.c.
2501
ec1c14f6 2502 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
b229b8d1
RS
2503
2504void
ec1c14f6
RS
2505transpose_markers (start1, end1, start2, end2,
2506 start1_byte, end1_byte, start2_byte, end2_byte)
b229b8d1 2507 register int start1, end1, start2, end2;
ec1c14f6 2508 register int start1_byte, end1_byte, start2_byte, end2_byte;
b229b8d1 2509{
ec1c14f6 2510 register int amt1, amt1_byte, amt2, amt2_byte, diff, diff_byte, mpos;
b229b8d1 2511 register Lisp_Object marker;
b229b8d1 2512
03240d11 2513 /* Update point as if it were a marker. */
8de1d5f0
KH
2514 if (PT < start1)
2515 ;
2516 else if (PT < end1)
ec1c14f6
RS
2517 TEMP_SET_PT_BOTH (PT + (end2 - end1),
2518 PT_BYTE + (end2_byte - end1_byte));
8de1d5f0 2519 else if (PT < start2)
ec1c14f6
RS
2520 TEMP_SET_PT_BOTH (PT + (end2 - start2) - (end1 - start1),
2521 (PT_BYTE + (end2_byte - start2_byte)
2522 - (end1_byte - start1_byte)));
8de1d5f0 2523 else if (PT < end2)
ec1c14f6
RS
2524 TEMP_SET_PT_BOTH (PT - (start2 - start1),
2525 PT_BYTE - (start2_byte - start1_byte));
8de1d5f0 2526
03240d11
KH
2527 /* We used to adjust the endpoints here to account for the gap, but that
2528 isn't good enough. Even if we assume the caller has tried to move the
2529 gap out of our way, it might still be at start1 exactly, for example;
2530 and that places it `inside' the interval, for our purposes. The amount
2531 of adjustment is nontrivial if there's a `denormalized' marker whose
2532 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
2533 the dirty work to Fmarker_position, below. */
b229b8d1
RS
2534
2535 /* The difference between the region's lengths */
2536 diff = (end2 - start2) - (end1 - start1);
ec1c14f6 2537 diff_byte = (end2_byte - start2_byte) - (end1_byte - start1_byte);
b229b8d1
RS
2538
2539 /* For shifting each marker in a region by the length of the other
ec1c14f6 2540 region plus the distance between the regions. */
b229b8d1
RS
2541 amt1 = (end2 - start2) + (start2 - end1);
2542 amt2 = (end1 - start1) + (start2 - end1);
ec1c14f6
RS
2543 amt1_byte = (end2_byte - start2_byte) + (start2_byte - end1_byte);
2544 amt2_byte = (end1_byte - start1_byte) + (start2_byte - end1_byte);
b229b8d1 2545
1e158d25 2546 for (marker = BUF_MARKERS (current_buffer); !NILP (marker);
03240d11 2547 marker = XMARKER (marker)->chain)
b229b8d1 2548 {
ec1c14f6
RS
2549 mpos = marker_byte_position (marker);
2550 if (mpos >= start1_byte && mpos < end2_byte)
2551 {
2552 if (mpos < end1_byte)
2553 mpos += amt1_byte;
2554 else if (mpos < start2_byte)
2555 mpos += diff_byte;
2556 else
2557 mpos -= amt2_byte;
f3e1f752 2558 XMARKER (marker)->bytepos = mpos;
ec1c14f6
RS
2559 }
2560 mpos = XMARKER (marker)->charpos;
03240d11
KH
2561 if (mpos >= start1 && mpos < end2)
2562 {
2563 if (mpos < end1)
2564 mpos += amt1;
2565 else if (mpos < start2)
2566 mpos += diff;
2567 else
2568 mpos -= amt2;
03240d11 2569 }
ec1c14f6 2570 XMARKER (marker)->charpos = mpos;
b229b8d1
RS
2571 }
2572}
2573
2574DEFUN ("transpose-regions", Ftranspose_regions, Stranspose_regions, 4, 5, 0,
2575 "Transpose region START1 to END1 with START2 to END2.\n\
2576The regions may not be overlapping, because the size of the buffer is\n\
2577never changed in a transposition.\n\
2578\n\
ec1c14f6 2579Optional fifth arg LEAVE_MARKERS, if non-nil, means don't update\n\
b229b8d1
RS
2580any markers that happen to be located in the regions.\n\
2581\n\
2582Transposing beyond buffer boundaries is an error.")
2583 (startr1, endr1, startr2, endr2, leave_markers)
2584 Lisp_Object startr1, endr1, startr2, endr2, leave_markers;
2585{
ec1c14f6
RS
2586 register int start1, end1, start2, end2;
2587 int start1_byte, start2_byte, len1_byte, len2_byte;
2588 int gap, len1, len_mid, len2;
3c6bc7d0 2589 unsigned char *start1_addr, *start2_addr, *temp;
b229b8d1
RS
2590
2591#ifdef USE_TEXT_PROPERTIES
2592 INTERVAL cur_intv, tmp_interval1, tmp_interval_mid, tmp_interval2;
1e158d25 2593 cur_intv = BUF_INTERVALS (current_buffer);
b229b8d1
RS
2594#endif /* USE_TEXT_PROPERTIES */
2595
2596 validate_region (&startr1, &endr1);
2597 validate_region (&startr2, &endr2);
2598
2599 start1 = XFASTINT (startr1);
2600 end1 = XFASTINT (endr1);
2601 start2 = XFASTINT (startr2);
2602 end2 = XFASTINT (endr2);
2603 gap = GPT;
2604
2605 /* Swap the regions if they're reversed. */
2606 if (start2 < end1)
2607 {
2608 register int glumph = start1;
2609 start1 = start2;
2610 start2 = glumph;
2611 glumph = end1;
2612 end1 = end2;
2613 end2 = glumph;
2614 }
2615
b229b8d1
RS
2616 len1 = end1 - start1;
2617 len2 = end2 - start2;
2618
2619 if (start2 < end1)
ec1c14f6 2620 error ("Transposed regions not properly ordered");
b229b8d1 2621 else if (start1 == end1 || start2 == end2)
ec1c14f6 2622 error ("Transposed region may not be of length 0");
b229b8d1
RS
2623
2624 /* The possibilities are:
2625 1. Adjacent (contiguous) regions, or separate but equal regions
2626 (no, really equal, in this case!), or
2627 2. Separate regions of unequal size.
2628
2629 The worst case is usually No. 2. It means that (aside from
2630 potential need for getting the gap out of the way), there also
2631 needs to be a shifting of the text between the two regions. So
2632 if they are spread far apart, we are that much slower... sigh. */
2633
2634 /* It must be pointed out that the really studly thing to do would
2635 be not to move the gap at all, but to leave it in place and work
2636 around it if necessary. This would be extremely efficient,
2637 especially considering that people are likely to do
2638 transpositions near where they are working interactively, which
2639 is exactly where the gap would be found. However, such code
2640 would be much harder to write and to read. So, if you are
2641 reading this comment and are feeling squirrely, by all means have
2642 a go! I just didn't feel like doing it, so I will simply move
2643 the gap the minimum distance to get it out of the way, and then
2644 deal with an unbroken array. */
3c6bc7d0
RS
2645
2646 /* Make sure the gap won't interfere, by moving it out of the text
2647 we will operate on. */
2648 if (start1 < gap && gap < end2)
2649 {
2650 if (gap - start1 < end2 - gap)
2651 move_gap (start1);
2652 else
2653 move_gap (end2);
2654 }
ec1c14f6
RS
2655
2656 start1_byte = CHAR_TO_BYTE (start1);
2657 start2_byte = CHAR_TO_BYTE (start2);
2658 len1_byte = CHAR_TO_BYTE (end1) - start1_byte;
2659 len2_byte = CHAR_TO_BYTE (end2) - start2_byte;
b229b8d1
RS
2660
2661 /* Hmmm... how about checking to see if the gap is large
2662 enough to use as the temporary storage? That would avoid an
2663 allocation... interesting. Later, don't fool with it now. */
2664
2665 /* Working without memmove, for portability (sigh), so must be
2666 careful of overlapping subsections of the array... */
2667
2668 if (end1 == start2) /* adjacent regions */
2669 {
b229b8d1
RS
2670 modify_region (current_buffer, start1, end2);
2671 record_change (start1, len1 + len2);
2672
2673#ifdef USE_TEXT_PROPERTIES
2674 tmp_interval1 = copy_intervals (cur_intv, start1, len1);
2675 tmp_interval2 = copy_intervals (cur_intv, start2, len2);
09dbcf71
RS
2676 Fset_text_properties (make_number (start1), make_number (end2),
2677 Qnil, Qnil);
b229b8d1
RS
2678#endif /* USE_TEXT_PROPERTIES */
2679
2680 /* First region smaller than second. */
ec1c14f6 2681 if (len1_byte < len2_byte)
b229b8d1 2682 {
3c6bc7d0
RS
2683 /* We use alloca only if it is small,
2684 because we want to avoid stack overflow. */
ec1c14f6
RS
2685 if (len2_byte > 20000)
2686 temp = (unsigned char *) xmalloc (len2_byte);
3c6bc7d0 2687 else
ec1c14f6 2688 temp = (unsigned char *) alloca (len2_byte);
03240d11
KH
2689
2690 /* Don't precompute these addresses. We have to compute them
2691 at the last minute, because the relocating allocator might
2692 have moved the buffer around during the xmalloc. */
ec1c14f6
RS
2693 start1_addr = BUF_CHAR_ADDRESS (current_buffer, start1_byte);
2694 start2_addr = BUF_CHAR_ADDRESS (current_buffer, start2_byte);
03240d11 2695
ec1c14f6
RS
2696 bcopy (start2_addr, temp, len2_byte);
2697 bcopy (start1_addr, start1_addr + len2_byte, len1_byte);
2698 bcopy (temp, start1_addr, len2_byte);
2699 if (len2_byte > 20000)
3c6bc7d0 2700 free (temp);
b229b8d1
RS
2701 }
2702 else
2703 /* First region not smaller than second. */
2704 {
ec1c14f6
RS
2705 if (len1_byte > 20000)
2706 temp = (unsigned char *) xmalloc (len1_byte);
3c6bc7d0 2707 else
ec1c14f6
RS
2708 temp = (unsigned char *) alloca (len1_byte);
2709 start1_addr = BUF_CHAR_ADDRESS (current_buffer, start1_byte);
2710 start2_addr = BUF_CHAR_ADDRESS (current_buffer, start2_byte);
2711 bcopy (start1_addr, temp, len1_byte);
2712 bcopy (start2_addr, start1_addr, len2_byte);
2713 bcopy (temp, start1_addr + len2_byte, len1_byte);
2714 if (len1_byte > 20000)
3c6bc7d0 2715 free (temp);
b229b8d1
RS
2716 }
2717#ifdef USE_TEXT_PROPERTIES
2718 graft_intervals_into_buffer (tmp_interval1, start1 + len2,
2719 len1, current_buffer, 0);
2720 graft_intervals_into_buffer (tmp_interval2, start1,
2721 len2, current_buffer, 0);
2722#endif /* USE_TEXT_PROPERTIES */
2723 }
2724 /* Non-adjacent regions, because end1 != start2, bleagh... */
2725 else
2726 {
ec1c14f6
RS
2727 len_mid = start2_byte - (start1_byte + len1_byte);
2728
2729 if (len1_byte == len2_byte)
b229b8d1
RS
2730 /* Regions are same size, though, how nice. */
2731 {
2732 modify_region (current_buffer, start1, end1);
2733 modify_region (current_buffer, start2, end2);
2734 record_change (start1, len1);
2735 record_change (start2, len2);
2736#ifdef USE_TEXT_PROPERTIES
2737 tmp_interval1 = copy_intervals (cur_intv, start1, len1);
2738 tmp_interval2 = copy_intervals (cur_intv, start2, len2);
09dbcf71
RS
2739 Fset_text_properties (make_number (start1), make_number (end1),
2740 Qnil, Qnil);
2741 Fset_text_properties (make_number (start2), make_number (end2),
2742 Qnil, Qnil);
b229b8d1
RS
2743#endif /* USE_TEXT_PROPERTIES */
2744
ec1c14f6
RS
2745 if (len1_byte > 20000)
2746 temp = (unsigned char *) xmalloc (len1_byte);
3c6bc7d0 2747 else
ec1c14f6
RS
2748 temp = (unsigned char *) alloca (len1_byte);
2749 start1_addr = BUF_CHAR_ADDRESS (current_buffer, start1_byte);
2750 start2_addr = BUF_CHAR_ADDRESS (current_buffer, start2_byte);
2751 bcopy (start1_addr, temp, len1_byte);
2752 bcopy (start2_addr, start1_addr, len2_byte);
2753 bcopy (temp, start2_addr, len1_byte);
2754 if (len1_byte > 20000)
3c6bc7d0 2755 free (temp);
b229b8d1
RS
2756#ifdef USE_TEXT_PROPERTIES
2757 graft_intervals_into_buffer (tmp_interval1, start2,
2758 len1, current_buffer, 0);
2759 graft_intervals_into_buffer (tmp_interval2, start1,
2760 len2, current_buffer, 0);
2761#endif /* USE_TEXT_PROPERTIES */
2762 }
2763
ec1c14f6 2764 else if (len1_byte < len2_byte) /* Second region larger than first */
b229b8d1
RS
2765 /* Non-adjacent & unequal size, area between must also be shifted. */
2766 {
b229b8d1
RS
2767 modify_region (current_buffer, start1, end2);
2768 record_change (start1, (end2 - start1));
2769#ifdef USE_TEXT_PROPERTIES
2770 tmp_interval1 = copy_intervals (cur_intv, start1, len1);
2771 tmp_interval_mid = copy_intervals (cur_intv, end1, len_mid);
2772 tmp_interval2 = copy_intervals (cur_intv, start2, len2);
09dbcf71
RS
2773 Fset_text_properties (make_number (start1), make_number (end2),
2774 Qnil, Qnil);
b229b8d1
RS
2775#endif /* USE_TEXT_PROPERTIES */
2776
3c6bc7d0 2777 /* holds region 2 */
ec1c14f6
RS
2778 if (len2_byte > 20000)
2779 temp = (unsigned char *) xmalloc (len2_byte);
3c6bc7d0 2780 else
ec1c14f6
RS
2781 temp = (unsigned char *) alloca (len2_byte);
2782 start1_addr = BUF_CHAR_ADDRESS (current_buffer, start1_byte);
2783 start2_addr = BUF_CHAR_ADDRESS (current_buffer, start2_byte);
2784 bcopy (start2_addr, temp, len2_byte);
2785 bcopy (start1_addr, start1_addr + len_mid + len2_byte, len1_byte);
2786 safe_bcopy (start1_addr + len1_byte, start1_addr + len2_byte, len_mid);
2787 bcopy (temp, start1_addr, len2_byte);
2788 if (len2_byte > 20000)
3c6bc7d0 2789 free (temp);
b229b8d1
RS
2790#ifdef USE_TEXT_PROPERTIES
2791 graft_intervals_into_buffer (tmp_interval1, end2 - len1,
2792 len1, current_buffer, 0);
2793 graft_intervals_into_buffer (tmp_interval_mid, start1 + len2,
2794 len_mid, current_buffer, 0);
2795 graft_intervals_into_buffer (tmp_interval2, start1,
2796 len2, current_buffer, 0);
2797#endif /* USE_TEXT_PROPERTIES */
2798 }
2799 else
2800 /* Second region smaller than first. */
2801 {
b229b8d1
RS
2802 record_change (start1, (end2 - start1));
2803 modify_region (current_buffer, start1, end2);
2804
2805#ifdef USE_TEXT_PROPERTIES
2806 tmp_interval1 = copy_intervals (cur_intv, start1, len1);
2807 tmp_interval_mid = copy_intervals (cur_intv, end1, len_mid);
2808 tmp_interval2 = copy_intervals (cur_intv, start2, len2);
09dbcf71
RS
2809 Fset_text_properties (make_number (start1), make_number (end2),
2810 Qnil, Qnil);
b229b8d1
RS
2811#endif /* USE_TEXT_PROPERTIES */
2812
3c6bc7d0 2813 /* holds region 1 */
ec1c14f6
RS
2814 if (len1_byte > 20000)
2815 temp = (unsigned char *) xmalloc (len1_byte);
3c6bc7d0 2816 else
ec1c14f6
RS
2817 temp = (unsigned char *) alloca (len1_byte);
2818 start1_addr = BUF_CHAR_ADDRESS (current_buffer, start1_byte);
2819 start2_addr = BUF_CHAR_ADDRESS (current_buffer, start2_byte);
2820 bcopy (start1_addr, temp, len1_byte);
2821 bcopy (start2_addr, start1_addr, len2_byte);
2822 bcopy (start1_addr + len1_byte, start1_addr + len2_byte, len_mid);
2823 bcopy (temp, start1_addr + len2_byte + len_mid, len1_byte);
2824 if (len1_byte > 20000)
3c6bc7d0 2825 free (temp);
b229b8d1
RS
2826#ifdef USE_TEXT_PROPERTIES
2827 graft_intervals_into_buffer (tmp_interval1, end2 - len1,
2828 len1, current_buffer, 0);
2829 graft_intervals_into_buffer (tmp_interval_mid, start1 + len2,
2830 len_mid, current_buffer, 0);
2831 graft_intervals_into_buffer (tmp_interval2, start1,
2832 len2, current_buffer, 0);
2833#endif /* USE_TEXT_PROPERTIES */
2834 }
2835 }
2836
ec1c14f6
RS
2837 /* When doing multiple transpositions, it might be nice
2838 to optimize this. Perhaps the markers in any one buffer
2839 should be organized in some sorted data tree. */
b229b8d1 2840 if (NILP (leave_markers))
8de1d5f0 2841 {
ec1c14f6
RS
2842 transpose_markers (start1, end1, start2, end2,
2843 start1_byte, start1_byte + len1_byte,
2844 start2_byte, start2_byte + len2_byte);
8de1d5f0
KH
2845 fix_overlays_in_range (start1, end2);
2846 }
b229b8d1
RS
2847
2848 return Qnil;
2849}
35692fe0 2850
35692fe0
JB
2851\f
2852void
2853syms_of_editfns ()
2854{
260e2e2a
KH
2855 environbuf = 0;
2856
2857 Qbuffer_access_fontify_functions
2858 = intern ("buffer-access-fontify-functions");
2859 staticpro (&Qbuffer_access_fontify_functions);
2860
2861 DEFVAR_LISP ("buffer-access-fontify-functions",
2862 &Vbuffer_access_fontify_functions,
2863 "List of functions called by `buffer-substring' to fontify if necessary.\n\
2864Each function is called with two arguments which specify the range\n\
2865of the buffer being accessed.");
2866 Vbuffer_access_fontify_functions = Qnil;
2867
af209db8
RS
2868 {
2869 Lisp_Object obuf;
2870 extern Lisp_Object Vprin1_to_string_buffer;
2871 obuf = Fcurrent_buffer ();
2872 /* Do this here, because init_buffer_once is too early--it won't work. */
2873 Fset_buffer (Vprin1_to_string_buffer);
2874 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
2875 Fset (Fmake_local_variable (intern ("buffer-access-fontify-functions")),
2876 Qnil);
2877 Fset_buffer (obuf);
2878 }
2879
0b6fd023 2880 DEFVAR_LISP ("buffer-access-fontified-property",
260e2e2a
KH
2881 &Vbuffer_access_fontified_property,
2882 "Property which (if non-nil) indicates text has been fontified.\n\
2883`buffer-substring' need not call the `buffer-access-fontify-functions'\n\
2884functions if all the text being accessed has this property.");
2885 Vbuffer_access_fontified_property = Qnil;
2886
f43754f6
KH
2887 DEFVAR_LISP ("system-name", &Vsystem_name,
2888 "The name of the machine Emacs is running on.");
2889
2890 DEFVAR_LISP ("user-full-name", &Vuser_full_name,
2891 "The full name of the user logged in.");
2892
35b34f72 2893 DEFVAR_LISP ("user-login-name", &Vuser_login_name,
f43754f6
KH
2894 "The user's name, taken from environment variables if possible.");
2895
35b34f72 2896 DEFVAR_LISP ("user-real-login-name", &Vuser_real_login_name,
f43754f6 2897 "The user's name, based upon the real uid only.");
35692fe0
JB
2898
2899 defsubr (&Schar_equal);
2900 defsubr (&Sgoto_char);
2901 defsubr (&Sstring_to_char);
2902 defsubr (&Schar_to_string);
2903 defsubr (&Sbuffer_substring);
260e2e2a 2904 defsubr (&Sbuffer_substring_no_properties);
35692fe0
JB
2905 defsubr (&Sbuffer_string);
2906
2907 defsubr (&Spoint_marker);
2908 defsubr (&Smark_marker);
2909 defsubr (&Spoint);
2910 defsubr (&Sregion_beginning);
2911 defsubr (&Sregion_end);
7df74da6
RS
2912
2913 defsubr (&Sline_beginning_position);
2914 defsubr (&Sline_end_position);
2915
35692fe0
JB
2916/* defsubr (&Smark); */
2917/* defsubr (&Sset_mark); */
2918 defsubr (&Ssave_excursion);
4bc8c7d2 2919 defsubr (&Ssave_current_buffer);
35692fe0
JB
2920
2921 defsubr (&Sbufsize);
2922 defsubr (&Spoint_max);
2923 defsubr (&Spoint_min);
2924 defsubr (&Spoint_min_marker);
2925 defsubr (&Spoint_max_marker);
7df74da6 2926 defsubr (&Sposition_bytes);
c9ed721d 2927
35692fe0
JB
2928 defsubr (&Sbobp);
2929 defsubr (&Seobp);
2930 defsubr (&Sbolp);
2931 defsubr (&Seolp);
850a8179
JB
2932 defsubr (&Sfollowing_char);
2933 defsubr (&Sprevious_char);
35692fe0 2934 defsubr (&Schar_after);
fb8106e8 2935 defsubr (&Schar_before);
35692fe0
JB
2936 defsubr (&Sinsert);
2937 defsubr (&Sinsert_before_markers);
be91036a
RS
2938 defsubr (&Sinsert_and_inherit);
2939 defsubr (&Sinsert_and_inherit_before_markers);
35692fe0
JB
2940 defsubr (&Sinsert_char);
2941
2942 defsubr (&Suser_login_name);
2943 defsubr (&Suser_real_login_name);
2944 defsubr (&Suser_uid);
2945 defsubr (&Suser_real_uid);
2946 defsubr (&Suser_full_name);
7fd233b3 2947 defsubr (&Semacs_pid);
d940e0e4 2948 defsubr (&Scurrent_time);
a82d387c 2949 defsubr (&Sformat_time_string);
4691c06d 2950 defsubr (&Sdecode_time);
cce7b8a0 2951 defsubr (&Sencode_time);
35692fe0 2952 defsubr (&Scurrent_time_string);
c2662aea 2953 defsubr (&Scurrent_time_zone);
143cb9a9 2954 defsubr (&Sset_time_zone_rule);
35692fe0 2955 defsubr (&Ssystem_name);
35692fe0 2956 defsubr (&Smessage);
cacc3e2c
RS
2957 defsubr (&Smessage_box);
2958 defsubr (&Smessage_or_box);
b14dda8a 2959 defsubr (&Scurrent_message);
35692fe0 2960 defsubr (&Sformat);
35692fe0
JB
2961
2962 defsubr (&Sinsert_buffer_substring);
e9cf2084 2963 defsubr (&Scompare_buffer_substrings);
35692fe0
JB
2964 defsubr (&Ssubst_char_in_region);
2965 defsubr (&Stranslate_region);
2966 defsubr (&Sdelete_region);
2967 defsubr (&Swiden);
2968 defsubr (&Snarrow_to_region);
2969 defsubr (&Ssave_restriction);
b229b8d1 2970 defsubr (&Stranspose_regions);
35692fe0 2971}