(Fposition_bytes): Allow marker as arg POSITION. 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)
461{
fa8a5a15
KH
462 CHECK_NUMBER_COERCE_MARKER (position, 1);
463 return make_number (CHAR_TO_BYTE (XINT (position)));
7df74da6
RS
464}
465\f
850a8179
JB
466DEFUN ("following-char", Ffollowing_char, Sfollowing_char, 0, 0, 0,
467 "Return the character following point, as a number.\n\
fb8106e8
KH
468At the end of the buffer or accessible region, return 0.\n\
469If `enable-multibyte-characters' is nil or point is not\n\
470 at character boundary, multibyte form is ignored,\n\
471 and only one byte following point is returned as a character.")
35692fe0
JB
472 ()
473{
474 Lisp_Object temp;
6ec8bbd2 475 if (PT >= ZV)
55561c63 476 XSETFASTINT (temp, 0);
850a8179 477 else
ec1c14f6 478 XSETFASTINT (temp, FETCH_CHAR (PT_BYTE));
35692fe0
JB
479 return temp;
480}
481
850a8179
JB
482DEFUN ("preceding-char", Fprevious_char, Sprevious_char, 0, 0, 0,
483 "Return the character preceding point, as a number.\n\
fb8106e8
KH
484At the beginning of the buffer or accessible region, return 0.\n\
485If `enable-multibyte-characters' is nil or point is not\n\
486 at character boundary, multi-byte form is ignored,\n\
487 and only one byte preceding point is returned as a character.")
35692fe0
JB
488 ()
489{
490 Lisp_Object temp;
6ec8bbd2 491 if (PT <= BEGV)
55561c63 492 XSETFASTINT (temp, 0);
fb8106e8
KH
493 else if (!NILP (current_buffer->enable_multibyte_characters))
494 {
ec1c14f6 495 int pos = PT_BYTE;
fb8106e8
KH
496 DEC_POS (pos);
497 XSETFASTINT (temp, FETCH_CHAR (pos));
498 }
35692fe0 499 else
ec1c14f6 500 XSETFASTINT (temp, FETCH_BYTE (PT_BYTE - 1));
35692fe0
JB
501 return temp;
502}
503
504DEFUN ("bobp", Fbobp, Sbobp, 0, 0, 0,
ec1c14f6 505 "Return t if point is at the beginning of the buffer.\n\
35692fe0
JB
506If the buffer is narrowed, this means the beginning of the narrowed part.")
507 ()
508{
6ec8bbd2 509 if (PT == BEGV)
35692fe0
JB
510 return Qt;
511 return Qnil;
512}
513
514DEFUN ("eobp", Feobp, Seobp, 0, 0, 0,
ec1c14f6 515 "Return t if point is at the end of the buffer.\n\
35692fe0
JB
516If the buffer is narrowed, this means the end of the narrowed part.")
517 ()
518{
6ec8bbd2 519 if (PT == ZV)
35692fe0
JB
520 return Qt;
521 return Qnil;
522}
523
524DEFUN ("bolp", Fbolp, Sbolp, 0, 0, 0,
ec1c14f6 525 "Return t if point is at the beginning of a line.")
35692fe0
JB
526 ()
527{
ec1c14f6 528 if (PT == BEGV || FETCH_BYTE (PT_BYTE - 1) == '\n')
35692fe0
JB
529 return Qt;
530 return Qnil;
531}
532
533DEFUN ("eolp", Feolp, Seolp, 0, 0, 0,
ec1c14f6 534 "Return t if point is at the end of a line.\n\
35692fe0
JB
535`End of a line' includes point being at the end of the buffer.")
536 ()
537{
ec1c14f6 538 if (PT == ZV || FETCH_BYTE (PT_BYTE) == '\n')
35692fe0
JB
539 return Qt;
540 return Qnil;
541}
542
fa1d3816 543DEFUN ("char-after", Fchar_after, Schar_after, 0, 1, 0,
35692fe0
JB
544 "Return character in current buffer at position POS.\n\
545POS is an integer or a buffer pointer.\n\
fb8106e8
KH
546If POS is out of range, the value is nil.\n\
547If `enable-multibyte-characters' is nil or POS is not at character boundary,\n\
548 multi-byte form is ignored, and only one byte at POS\n\
549 is returned as a character.")
35692fe0
JB
550 (pos)
551 Lisp_Object pos;
552{
ec1c14f6 553 register int pos_byte;
35692fe0 554 register Lisp_Object val;
35692fe0 555
fa1d3816 556 if (NILP (pos))
ec1c14f6
RS
557 return make_number (FETCH_CHAR (PT_BYTE));
558
559 if (MARKERP (pos))
560 pos_byte = marker_byte_position (pos);
fa1d3816
RS
561 else
562 {
563 CHECK_NUMBER_COERCE_MARKER (pos, 0);
ec1c14f6
RS
564
565 pos_byte = CHAR_TO_BYTE (XINT (pos));
fa1d3816 566 }
35692fe0 567
9d1af5be 568 if (pos_byte < BEGV_BYTE || pos_byte >= ZV_BYTE)
ec1c14f6
RS
569 return Qnil;
570
571 return make_number (FETCH_CHAR (pos_byte));
35692fe0 572}
fb8106e8 573
fa1d3816 574DEFUN ("char-before", Fchar_before, Schar_before, 0, 1, 0,
fb8106e8
KH
575 "Return character in current buffer preceding position POS.\n\
576POS is an integer or a buffer pointer.\n\
577If POS is out of range, the value is nil.\n\
578If `enable-multibyte-characters' is nil or POS is not at character boundary,\n\
579multi-byte form is ignored, and only one byte preceding POS\n\
580is returned as a character.")
581 (pos)
582 Lisp_Object pos;
583{
584 register Lisp_Object val;
ec1c14f6 585 register int pos_byte;
fb8106e8 586
fa1d3816 587 if (NILP (pos))
ec1c14f6
RS
588 pos_byte = PT_BYTE;
589 else if (MARKERP (pos))
590 pos_byte = marker_byte_position (pos);
fa1d3816
RS
591 else
592 {
593 CHECK_NUMBER_COERCE_MARKER (pos, 0);
fb8106e8 594
ec1c14f6 595 pos_byte = CHAR_TO_BYTE (XINT (pos));
fa1d3816 596 }
fb8106e8 597
ec1c14f6 598 if (pos_byte <= BEGV_BYTE || pos_byte > ZV_BYTE)
20713324
RS
599 return Qnil;
600
fb8106e8
KH
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];
84246b95
KH
1828 pos++;
1829 pos_byte += len;
35692fe0 1830 }
84246b95 1831 INC_BOTH (pos, pos_byte);
35692fe0
JB
1832 }
1833
60b96ee7
RS
1834 if (changed)
1835 signal_after_change (XINT (start),
84246b95 1836 XINT (end) - XINT (start), XINT (end) - XINT (start));
60b96ee7 1837
d5a539cd 1838 unbind_to (count, Qnil);
35692fe0
JB
1839 return Qnil;
1840}
1841
1842DEFUN ("translate-region", Ftranslate_region, Stranslate_region, 3, 3, 0,
1843 "From START to END, translate characters according to TABLE.\n\
1844TABLE is a string; the Nth character in it is the mapping\n\
1f24f4fd
RS
1845for the character with code N.\n\
1846This function does not alter multibyte characters.\n\
1847It returns the number of characters changed.")
35692fe0
JB
1848 (start, end, table)
1849 Lisp_Object start;
1850 Lisp_Object end;
1851 register Lisp_Object table;
1852{
ec1c14f6 1853 register int pos_byte, stop; /* Limits of the region. */
35692fe0 1854 register unsigned char *tt; /* Trans table. */
35692fe0
JB
1855 register int nc; /* New character. */
1856 int cnt; /* Number of changes made. */
35692fe0 1857 int size; /* Size of translate table. */
1f24f4fd 1858 int pos;
35692fe0
JB
1859
1860 validate_region (&start, &end);
1861 CHECK_STRING (table, 2);
1862
1f24f4fd 1863 size = XSTRING (table)->size_byte;
35692fe0
JB
1864 tt = XSTRING (table)->data;
1865
ec1c14f6
RS
1866 pos_byte = CHAR_TO_BYTE (XINT (start));
1867 stop = CHAR_TO_BYTE (XINT (end));
1868 modify_region (current_buffer, XINT (start), XINT (end));
1f24f4fd 1869 pos = XINT (start);
35692fe0
JB
1870
1871 cnt = 0;
1f24f4fd 1872 for (; pos_byte < stop; )
35692fe0 1873 {
ec1c14f6 1874 register unsigned char *p = BYTE_POS_ADDR (pos_byte);
1f24f4fd
RS
1875 int len;
1876 int oc;
ec1c14f6 1877
1f24f4fd
RS
1878 oc = STRING_CHAR_AND_LENGTH (p, stop - pos_byte, len);
1879 if (oc < size && len == 1)
35692fe0
JB
1880 {
1881 nc = tt[oc];
1882 if (nc != oc)
1883 {
1f24f4fd 1884 record_change (pos, 1);
ec1c14f6 1885 *p = nc;
1f24f4fd 1886 signal_after_change (pos, 1, 1);
35692fe0
JB
1887 ++cnt;
1888 }
1889 }
1f24f4fd
RS
1890 pos_byte += len;
1891 pos++;
35692fe0
JB
1892 }
1893
ec1c14f6 1894 return make_number (cnt);
35692fe0
JB
1895}
1896
1897DEFUN ("delete-region", Fdelete_region, Sdelete_region, 2, 2, "r",
1898 "Delete the text between point and mark.\n\
1899When called from a program, expects two arguments,\n\
1900positions (integers or markers) specifying the stretch to be deleted.")
2591ec64
EN
1901 (start, end)
1902 Lisp_Object start, end;
35692fe0 1903{
2591ec64
EN
1904 validate_region (&start, &end);
1905 del_range (XINT (start), XINT (end));
35692fe0
JB
1906 return Qnil;
1907}
1908\f
1909DEFUN ("widen", Fwiden, Swiden, 0, 0, "",
1910 "Remove restrictions (narrowing) from current buffer.\n\
1911This allows the buffer's full text to be seen and edited.")
1912 ()
1913{
2cad2e34
RS
1914 if (BEG != BEGV || Z != ZV)
1915 current_buffer->clip_changed = 1;
35692fe0 1916 BEGV = BEG;
ec1c14f6
RS
1917 BEGV_BYTE = BEG_BYTE;
1918 SET_BUF_ZV_BOTH (current_buffer, Z, Z_BYTE);
52b14ac0
JB
1919 /* Changing the buffer bounds invalidates any recorded current column. */
1920 invalidate_current_column ();
35692fe0
JB
1921 return Qnil;
1922}
1923
1924DEFUN ("narrow-to-region", Fnarrow_to_region, Snarrow_to_region, 2, 2, "r",
1925 "Restrict editing in this buffer to the current region.\n\
1926The rest of the text becomes temporarily invisible and untouchable\n\
1927but is not deleted; if you save the buffer in a file, the invisible\n\
1928text is included in the file. \\[widen] makes all visible again.\n\
1929See also `save-restriction'.\n\
1930\n\
1931When calling from a program, pass two arguments; positions (integers\n\
1932or markers) bounding the text that should remain visible.")
2591ec64
EN
1933 (start, end)
1934 register Lisp_Object start, end;
35692fe0 1935{
2591ec64
EN
1936 CHECK_NUMBER_COERCE_MARKER (start, 0);
1937 CHECK_NUMBER_COERCE_MARKER (end, 1);
35692fe0 1938
2591ec64 1939 if (XINT (start) > XINT (end))
35692fe0 1940 {
b5a6948e 1941 Lisp_Object tem;
2591ec64 1942 tem = start; start = end; end = tem;
35692fe0
JB
1943 }
1944
2591ec64
EN
1945 if (!(BEG <= XINT (start) && XINT (start) <= XINT (end) && XINT (end) <= Z))
1946 args_out_of_range (start, end);
35692fe0 1947
2cad2e34
RS
1948 if (BEGV != XFASTINT (start) || ZV != XFASTINT (end))
1949 current_buffer->clip_changed = 1;
1950
ec1c14f6 1951 SET_BUF_BEGV (current_buffer, XFASTINT (start));
2591ec64 1952 SET_BUF_ZV (current_buffer, XFASTINT (end));
6ec8bbd2 1953 if (PT < XFASTINT (start))
2591ec64 1954 SET_PT (XFASTINT (start));
6ec8bbd2 1955 if (PT > XFASTINT (end))
2591ec64 1956 SET_PT (XFASTINT (end));
52b14ac0
JB
1957 /* Changing the buffer bounds invalidates any recorded current column. */
1958 invalidate_current_column ();
35692fe0
JB
1959 return Qnil;
1960}
1961
1962Lisp_Object
1963save_restriction_save ()
1964{
1965 register Lisp_Object bottom, top;
1966 /* Note: I tried using markers here, but it does not win
1967 because insertion at the end of the saved region
1968 does not advance mh and is considered "outside" the saved region. */
55561c63
KH
1969 XSETFASTINT (bottom, BEGV - BEG);
1970 XSETFASTINT (top, Z - ZV);
35692fe0
JB
1971
1972 return Fcons (Fcurrent_buffer (), Fcons (bottom, top));
1973}
1974
1975Lisp_Object
1976save_restriction_restore (data)
1977 Lisp_Object data;
1978{
1979 register struct buffer *buf;
1980 register int newhead, newtail;
1981 register Lisp_Object tem;
2cad2e34 1982 int obegv, ozv;
35692fe0
JB
1983
1984 buf = XBUFFER (XCONS (data)->car);
1985
1986 data = XCONS (data)->cdr;
1987
1988 tem = XCONS (data)->car;
1989 newhead = XINT (tem);
1990 tem = XCONS (data)->cdr;
1991 newtail = XINT (tem);
1992 if (newhead + newtail > BUF_Z (buf) - BUF_BEG (buf))
1993 {
1994 newhead = 0;
1995 newtail = 0;
1996 }
2cad2e34
RS
1997
1998 obegv = BUF_BEGV (buf);
1999 ozv = BUF_ZV (buf);
2000
ec1c14f6 2001 SET_BUF_BEGV (buf, BUF_BEG (buf) + newhead);
35692fe0 2002 SET_BUF_ZV (buf, BUF_Z (buf) - newtail);
2cad2e34
RS
2003
2004 if (obegv != BUF_BEGV (buf) || ozv != BUF_ZV (buf))
2005 current_buffer->clip_changed = 1;
35692fe0
JB
2006
2007 /* If point is outside the new visible range, move it inside. */
ec1c14f6
RS
2008 SET_BUF_PT_BOTH (buf,
2009 clip_to_bounds (BUF_BEGV (buf), BUF_PT (buf), BUF_ZV (buf)),
2010 clip_to_bounds (BUF_BEGV_BYTE (buf), BUF_PT_BYTE (buf),
2011 BUF_ZV_BYTE (buf)));
35692fe0
JB
2012
2013 return Qnil;
2014}
2015
2016DEFUN ("save-restriction", Fsave_restriction, Ssave_restriction, 0, UNEVALLED, 0,
2017 "Execute BODY, saving and restoring current buffer's restrictions.\n\
2018The buffer's restrictions make parts of the beginning and end invisible.\n\
2019\(They are set up with `narrow-to-region' and eliminated with `widen'.)\n\
2020This special form, `save-restriction', saves the current buffer's restrictions\n\
2021when it is entered, and restores them when it is exited.\n\
2022So any `narrow-to-region' within BODY lasts only until the end of the form.\n\
2023The old restrictions settings are restored\n\
2024even in case of abnormal exit (throw or error).\n\
2025\n\
2026The value returned is the value of the last form in BODY.\n\
2027\n\
2028`save-restriction' can get confused if, within the BODY, you widen\n\
2029and then make changes outside the area within the saved restrictions.\n\
2030\n\
2031Note: if you are using both `save-excursion' and `save-restriction',\n\
2032use `save-excursion' outermost:\n\
2033 (save-excursion (save-restriction ...))")
2034 (body)
2035 Lisp_Object body;
2036{
2037 register Lisp_Object val;
2038 int count = specpdl_ptr - specpdl;
2039
2040 record_unwind_protect (save_restriction_restore, save_restriction_save ());
2041 val = Fprogn (body);
2042 return unbind_to (count, val);
2043}
2044\f
671fbc4d
KH
2045/* Buffer for the most recent text displayed by Fmessage. */
2046static char *message_text;
2047
2048/* Allocated length of that buffer. */
2049static int message_length;
2050
35692fe0
JB
2051DEFUN ("message", Fmessage, Smessage, 1, MANY, 0,
2052 "Print a one-line message at the bottom of the screen.\n\
98fc5c3c
RS
2053The first argument is a format control string, and the rest are data\n\
2054to be formatted under control of the string. See `format' for details.\n\
2055\n\
ccdac5be
JB
2056If the first argument is nil, clear any existing message; let the\n\
2057minibuffer contents show.")
35692fe0
JB
2058 (nargs, args)
2059 int nargs;
2060 Lisp_Object *args;
2061{
ccdac5be 2062 if (NILP (args[0]))
f0250249
JB
2063 {
2064 message (0);
2065 return Qnil;
2066 }
ccdac5be
JB
2067 else
2068 {
2069 register Lisp_Object val;
2070 val = Fformat (nargs, args);
671fbc4d
KH
2071 /* Copy the data so that it won't move when we GC. */
2072 if (! message_text)
2073 {
2074 message_text = (char *)xmalloc (80);
2075 message_length = 80;
2076 }
2077 if (XSTRING (val)->size > message_length)
2078 {
1f24f4fd 2079 message_length = XSTRING (val)->size_byte;
671fbc4d
KH
2080 message_text = (char *)xrealloc (message_text, message_length);
2081 }
1f24f4fd
RS
2082 bcopy (XSTRING (val)->data, message_text, XSTRING (val)->size_byte);
2083 message2 (message_text, XSTRING (val)->size_byte,
2084 STRING_MULTIBYTE (val));
ccdac5be
JB
2085 return val;
2086 }
35692fe0
JB
2087}
2088
cacc3e2c
RS
2089DEFUN ("message-box", Fmessage_box, Smessage_box, 1, MANY, 0,
2090 "Display a message, in a dialog box if possible.\n\
2091If a dialog box is not available, use the echo area.\n\
f8250f01
RS
2092The first argument is a format control string, and the rest are data\n\
2093to be formatted under control of the string. See `format' for details.\n\
2094\n\
cacc3e2c
RS
2095If the first argument is nil, clear any existing message; let the\n\
2096minibuffer contents show.")
2097 (nargs, args)
2098 int nargs;
2099 Lisp_Object *args;
2100{
2101 if (NILP (args[0]))
2102 {
2103 message (0);
2104 return Qnil;
2105 }
2106 else
2107 {
2108 register Lisp_Object val;
2109 val = Fformat (nargs, args);
f8250f01 2110#ifdef HAVE_MENUS
cacc3e2c
RS
2111 {
2112 Lisp_Object pane, menu, obj;
2113 struct gcpro gcpro1;
2114 pane = Fcons (Fcons (build_string ("OK"), Qt), Qnil);
2115 GCPRO1 (pane);
2116 menu = Fcons (val, pane);
2117 obj = Fx_popup_dialog (Qt, menu);
2118 UNGCPRO;
2119 return val;
2120 }
f8250f01 2121#else /* not HAVE_MENUS */
cacc3e2c
RS
2122 /* Copy the data so that it won't move when we GC. */
2123 if (! message_text)
2124 {
2125 message_text = (char *)xmalloc (80);
2126 message_length = 80;
2127 }
1f24f4fd 2128 if (XSTRING (val)->size_byte > message_length)
cacc3e2c 2129 {
1f24f4fd 2130 message_length = XSTRING (val)->size_byte;
cacc3e2c
RS
2131 message_text = (char *)xrealloc (message_text, message_length);
2132 }
1f24f4fd
RS
2133 bcopy (XSTRING (val)->data, message_text, XSTRING (val)->size_byte);
2134 message2 (message_text, XSTRING (val)->size_byte);
cacc3e2c 2135 return val;
f8250f01 2136#endif /* not HAVE_MENUS */
cacc3e2c
RS
2137 }
2138}
f8250f01 2139#ifdef HAVE_MENUS
cacc3e2c
RS
2140extern Lisp_Object last_nonmenu_event;
2141#endif
f8250f01 2142
cacc3e2c
RS
2143DEFUN ("message-or-box", Fmessage_or_box, Smessage_or_box, 1, MANY, 0,
2144 "Display a message in a dialog box or in the echo area.\n\
2145If this command was invoked with the mouse, use a dialog box.\n\
2146Otherwise, use the echo area.\n\
f8250f01
RS
2147The first argument is a format control string, and the rest are data\n\
2148to be formatted under control of the string. See `format' for details.\n\
cacc3e2c 2149\n\
cacc3e2c
RS
2150If the first argument is nil, clear any existing message; let the\n\
2151minibuffer contents show.")
2152 (nargs, args)
2153 int nargs;
2154 Lisp_Object *args;
2155{
f8250f01 2156#ifdef HAVE_MENUS
cacc3e2c 2157 if (NILP (last_nonmenu_event) || CONSP (last_nonmenu_event))
0a56ee6b 2158 return Fmessage_box (nargs, args);
cacc3e2c
RS
2159#endif
2160 return Fmessage (nargs, args);
2161}
2162
b14dda8a
RS
2163DEFUN ("current-message", Fcurrent_message, Scurrent_message, 0, 0, 0,
2164 "Return the string currently displayed in the echo area, or nil if none.")
2165 ()
2166{
2167 return (echo_area_glyphs
2168 ? make_string (echo_area_glyphs, echo_area_glyphs_length)
2169 : Qnil);
2170}
2171
1f24f4fd
RS
2172/* Number of bytes that STRING will occupy when put into the result.
2173 MULTIBYTE is nonzero if the result should be multibyte. */
2174
2175#define CONVERTED_BYTE_SIZE(MULTIBYTE, STRING) \
2176 (((MULTIBYTE) && ! STRING_MULTIBYTE (STRING)) \
8d6179dc
KH
2177 ? count_size_as_multibyte (XSTRING (STRING)->data, \
2178 XSTRING (STRING)->size_byte) \
2179 : XSTRING (STRING)->size_byte)
1f24f4fd 2180
35692fe0
JB
2181DEFUN ("format", Fformat, Sformat, 1, MANY, 0,
2182 "Format a string out of a control-string and arguments.\n\
2183The first argument is a control string.\n\
2184The other arguments are substituted into it to make the result, a string.\n\
2185It may contain %-sequences meaning to substitute the next argument.\n\
2186%s means print a string argument. Actually, prints any object, with `princ'.\n\
2187%d means print as number in decimal (%o octal, %x hex).\n\
9db1775a
RS
2188%e means print a number in exponential notation.\n\
2189%f means print a number in decimal-point notation.\n\
2190%g means print a number in exponential notation\n\
2191 or decimal-point notation, whichever uses fewer characters.\n\
35692fe0
JB
2192%c means print a number as a single character.\n\
2193%S means print any object as an s-expression (using prin1).\n\
9db1775a 2194 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.\n\
52b14ac0 2195Use %% to put a single % into the output.")
35692fe0
JB
2196 (nargs, args)
2197 int nargs;
2198 register Lisp_Object *args;
2199{
2200 register int n; /* The number of the next arg to substitute */
e781c49e 2201 register int total; /* An estimate of the final length */
1f24f4fd 2202 char *buf, *p;
35692fe0 2203 register unsigned char *format, *end;
1f24f4fd
RS
2204 int length, nchars;
2205 /* Nonzero if the output should be a multibyte string,
2206 which is true if any of the inputs is one. */
2207 int multibyte = 0;
2208 unsigned char *this_format;
e781c49e 2209 int longest_format;
8d6179dc 2210 Lisp_Object val;
1f24f4fd 2211
35692fe0 2212 extern char *index ();
1f24f4fd 2213
35692fe0
JB
2214 /* It should not be necessary to GCPRO ARGS, because
2215 the caller in the interpreter should take care of that. */
2216
e781c49e
RS
2217 /* Try to determine whether the result should be multibyte.
2218 This is not always right; sometimes the result needs to be multibyte
2219 because of an object that we will pass through prin1,
2220 and in that case, we won't know it here. */
1f24f4fd
RS
2221 for (n = 0; n < nargs; n++)
2222 if (STRINGP (args[n]) && STRING_MULTIBYTE (args[n]))
2223 multibyte = 1;
2224
35692fe0 2225 CHECK_STRING (args[0], 0);
e781c49e
RS
2226
2227 /* If we start out planning a unibyte result,
2228 and later find it has to be multibyte, we jump back to retry. */
2229 retry:
2230
35692fe0 2231 format = XSTRING (args[0])->data;
1f24f4fd 2232 end = format + XSTRING (args[0])->size_byte;
e781c49e 2233 longest_format = 0;
1f24f4fd
RS
2234
2235 /* Make room in result for all the non-%-codes in the control string. */
e781c49e 2236 total = 5 + CONVERTED_BYTE_SIZE (multibyte, args[0]);
1f24f4fd
RS
2237
2238 /* Add to TOTAL enough space to hold the converted arguments. */
35692fe0
JB
2239
2240 n = 0;
2241 while (format != end)
2242 if (*format++ == '%')
2243 {
1f24f4fd
RS
2244 int minlen, thissize = 0;
2245 unsigned char *this_format_start = format - 1;
35692fe0
JB
2246
2247 /* Process a numeric arg and skip it. */
2248 minlen = atoi (format);
537dfb13
RS
2249 if (minlen < 0)
2250 minlen = - minlen;
2251
35692fe0
JB
2252 while ((*format >= '0' && *format <= '9')
2253 || *format == '-' || *format == ' ' || *format == '.')
2254 format++;
2255
1f24f4fd
RS
2256 if (format - this_format_start + 1 > longest_format)
2257 longest_format = format - this_format_start + 1;
2258
35692fe0
JB
2259 if (*format == '%')
2260 format++;
2261 else if (++n >= nargs)
537dfb13 2262 error ("Not enough arguments for format string");
35692fe0
JB
2263 else if (*format == 'S')
2264 {
2265 /* For `S', prin1 the argument and then treat like a string. */
2266 register Lisp_Object tem;
2267 tem = Fprin1_to_string (args[n], Qnil);
e781c49e
RS
2268 if (STRING_MULTIBYTE (tem) && ! multibyte)
2269 {
2270 multibyte = 1;
2271 goto retry;
2272 }
35692fe0
JB
2273 args[n] = tem;
2274 goto string;
2275 }
ae683129 2276 else if (SYMBOLP (args[n]))
35692fe0 2277 {
d2fd0445 2278 XSETSTRING (args[n], XSYMBOL (args[n])->name);
7df74da6
RS
2279 if (STRING_MULTIBYTE (args[n]) && ! multibyte)
2280 {
2281 multibyte = 1;
2282 goto retry;
2283 }
35692fe0
JB
2284 goto string;
2285 }
ae683129 2286 else if (STRINGP (args[n]))
35692fe0
JB
2287 {
2288 string:
b22e7ecc
KH
2289 if (*format != 's' && *format != 'S')
2290 error ("format specifier doesn't match argument type");
1f24f4fd 2291 thissize = CONVERTED_BYTE_SIZE (multibyte, args[n]);
35692fe0
JB
2292 }
2293 /* Would get MPV otherwise, since Lisp_Int's `point' to low memory. */
ae683129 2294 else if (INTEGERP (args[n]) && *format != 's')
35692fe0 2295 {
4746118a 2296#ifdef LISP_FLOAT_TYPE
eb8c3be9 2297 /* The following loop assumes the Lisp type indicates
35692fe0
JB
2298 the proper way to pass the argument.
2299 So make sure we have a flonum if the argument should
2300 be a double. */
2301 if (*format == 'e' || *format == 'f' || *format == 'g')
2302 args[n] = Ffloat (args[n]);
4746118a 2303#endif
1f24f4fd 2304 thissize = 30;
35692fe0 2305 }
4746118a 2306#ifdef LISP_FLOAT_TYPE
ae683129 2307 else if (FLOATP (args[n]) && *format != 's')
35692fe0
JB
2308 {
2309 if (! (*format == 'e' || *format == 'f' || *format == 'g'))
247422ce 2310 args[n] = Ftruncate (args[n], Qnil);
1f24f4fd 2311 thissize = 60;
35692fe0 2312 }
4746118a 2313#endif
35692fe0
JB
2314 else
2315 {
2316 /* Anything but a string, convert to a string using princ. */
2317 register Lisp_Object tem;
2318 tem = Fprin1_to_string (args[n], Qt);
8d6179dc 2319 if (STRING_MULTIBYTE (tem))
e781c49e
RS
2320 {
2321 multibyte = 1;
2322 goto retry;
2323 }
35692fe0
JB
2324 args[n] = tem;
2325 goto string;
2326 }
1f24f4fd
RS
2327
2328 if (thissize < minlen)
2329 thissize = minlen;
2330
2331 total += thissize + 4;
35692fe0
JB
2332 }
2333
e781c49e
RS
2334 /* Now we can no longer jump to retry.
2335 TOTAL and LONGEST_FORMAT are known for certain. */
2336
1f24f4fd 2337 this_format = (unsigned char *) alloca (longest_format + 1);
50aa2f90 2338
1f24f4fd
RS
2339 /* Allocate the space for the result.
2340 Note that TOTAL is an overestimate. */
2341 if (total < 1000)
2342 buf = (unsigned char *) alloca (total + 1);
2343 else
2344 buf = (unsigned char *) xmalloc (total + 1);
35692fe0 2345
1f24f4fd
RS
2346 p = buf;
2347 nchars = 0;
2348 n = 0;
35692fe0 2349
1f24f4fd
RS
2350 /* Scan the format and store result in BUF. */
2351 format = XSTRING (args[0])->data;
2352 while (format != end)
2353 {
2354 if (*format == '%')
2355 {
2356 int minlen;
2357 unsigned char *this_format_start = format;
35692fe0 2358
1f24f4fd 2359 format++;
fb893977 2360
1f24f4fd
RS
2361 /* Process a numeric arg and skip it. */
2362 minlen = atoi (format);
2363 if (minlen < 0)
2364 minlen = - minlen;
35692fe0 2365
1f24f4fd
RS
2366 while ((*format >= '0' && *format <= '9')
2367 || *format == '-' || *format == ' ' || *format == '.')
2368 format++;
35692fe0 2369
1f24f4fd
RS
2370 if (*format++ == '%')
2371 {
2372 *p++ = '%';
2373 nchars++;
2374 continue;
2375 }
2376
2377 ++n;
2378
2379 if (STRINGP (args[n]))
2380 {
2381 int padding, nbytes;
2382
2383 nbytes = copy_text (XSTRING (args[n])->data, p,
2384 XSTRING (args[n])->size_byte,
2385 STRING_MULTIBYTE (args[n]), multibyte);
2386 p += nbytes;
2387 nchars += XSTRING (args[n])->size;
2388
2389 /* If spec requires it, pad on right with spaces. */
2390 padding = minlen - XSTRING (args[n])->size;
2391 while (padding-- > 0)
2392 {
2393 *p++ = ' ';
2394 nchars++;
2395 }
2396 }
2397 else if (INTEGERP (args[n]) || FLOATP (args[n]))
2398 {
2399 int this_nchars;
2400
2401 bcopy (this_format_start, this_format,
2402 format - this_format_start);
2403 this_format[format - this_format_start] = 0;
2404
2405 sprintf (p, this_format, XINT (args[n]));
2406
2407 this_nchars = strlen (p);
2408 p += this_nchars;
2409 nchars += this_nchars;
2410 }
2411 }
7df74da6
RS
2412 else if (STRING_MULTIBYTE (args[0]))
2413 {
2414 /* Copy a whole multibyte character. */
2415 *p++ = *format++;
2416 while (! CHAR_HEAD_P (*format)) *p++ = *format++;
2417 nchars++;
2418 }
2419 else if (multibyte)
1f24f4fd
RS
2420 {
2421 /* Convert a single-byte character to multibyte. */
2422 int len = copy_text (format, p, 1, 0, 1);
2423
2424 p += len;
2425 format++;
2426 nchars++;
2427 }
2428 else
2429 *p++ = *format++, nchars++;
2430 }
2431
8d6179dc
KH
2432 val = make_multibyte_string (buf, nchars, p - buf);
2433
1f24f4fd
RS
2434 /* If we allocated BUF with malloc, free it too. */
2435 if (total >= 1000)
2436 xfree (buf);
35692fe0 2437
8d6179dc 2438 return val;
35692fe0
JB
2439}
2440
2441/* VARARGS 1 */
2442Lisp_Object
2443#ifdef NO_ARG_ARRAY
2444format1 (string1, arg0, arg1, arg2, arg3, arg4)
679e18b1 2445 EMACS_INT arg0, arg1, arg2, arg3, arg4;
35692fe0
JB
2446#else
2447format1 (string1)
2448#endif
2449 char *string1;
2450{
2451 char buf[100];
2452#ifdef NO_ARG_ARRAY
679e18b1 2453 EMACS_INT args[5];
35692fe0
JB
2454 args[0] = arg0;
2455 args[1] = arg1;
2456 args[2] = arg2;
2457 args[3] = arg3;
2458 args[4] = arg4;
ea4d2909 2459 doprnt (buf, sizeof buf, string1, (char *)0, 5, args);
35692fe0 2460#else
ea4d2909 2461 doprnt (buf, sizeof buf, string1, (char *)0, 5, &string1 + 1);
35692fe0
JB
2462#endif
2463 return build_string (buf);
2464}
2465\f
2466DEFUN ("char-equal", Fchar_equal, Schar_equal, 2, 2, 0,
2467 "Return t if two characters match, optionally ignoring case.\n\
2468Both arguments must be characters (i.e. integers).\n\
2469Case is ignored if `case-fold-search' is non-nil in the current buffer.")
2470 (c1, c2)
2471 register Lisp_Object c1, c2;
2472{
1b5d98bb 2473 int i1, i2;
35692fe0
JB
2474 CHECK_NUMBER (c1, 0);
2475 CHECK_NUMBER (c2, 1);
2476
1b5d98bb 2477 if (XINT (c1) == XINT (c2))
35692fe0 2478 return Qt;
1b5d98bb
RS
2479 if (NILP (current_buffer->case_fold_search))
2480 return Qnil;
2481
2482 /* Do these in separate statements,
2483 then compare the variables.
2484 because of the way DOWNCASE uses temp variables. */
2485 i1 = DOWNCASE (XFASTINT (c1));
2486 i2 = DOWNCASE (XFASTINT (c2));
2487 return (i1 == i2 ? Qt : Qnil);
35692fe0 2488}
b229b8d1
RS
2489\f
2490/* Transpose the markers in two regions of the current buffer, and
2491 adjust the ones between them if necessary (i.e.: if the regions
2492 differ in size).
2493
ec1c14f6
RS
2494 START1, END1 are the character positions of the first region.
2495 START1_BYTE, END1_BYTE are the byte positions.
2496 START2, END2 are the character positions of the second region.
2497 START2_BYTE, END2_BYTE are the byte positions.
2498
b229b8d1
RS
2499 Traverses the entire marker list of the buffer to do so, adding an
2500 appropriate amount to some, subtracting from some, and leaving the
2501 rest untouched. Most of this is copied from adjust_markers in insdel.c.
2502
ec1c14f6 2503 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
b229b8d1
RS
2504
2505void
ec1c14f6
RS
2506transpose_markers (start1, end1, start2, end2,
2507 start1_byte, end1_byte, start2_byte, end2_byte)
b229b8d1 2508 register int start1, end1, start2, end2;
ec1c14f6 2509 register int start1_byte, end1_byte, start2_byte, end2_byte;
b229b8d1 2510{
ec1c14f6 2511 register int amt1, amt1_byte, amt2, amt2_byte, diff, diff_byte, mpos;
b229b8d1 2512 register Lisp_Object marker;
b229b8d1 2513
03240d11 2514 /* Update point as if it were a marker. */
8de1d5f0
KH
2515 if (PT < start1)
2516 ;
2517 else if (PT < end1)
ec1c14f6
RS
2518 TEMP_SET_PT_BOTH (PT + (end2 - end1),
2519 PT_BYTE + (end2_byte - end1_byte));
8de1d5f0 2520 else if (PT < start2)
ec1c14f6
RS
2521 TEMP_SET_PT_BOTH (PT + (end2 - start2) - (end1 - start1),
2522 (PT_BYTE + (end2_byte - start2_byte)
2523 - (end1_byte - start1_byte)));
8de1d5f0 2524 else if (PT < end2)
ec1c14f6
RS
2525 TEMP_SET_PT_BOTH (PT - (start2 - start1),
2526 PT_BYTE - (start2_byte - start1_byte));
8de1d5f0 2527
03240d11
KH
2528 /* We used to adjust the endpoints here to account for the gap, but that
2529 isn't good enough. Even if we assume the caller has tried to move the
2530 gap out of our way, it might still be at start1 exactly, for example;
2531 and that places it `inside' the interval, for our purposes. The amount
2532 of adjustment is nontrivial if there's a `denormalized' marker whose
2533 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
2534 the dirty work to Fmarker_position, below. */
b229b8d1
RS
2535
2536 /* The difference between the region's lengths */
2537 diff = (end2 - start2) - (end1 - start1);
ec1c14f6 2538 diff_byte = (end2_byte - start2_byte) - (end1_byte - start1_byte);
b229b8d1
RS
2539
2540 /* For shifting each marker in a region by the length of the other
ec1c14f6 2541 region plus the distance between the regions. */
b229b8d1
RS
2542 amt1 = (end2 - start2) + (start2 - end1);
2543 amt2 = (end1 - start1) + (start2 - end1);
ec1c14f6
RS
2544 amt1_byte = (end2_byte - start2_byte) + (start2_byte - end1_byte);
2545 amt2_byte = (end1_byte - start1_byte) + (start2_byte - end1_byte);
b229b8d1 2546
1e158d25 2547 for (marker = BUF_MARKERS (current_buffer); !NILP (marker);
03240d11 2548 marker = XMARKER (marker)->chain)
b229b8d1 2549 {
ec1c14f6
RS
2550 mpos = marker_byte_position (marker);
2551 if (mpos >= start1_byte && mpos < end2_byte)
2552 {
2553 if (mpos < end1_byte)
2554 mpos += amt1_byte;
2555 else if (mpos < start2_byte)
2556 mpos += diff_byte;
2557 else
2558 mpos -= amt2_byte;
f3e1f752 2559 XMARKER (marker)->bytepos = mpos;
ec1c14f6
RS
2560 }
2561 mpos = XMARKER (marker)->charpos;
03240d11
KH
2562 if (mpos >= start1 && mpos < end2)
2563 {
2564 if (mpos < end1)
2565 mpos += amt1;
2566 else if (mpos < start2)
2567 mpos += diff;
2568 else
2569 mpos -= amt2;
03240d11 2570 }
ec1c14f6 2571 XMARKER (marker)->charpos = mpos;
b229b8d1
RS
2572 }
2573}
2574
2575DEFUN ("transpose-regions", Ftranspose_regions, Stranspose_regions, 4, 5, 0,
2576 "Transpose region START1 to END1 with START2 to END2.\n\
2577The regions may not be overlapping, because the size of the buffer is\n\
2578never changed in a transposition.\n\
2579\n\
ec1c14f6 2580Optional fifth arg LEAVE_MARKERS, if non-nil, means don't update\n\
b229b8d1
RS
2581any markers that happen to be located in the regions.\n\
2582\n\
2583Transposing beyond buffer boundaries is an error.")
2584 (startr1, endr1, startr2, endr2, leave_markers)
2585 Lisp_Object startr1, endr1, startr2, endr2, leave_markers;
2586{
ec1c14f6
RS
2587 register int start1, end1, start2, end2;
2588 int start1_byte, start2_byte, len1_byte, len2_byte;
2589 int gap, len1, len_mid, len2;
3c6bc7d0 2590 unsigned char *start1_addr, *start2_addr, *temp;
b229b8d1
RS
2591
2592#ifdef USE_TEXT_PROPERTIES
2593 INTERVAL cur_intv, tmp_interval1, tmp_interval_mid, tmp_interval2;
1e158d25 2594 cur_intv = BUF_INTERVALS (current_buffer);
b229b8d1
RS
2595#endif /* USE_TEXT_PROPERTIES */
2596
2597 validate_region (&startr1, &endr1);
2598 validate_region (&startr2, &endr2);
2599
2600 start1 = XFASTINT (startr1);
2601 end1 = XFASTINT (endr1);
2602 start2 = XFASTINT (startr2);
2603 end2 = XFASTINT (endr2);
2604 gap = GPT;
2605
2606 /* Swap the regions if they're reversed. */
2607 if (start2 < end1)
2608 {
2609 register int glumph = start1;
2610 start1 = start2;
2611 start2 = glumph;
2612 glumph = end1;
2613 end1 = end2;
2614 end2 = glumph;
2615 }
2616
b229b8d1
RS
2617 len1 = end1 - start1;
2618 len2 = end2 - start2;
2619
2620 if (start2 < end1)
ec1c14f6 2621 error ("Transposed regions not properly ordered");
b229b8d1 2622 else if (start1 == end1 || start2 == end2)
ec1c14f6 2623 error ("Transposed region may not be of length 0");
b229b8d1
RS
2624
2625 /* The possibilities are:
2626 1. Adjacent (contiguous) regions, or separate but equal regions
2627 (no, really equal, in this case!), or
2628 2. Separate regions of unequal size.
2629
2630 The worst case is usually No. 2. It means that (aside from
2631 potential need for getting the gap out of the way), there also
2632 needs to be a shifting of the text between the two regions. So
2633 if they are spread far apart, we are that much slower... sigh. */
2634
2635 /* It must be pointed out that the really studly thing to do would
2636 be not to move the gap at all, but to leave it in place and work
2637 around it if necessary. This would be extremely efficient,
2638 especially considering that people are likely to do
2639 transpositions near where they are working interactively, which
2640 is exactly where the gap would be found. However, such code
2641 would be much harder to write and to read. So, if you are
2642 reading this comment and are feeling squirrely, by all means have
2643 a go! I just didn't feel like doing it, so I will simply move
2644 the gap the minimum distance to get it out of the way, and then
2645 deal with an unbroken array. */
3c6bc7d0
RS
2646
2647 /* Make sure the gap won't interfere, by moving it out of the text
2648 we will operate on. */
2649 if (start1 < gap && gap < end2)
2650 {
2651 if (gap - start1 < end2 - gap)
2652 move_gap (start1);
2653 else
2654 move_gap (end2);
2655 }
ec1c14f6
RS
2656
2657 start1_byte = CHAR_TO_BYTE (start1);
2658 start2_byte = CHAR_TO_BYTE (start2);
2659 len1_byte = CHAR_TO_BYTE (end1) - start1_byte;
2660 len2_byte = CHAR_TO_BYTE (end2) - start2_byte;
b229b8d1
RS
2661
2662 /* Hmmm... how about checking to see if the gap is large
2663 enough to use as the temporary storage? That would avoid an
2664 allocation... interesting. Later, don't fool with it now. */
2665
2666 /* Working without memmove, for portability (sigh), so must be
2667 careful of overlapping subsections of the array... */
2668
2669 if (end1 == start2) /* adjacent regions */
2670 {
b229b8d1
RS
2671 modify_region (current_buffer, start1, end2);
2672 record_change (start1, len1 + len2);
2673
2674#ifdef USE_TEXT_PROPERTIES
2675 tmp_interval1 = copy_intervals (cur_intv, start1, len1);
2676 tmp_interval2 = copy_intervals (cur_intv, start2, len2);
09dbcf71
RS
2677 Fset_text_properties (make_number (start1), make_number (end2),
2678 Qnil, Qnil);
b229b8d1
RS
2679#endif /* USE_TEXT_PROPERTIES */
2680
2681 /* First region smaller than second. */
ec1c14f6 2682 if (len1_byte < len2_byte)
b229b8d1 2683 {
3c6bc7d0
RS
2684 /* We use alloca only if it is small,
2685 because we want to avoid stack overflow. */
ec1c14f6
RS
2686 if (len2_byte > 20000)
2687 temp = (unsigned char *) xmalloc (len2_byte);
3c6bc7d0 2688 else
ec1c14f6 2689 temp = (unsigned char *) alloca (len2_byte);
03240d11
KH
2690
2691 /* Don't precompute these addresses. We have to compute them
2692 at the last minute, because the relocating allocator might
2693 have moved the buffer around during the xmalloc. */
ec1c14f6
RS
2694 start1_addr = BUF_CHAR_ADDRESS (current_buffer, start1_byte);
2695 start2_addr = BUF_CHAR_ADDRESS (current_buffer, start2_byte);
03240d11 2696
ec1c14f6
RS
2697 bcopy (start2_addr, temp, len2_byte);
2698 bcopy (start1_addr, start1_addr + len2_byte, len1_byte);
2699 bcopy (temp, start1_addr, len2_byte);
2700 if (len2_byte > 20000)
3c6bc7d0 2701 free (temp);
b229b8d1
RS
2702 }
2703 else
2704 /* First region not smaller than second. */
2705 {
ec1c14f6
RS
2706 if (len1_byte > 20000)
2707 temp = (unsigned char *) xmalloc (len1_byte);
3c6bc7d0 2708 else
ec1c14f6
RS
2709 temp = (unsigned char *) alloca (len1_byte);
2710 start1_addr = BUF_CHAR_ADDRESS (current_buffer, start1_byte);
2711 start2_addr = BUF_CHAR_ADDRESS (current_buffer, start2_byte);
2712 bcopy (start1_addr, temp, len1_byte);
2713 bcopy (start2_addr, start1_addr, len2_byte);
2714 bcopy (temp, start1_addr + len2_byte, len1_byte);
2715 if (len1_byte > 20000)
3c6bc7d0 2716 free (temp);
b229b8d1
RS
2717 }
2718#ifdef USE_TEXT_PROPERTIES
2719 graft_intervals_into_buffer (tmp_interval1, start1 + len2,
2720 len1, current_buffer, 0);
2721 graft_intervals_into_buffer (tmp_interval2, start1,
2722 len2, current_buffer, 0);
2723#endif /* USE_TEXT_PROPERTIES */
2724 }
2725 /* Non-adjacent regions, because end1 != start2, bleagh... */
2726 else
2727 {
ec1c14f6
RS
2728 len_mid = start2_byte - (start1_byte + len1_byte);
2729
2730 if (len1_byte == len2_byte)
b229b8d1
RS
2731 /* Regions are same size, though, how nice. */
2732 {
2733 modify_region (current_buffer, start1, end1);
2734 modify_region (current_buffer, start2, end2);
2735 record_change (start1, len1);
2736 record_change (start2, len2);
2737#ifdef USE_TEXT_PROPERTIES
2738 tmp_interval1 = copy_intervals (cur_intv, start1, len1);
2739 tmp_interval2 = copy_intervals (cur_intv, start2, len2);
09dbcf71
RS
2740 Fset_text_properties (make_number (start1), make_number (end1),
2741 Qnil, Qnil);
2742 Fset_text_properties (make_number (start2), make_number (end2),
2743 Qnil, Qnil);
b229b8d1
RS
2744#endif /* USE_TEXT_PROPERTIES */
2745
ec1c14f6
RS
2746 if (len1_byte > 20000)
2747 temp = (unsigned char *) xmalloc (len1_byte);
3c6bc7d0 2748 else
ec1c14f6
RS
2749 temp = (unsigned char *) alloca (len1_byte);
2750 start1_addr = BUF_CHAR_ADDRESS (current_buffer, start1_byte);
2751 start2_addr = BUF_CHAR_ADDRESS (current_buffer, start2_byte);
2752 bcopy (start1_addr, temp, len1_byte);
2753 bcopy (start2_addr, start1_addr, len2_byte);
2754 bcopy (temp, start2_addr, len1_byte);
2755 if (len1_byte > 20000)
3c6bc7d0 2756 free (temp);
b229b8d1
RS
2757#ifdef USE_TEXT_PROPERTIES
2758 graft_intervals_into_buffer (tmp_interval1, start2,
2759 len1, current_buffer, 0);
2760 graft_intervals_into_buffer (tmp_interval2, start1,
2761 len2, current_buffer, 0);
2762#endif /* USE_TEXT_PROPERTIES */
2763 }
2764
ec1c14f6 2765 else if (len1_byte < len2_byte) /* Second region larger than first */
b229b8d1
RS
2766 /* Non-adjacent & unequal size, area between must also be shifted. */
2767 {
b229b8d1
RS
2768 modify_region (current_buffer, start1, end2);
2769 record_change (start1, (end2 - start1));
2770#ifdef USE_TEXT_PROPERTIES
2771 tmp_interval1 = copy_intervals (cur_intv, start1, len1);
2772 tmp_interval_mid = copy_intervals (cur_intv, end1, len_mid);
2773 tmp_interval2 = copy_intervals (cur_intv, start2, len2);
09dbcf71
RS
2774 Fset_text_properties (make_number (start1), make_number (end2),
2775 Qnil, Qnil);
b229b8d1
RS
2776#endif /* USE_TEXT_PROPERTIES */
2777
3c6bc7d0 2778 /* holds region 2 */
ec1c14f6
RS
2779 if (len2_byte > 20000)
2780 temp = (unsigned char *) xmalloc (len2_byte);
3c6bc7d0 2781 else
ec1c14f6
RS
2782 temp = (unsigned char *) alloca (len2_byte);
2783 start1_addr = BUF_CHAR_ADDRESS (current_buffer, start1_byte);
2784 start2_addr = BUF_CHAR_ADDRESS (current_buffer, start2_byte);
2785 bcopy (start2_addr, temp, len2_byte);
2786 bcopy (start1_addr, start1_addr + len_mid + len2_byte, len1_byte);
2787 safe_bcopy (start1_addr + len1_byte, start1_addr + len2_byte, len_mid);
2788 bcopy (temp, start1_addr, len2_byte);
2789 if (len2_byte > 20000)
3c6bc7d0 2790 free (temp);
b229b8d1
RS
2791#ifdef USE_TEXT_PROPERTIES
2792 graft_intervals_into_buffer (tmp_interval1, end2 - len1,
2793 len1, current_buffer, 0);
2794 graft_intervals_into_buffer (tmp_interval_mid, start1 + len2,
2795 len_mid, current_buffer, 0);
2796 graft_intervals_into_buffer (tmp_interval2, start1,
2797 len2, current_buffer, 0);
2798#endif /* USE_TEXT_PROPERTIES */
2799 }
2800 else
2801 /* Second region smaller than first. */
2802 {
b229b8d1
RS
2803 record_change (start1, (end2 - start1));
2804 modify_region (current_buffer, start1, end2);
2805
2806#ifdef USE_TEXT_PROPERTIES
2807 tmp_interval1 = copy_intervals (cur_intv, start1, len1);
2808 tmp_interval_mid = copy_intervals (cur_intv, end1, len_mid);
2809 tmp_interval2 = copy_intervals (cur_intv, start2, len2);
09dbcf71
RS
2810 Fset_text_properties (make_number (start1), make_number (end2),
2811 Qnil, Qnil);
b229b8d1
RS
2812#endif /* USE_TEXT_PROPERTIES */
2813
3c6bc7d0 2814 /* holds region 1 */
ec1c14f6
RS
2815 if (len1_byte > 20000)
2816 temp = (unsigned char *) xmalloc (len1_byte);
3c6bc7d0 2817 else
ec1c14f6
RS
2818 temp = (unsigned char *) alloca (len1_byte);
2819 start1_addr = BUF_CHAR_ADDRESS (current_buffer, start1_byte);
2820 start2_addr = BUF_CHAR_ADDRESS (current_buffer, start2_byte);
2821 bcopy (start1_addr, temp, len1_byte);
2822 bcopy (start2_addr, start1_addr, len2_byte);
2823 bcopy (start1_addr + len1_byte, start1_addr + len2_byte, len_mid);
2824 bcopy (temp, start1_addr + len2_byte + len_mid, len1_byte);
2825 if (len1_byte > 20000)
3c6bc7d0 2826 free (temp);
b229b8d1
RS
2827#ifdef USE_TEXT_PROPERTIES
2828 graft_intervals_into_buffer (tmp_interval1, end2 - len1,
2829 len1, current_buffer, 0);
2830 graft_intervals_into_buffer (tmp_interval_mid, start1 + len2,
2831 len_mid, current_buffer, 0);
2832 graft_intervals_into_buffer (tmp_interval2, start1,
2833 len2, current_buffer, 0);
2834#endif /* USE_TEXT_PROPERTIES */
2835 }
2836 }
2837
ec1c14f6
RS
2838 /* When doing multiple transpositions, it might be nice
2839 to optimize this. Perhaps the markers in any one buffer
2840 should be organized in some sorted data tree. */
b229b8d1 2841 if (NILP (leave_markers))
8de1d5f0 2842 {
ec1c14f6
RS
2843 transpose_markers (start1, end1, start2, end2,
2844 start1_byte, start1_byte + len1_byte,
2845 start2_byte, start2_byte + len2_byte);
8de1d5f0
KH
2846 fix_overlays_in_range (start1, end2);
2847 }
b229b8d1
RS
2848
2849 return Qnil;
2850}
35692fe0 2851
35692fe0
JB
2852\f
2853void
2854syms_of_editfns ()
2855{
260e2e2a
KH
2856 environbuf = 0;
2857
2858 Qbuffer_access_fontify_functions
2859 = intern ("buffer-access-fontify-functions");
2860 staticpro (&Qbuffer_access_fontify_functions);
2861
2862 DEFVAR_LISP ("buffer-access-fontify-functions",
2863 &Vbuffer_access_fontify_functions,
2864 "List of functions called by `buffer-substring' to fontify if necessary.\n\
2865Each function is called with two arguments which specify the range\n\
2866of the buffer being accessed.");
2867 Vbuffer_access_fontify_functions = Qnil;
2868
af209db8
RS
2869 {
2870 Lisp_Object obuf;
2871 extern Lisp_Object Vprin1_to_string_buffer;
2872 obuf = Fcurrent_buffer ();
2873 /* Do this here, because init_buffer_once is too early--it won't work. */
2874 Fset_buffer (Vprin1_to_string_buffer);
2875 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
2876 Fset (Fmake_local_variable (intern ("buffer-access-fontify-functions")),
2877 Qnil);
2878 Fset_buffer (obuf);
2879 }
2880
0b6fd023 2881 DEFVAR_LISP ("buffer-access-fontified-property",
260e2e2a
KH
2882 &Vbuffer_access_fontified_property,
2883 "Property which (if non-nil) indicates text has been fontified.\n\
2884`buffer-substring' need not call the `buffer-access-fontify-functions'\n\
2885functions if all the text being accessed has this property.");
2886 Vbuffer_access_fontified_property = Qnil;
2887
f43754f6
KH
2888 DEFVAR_LISP ("system-name", &Vsystem_name,
2889 "The name of the machine Emacs is running on.");
2890
2891 DEFVAR_LISP ("user-full-name", &Vuser_full_name,
2892 "The full name of the user logged in.");
2893
35b34f72 2894 DEFVAR_LISP ("user-login-name", &Vuser_login_name,
f43754f6
KH
2895 "The user's name, taken from environment variables if possible.");
2896
35b34f72 2897 DEFVAR_LISP ("user-real-login-name", &Vuser_real_login_name,
f43754f6 2898 "The user's name, based upon the real uid only.");
35692fe0
JB
2899
2900 defsubr (&Schar_equal);
2901 defsubr (&Sgoto_char);
2902 defsubr (&Sstring_to_char);
2903 defsubr (&Schar_to_string);
2904 defsubr (&Sbuffer_substring);
260e2e2a 2905 defsubr (&Sbuffer_substring_no_properties);
35692fe0
JB
2906 defsubr (&Sbuffer_string);
2907
2908 defsubr (&Spoint_marker);
2909 defsubr (&Smark_marker);
2910 defsubr (&Spoint);
2911 defsubr (&Sregion_beginning);
2912 defsubr (&Sregion_end);
7df74da6
RS
2913
2914 defsubr (&Sline_beginning_position);
2915 defsubr (&Sline_end_position);
2916
35692fe0
JB
2917/* defsubr (&Smark); */
2918/* defsubr (&Sset_mark); */
2919 defsubr (&Ssave_excursion);
4bc8c7d2 2920 defsubr (&Ssave_current_buffer);
35692fe0
JB
2921
2922 defsubr (&Sbufsize);
2923 defsubr (&Spoint_max);
2924 defsubr (&Spoint_min);
2925 defsubr (&Spoint_min_marker);
2926 defsubr (&Spoint_max_marker);
7df74da6 2927 defsubr (&Sposition_bytes);
c9ed721d 2928
35692fe0
JB
2929 defsubr (&Sbobp);
2930 defsubr (&Seobp);
2931 defsubr (&Sbolp);
2932 defsubr (&Seolp);
850a8179
JB
2933 defsubr (&Sfollowing_char);
2934 defsubr (&Sprevious_char);
35692fe0 2935 defsubr (&Schar_after);
fb8106e8 2936 defsubr (&Schar_before);
35692fe0
JB
2937 defsubr (&Sinsert);
2938 defsubr (&Sinsert_before_markers);
be91036a
RS
2939 defsubr (&Sinsert_and_inherit);
2940 defsubr (&Sinsert_and_inherit_before_markers);
35692fe0
JB
2941 defsubr (&Sinsert_char);
2942
2943 defsubr (&Suser_login_name);
2944 defsubr (&Suser_real_login_name);
2945 defsubr (&Suser_uid);
2946 defsubr (&Suser_real_uid);
2947 defsubr (&Suser_full_name);
7fd233b3 2948 defsubr (&Semacs_pid);
d940e0e4 2949 defsubr (&Scurrent_time);
a82d387c 2950 defsubr (&Sformat_time_string);
4691c06d 2951 defsubr (&Sdecode_time);
cce7b8a0 2952 defsubr (&Sencode_time);
35692fe0 2953 defsubr (&Scurrent_time_string);
c2662aea 2954 defsubr (&Scurrent_time_zone);
143cb9a9 2955 defsubr (&Sset_time_zone_rule);
35692fe0 2956 defsubr (&Ssystem_name);
35692fe0 2957 defsubr (&Smessage);
cacc3e2c
RS
2958 defsubr (&Smessage_box);
2959 defsubr (&Smessage_or_box);
b14dda8a 2960 defsubr (&Scurrent_message);
35692fe0 2961 defsubr (&Sformat);
35692fe0
JB
2962
2963 defsubr (&Sinsert_buffer_substring);
e9cf2084 2964 defsubr (&Scompare_buffer_substrings);
35692fe0
JB
2965 defsubr (&Ssubst_char_in_region);
2966 defsubr (&Stranslate_region);
2967 defsubr (&Sdelete_region);
2968 defsubr (&Swiden);
2969 defsubr (&Snarrow_to_region);
2970 defsubr (&Ssave_restriction);
b229b8d1 2971 defsubr (&Stranspose_regions);
35692fe0 2972}