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