1 /* Lisp functions pertaining to editing.
2 Copyright (C) 1985,86,87,89,93,94,95,96,97,98 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs; see the file COPYING. If not, write to
18 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
19 Boston, MA 02111-1307, USA. */
22 #include <sys/types.h>
41 #include "intervals.h"
48 #define min(a, b) ((a) < (b) ? (a) : (b))
49 #define max(a, b) ((a) > (b) ? (a) : (b))
55 extern char **environ
;
56 extern Lisp_Object
make_time ();
57 extern void insert_from_buffer ();
58 static int tm_diff ();
59 static void update_buffer_properties ();
60 size_t emacs_strftime ();
61 void set_time_zone_rule ();
63 Lisp_Object Vbuffer_access_fontify_functions
;
64 Lisp_Object Qbuffer_access_fontify_functions
;
65 Lisp_Object Vbuffer_access_fontified_property
;
67 Lisp_Object
Fuser_full_name ();
69 /* Some static data, and a function to initialize it for each run */
71 Lisp_Object Vsystem_name
;
72 Lisp_Object Vuser_real_login_name
; /* login name of current user ID */
73 Lisp_Object Vuser_full_name
; /* full name of current user */
74 Lisp_Object Vuser_login_name
; /* user name from LOGNAME or USER */
80 register unsigned char *p
, *q
, *r
;
81 struct passwd
*pw
; /* password entry for the current user */
84 /* Set up system_name even when dumping. */
88 /* Don't bother with this on initial start when just dumping out */
91 #endif /* not CANNOT_DUMP */
93 pw
= (struct passwd
*) getpwuid (getuid ());
95 /* We let the real user name default to "root" because that's quite
96 accurate on MSDOG and because it lets Emacs find the init file.
97 (The DVX libraries override the Djgpp libraries here.) */
98 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "root");
100 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "unknown");
103 /* Get the effective user name, by consulting environment variables,
104 or the effective uid if those are unset. */
105 user_name
= (char *) getenv ("LOGNAME");
108 user_name
= (char *) getenv ("USERNAME"); /* it's USERNAME on NT */
109 #else /* WINDOWSNT */
110 user_name
= (char *) getenv ("USER");
111 #endif /* WINDOWSNT */
114 pw
= (struct passwd
*) getpwuid (geteuid ());
115 user_name
= (char *) (pw
? pw
->pw_name
: "unknown");
117 Vuser_login_name
= build_string (user_name
);
119 /* If the user name claimed in the environment vars differs from
120 the real uid, use the claimed name to find the full name. */
121 tem
= Fstring_equal (Vuser_login_name
, Vuser_real_login_name
);
122 Vuser_full_name
= Fuser_full_name (NILP (tem
)? make_number (geteuid())
125 p
= (unsigned char *) getenv ("NAME");
127 Vuser_full_name
= build_string (p
);
128 else if (NILP (Vuser_full_name
))
129 Vuser_full_name
= build_string ("unknown");
132 DEFUN ("char-to-string", Fchar_to_string
, Schar_to_string
, 1, 1, 0,
133 "Convert arg CHAR to a string containing that character.")
135 Lisp_Object character
;
138 unsigned char workbuf
[4], *str
;
140 CHECK_NUMBER (character
, 0);
142 len
= CHAR_STRING (XFASTINT (character
), workbuf
, str
);
143 return make_string_from_bytes (str
, 1, len
);
146 DEFUN ("string-to-char", Fstring_to_char
, Sstring_to_char
, 1, 1, 0,
147 "Convert arg STRING to a character, the first character of that string.\n\
148 A multibyte character is handled correctly.")
150 register Lisp_Object string
;
152 register Lisp_Object val
;
153 register struct Lisp_String
*p
;
154 CHECK_STRING (string
, 0);
155 p
= XSTRING (string
);
158 if (STRING_MULTIBYTE (string
))
159 XSETFASTINT (val
, STRING_CHAR (p
->data
, STRING_BYTES (p
)));
161 XSETFASTINT (val
, p
->data
[0]);
164 XSETFASTINT (val
, 0);
169 buildmark (charpos
, bytepos
)
170 int charpos
, bytepos
;
172 register Lisp_Object mark
;
173 mark
= Fmake_marker ();
174 set_marker_both (mark
, Qnil
, charpos
, bytepos
);
178 DEFUN ("point", Fpoint
, Spoint
, 0, 0, 0,
179 "Return value of point, as an integer.\n\
180 Beginning of buffer is position (point-min)")
184 XSETFASTINT (temp
, PT
);
188 DEFUN ("point-marker", Fpoint_marker
, Spoint_marker
, 0, 0, 0,
189 "Return value of point, as a marker object.")
192 return buildmark (PT
, PT_BYTE
);
196 clip_to_bounds (lower
, num
, upper
)
197 int lower
, num
, upper
;
201 else if (num
> upper
)
207 DEFUN ("goto-char", Fgoto_char
, Sgoto_char
, 1, 1, "NGoto char: ",
208 "Set point to POSITION, a number or marker.\n\
209 Beginning of buffer is position (point-min), end is (point-max).\n\
210 If the position is in the middle of a multibyte form,\n\
211 the actual point is set at the head of the multibyte form\n\
212 except in the case that `enable-multibyte-characters' is nil.")
214 register Lisp_Object position
;
219 if (MARKERP (position
)
220 && current_buffer
== XMARKER (position
)->buffer
)
222 pos
= marker_position (position
);
224 SET_PT_BOTH (BEGV
, BEGV_BYTE
);
226 SET_PT_BOTH (ZV
, ZV_BYTE
);
228 SET_PT_BOTH (pos
, marker_byte_position (position
));
233 CHECK_NUMBER_COERCE_MARKER (position
, 0);
235 pos
= clip_to_bounds (BEGV
, XINT (position
), ZV
);
241 region_limit (beginningp
)
244 extern Lisp_Object Vmark_even_if_inactive
; /* Defined in callint.c. */
245 register Lisp_Object m
;
246 if (!NILP (Vtransient_mark_mode
) && NILP (Vmark_even_if_inactive
)
247 && NILP (current_buffer
->mark_active
))
248 Fsignal (Qmark_inactive
, Qnil
);
249 m
= Fmarker_position (current_buffer
->mark
);
250 if (NILP (m
)) error ("There is no region now");
251 if ((PT
< XFASTINT (m
)) == beginningp
)
252 return (make_number (PT
));
257 DEFUN ("region-beginning", Fregion_beginning
, Sregion_beginning
, 0, 0, 0,
258 "Return position of beginning of region, as an integer.")
261 return (region_limit (1));
264 DEFUN ("region-end", Fregion_end
, Sregion_end
, 0, 0, 0,
265 "Return position of end of region, as an integer.")
268 return (region_limit (0));
271 DEFUN ("mark-marker", Fmark_marker
, Smark_marker
, 0, 0, 0,
272 "Return this buffer's mark, as a marker object.\n\
273 Watch out! Moving this marker changes the mark position.\n\
274 If you set the marker not to point anywhere, the buffer will have no mark.")
277 return current_buffer
->mark
;
280 DEFUN ("line-beginning-position", Fline_beginning_position
, Sline_beginning_position
,
282 "Return the character position of the first character on the current line.\n\
283 With argument N not nil or 1, move forward N - 1 lines first.\n\
284 If scan reaches end of buffer, return that position.\n\
285 This function does not move point.\n\n\
286 In the minibuffer, if point is not within the prompt,\n\
287 the return value is never within the prompt either.")
292 register int orig
, orig_byte
, end
;
301 Fforward_line (make_number (XINT (n
) - 1));
304 if (INTEGERP (current_buffer
->prompt_end_charpos
)
305 && orig
>= XFASTINT (current_buffer
->prompt_end_charpos
)
306 && end
< XFASTINT (current_buffer
->prompt_end_charpos
))
307 end
= XFASTINT (current_buffer
->prompt_end_charpos
);
309 SET_PT_BOTH (orig
, orig_byte
);
311 return make_number (end
);
314 DEFUN ("line-end-position", Fline_end_position
, Sline_end_position
,
316 "Return the character position of the last character on the current line.\n\
317 With argument N not nil or 1, move forward N - 1 lines first.\n\
318 If scan reaches end of buffer, return that position.\n\
319 This function does not move point.")
328 return make_number (find_before_next_newline
329 (PT
, 0, XINT (n
) - (XINT (n
) <= 0)));
333 save_excursion_save ()
335 register int visible
= (XBUFFER (XWINDOW (selected_window
)->buffer
)
338 return Fcons (Fpoint_marker (),
339 Fcons (Fcopy_marker (current_buffer
->mark
, Qnil
),
340 Fcons (visible
? Qt
: Qnil
,
341 current_buffer
->mark_active
)));
345 save_excursion_restore (info
)
348 Lisp_Object tem
, tem1
, omark
, nmark
;
349 struct gcpro gcpro1
, gcpro2
, gcpro3
;
351 tem
= Fmarker_buffer (Fcar (info
));
352 /* If buffer being returned to is now deleted, avoid error */
353 /* Otherwise could get error here while unwinding to top level
355 /* In that case, Fmarker_buffer returns nil now. */
359 omark
= nmark
= Qnil
;
360 GCPRO3 (info
, omark
, nmark
);
365 unchain_marker (tem
);
366 tem
= Fcar (Fcdr (info
));
367 omark
= Fmarker_position (current_buffer
->mark
);
368 Fset_marker (current_buffer
->mark
, tem
, Fcurrent_buffer ());
369 nmark
= Fmarker_position (tem
);
370 unchain_marker (tem
);
371 tem
= Fcdr (Fcdr (info
));
372 #if 0 /* We used to make the current buffer visible in the selected window
373 if that was true previously. That avoids some anomalies.
374 But it creates others, and it wasn't documented, and it is simpler
375 and cleaner never to alter the window/buffer connections. */
378 && current_buffer
!= XBUFFER (XWINDOW (selected_window
)->buffer
))
379 Fswitch_to_buffer (Fcurrent_buffer (), Qnil
);
382 tem1
= current_buffer
->mark_active
;
383 current_buffer
->mark_active
= Fcdr (tem
);
384 if (!NILP (Vrun_hooks
))
386 /* If mark is active now, and either was not active
387 or was at a different place, run the activate hook. */
388 if (! NILP (current_buffer
->mark_active
))
390 if (! EQ (omark
, nmark
))
391 call1 (Vrun_hooks
, intern ("activate-mark-hook"));
393 /* If mark has ceased to be active, run deactivate hook. */
394 else if (! NILP (tem1
))
395 call1 (Vrun_hooks
, intern ("deactivate-mark-hook"));
401 DEFUN ("save-excursion", Fsave_excursion
, Ssave_excursion
, 0, UNEVALLED
, 0,
402 "Save point, mark, and current buffer; execute BODY; restore those things.\n\
403 Executes BODY just like `progn'.\n\
404 The values of point, mark and the current buffer are restored\n\
405 even in case of abnormal exit (throw or error).\n\
406 The state of activation of the mark is also restored.\n\
408 This construct does not save `deactivate-mark', and therefore\n\
409 functions that change the buffer will still cause deactivation\n\
410 of the mark at the end of the command. To prevent that, bind\n\
411 `deactivate-mark' with `let'.")
415 register Lisp_Object val
;
416 int count
= specpdl_ptr
- specpdl
;
418 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
421 return unbind_to (count
, val
);
424 DEFUN ("save-current-buffer", Fsave_current_buffer
, Ssave_current_buffer
, 0, UNEVALLED
, 0,
425 "Save the current buffer; execute BODY; restore the current buffer.\n\
426 Executes BODY just like `progn'.")
430 register Lisp_Object val
;
431 int count
= specpdl_ptr
- specpdl
;
433 record_unwind_protect (set_buffer_if_live
, Fcurrent_buffer ());
436 return unbind_to (count
, val
);
439 DEFUN ("buffer-size", Fbufsize
, Sbufsize
, 0, 1, 0,
440 "Return the number of characters in the current buffer.\n\
441 If BUFFER, return the number of characters in that buffer instead.")
446 return make_number (Z
- BEG
);
449 CHECK_BUFFER (buffer
, 1);
450 return make_number (BUF_Z (XBUFFER (buffer
))
451 - BUF_BEG (XBUFFER (buffer
)));
455 DEFUN ("point-min", Fpoint_min
, Spoint_min
, 0, 0, 0,
456 "Return the minimum permissible value of point in the current buffer.\n\
457 This is 1, unless narrowing (a buffer restriction) is in effect.")
461 XSETFASTINT (temp
, BEGV
);
465 DEFUN ("point-min-marker", Fpoint_min_marker
, Spoint_min_marker
, 0, 0, 0,
466 "Return a marker to the minimum permissible value of point in this buffer.\n\
467 This is the beginning, unless narrowing (a buffer restriction) is in effect.")
470 return buildmark (BEGV
, BEGV_BYTE
);
473 DEFUN ("point-max", Fpoint_max
, Spoint_max
, 0, 0, 0,
474 "Return the maximum permissible value of point in the current buffer.\n\
475 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)\n\
476 is in effect, in which case it is less.")
480 XSETFASTINT (temp
, ZV
);
484 DEFUN ("point-max-marker", Fpoint_max_marker
, Spoint_max_marker
, 0, 0, 0,
485 "Return a marker to the maximum permissible value of point in this buffer.\n\
486 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)\n\
487 is in effect, in which case it is less.")
490 return buildmark (ZV
, ZV_BYTE
);
493 DEFUN ("gap-position", Fgap_position
, Sgap_position
, 0, 0, 0,
494 "Return the position of the gap, in the current buffer.\n\
495 See also `gap-size'.")
499 XSETFASTINT (temp
, GPT
);
503 DEFUN ("gap-size", Fgap_size
, Sgap_size
, 0, 0, 0,
504 "Return the size of the current buffer's gap.\n\
505 See also `gap-position'.")
509 XSETFASTINT (temp
, GAP_SIZE
);
513 DEFUN ("position-bytes", Fposition_bytes
, Sposition_bytes
, 1, 1, 0,
514 "Return the byte position for character position POSITION.\n\
515 If POSITION is out of range, the value is nil.")
517 Lisp_Object position
;
519 CHECK_NUMBER_COERCE_MARKER (position
, 1);
520 if (XINT (position
) < BEG
|| XINT (position
) > Z
)
522 return make_number (CHAR_TO_BYTE (XINT (position
)));
525 DEFUN ("byte-to-position", Fbyte_to_position
, Sbyte_to_position
, 1, 1, 0,
526 "Return the character position for byte position BYTEPOS.\n\
527 If BYTEPOS is out of range, the value is nil.")
531 CHECK_NUMBER (bytepos
, 1);
532 if (XINT (bytepos
) < BEG_BYTE
|| XINT (bytepos
) > Z_BYTE
)
534 return make_number (BYTE_TO_CHAR (XINT (bytepos
)));
537 DEFUN ("following-char", Ffollowing_char
, Sfollowing_char
, 0, 0, 0,
538 "Return the character following point, as a number.\n\
539 At the end of the buffer or accessible region, return 0.\n\
540 If `enable-multibyte-characters' is nil or point is not\n\
541 at character boundary, multibyte form is ignored,\n\
542 and only one byte following point is returned as a character.")
547 XSETFASTINT (temp
, 0);
549 XSETFASTINT (temp
, FETCH_CHAR (PT_BYTE
));
553 DEFUN ("preceding-char", Fprevious_char
, Sprevious_char
, 0, 0, 0,
554 "Return the character preceding point, as a number.\n\
555 At the beginning of the buffer or accessible region, return 0.\n\
556 If `enable-multibyte-characters' is nil or point is not\n\
557 at character boundary, multi-byte form is ignored,\n\
558 and only one byte preceding point is returned as a character.")
563 XSETFASTINT (temp
, 0);
564 else if (!NILP (current_buffer
->enable_multibyte_characters
))
568 XSETFASTINT (temp
, FETCH_CHAR (pos
));
571 XSETFASTINT (temp
, FETCH_BYTE (PT_BYTE
- 1));
575 DEFUN ("bobp", Fbobp
, Sbobp
, 0, 0, 0,
576 "Return t if point is at the beginning of the buffer.\n\
577 If the buffer is narrowed, this means the beginning of the narrowed part.")
585 DEFUN ("eobp", Feobp
, Seobp
, 0, 0, 0,
586 "Return t if point is at the end of the buffer.\n\
587 If the buffer is narrowed, this means the end of the narrowed part.")
595 DEFUN ("bolp", Fbolp
, Sbolp
, 0, 0, 0,
596 "Return t if point is at the beginning of a line.")
599 if (PT
== BEGV
|| FETCH_BYTE (PT_BYTE
- 1) == '\n')
604 DEFUN ("eolp", Feolp
, Seolp
, 0, 0, 0,
605 "Return t if point is at the end of a line.\n\
606 `End of a line' includes point being at the end of the buffer.")
609 if (PT
== ZV
|| FETCH_BYTE (PT_BYTE
) == '\n')
614 DEFUN ("char-after", Fchar_after
, Schar_after
, 0, 1, 0,
615 "Return character in current buffer at position POS.\n\
616 POS is an integer or a buffer pointer.\n\
617 If POS is out of range, the value is nil.")
621 register int pos_byte
;
622 register Lisp_Object val
;
627 XSETFASTINT (pos
, PT
);
632 pos_byte
= marker_byte_position (pos
);
633 if (pos_byte
< BEGV_BYTE
|| pos_byte
>= ZV_BYTE
)
638 CHECK_NUMBER_COERCE_MARKER (pos
, 0);
639 if (XINT (pos
) < BEGV
|| XINT (pos
) >= ZV
)
642 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
645 return make_number (FETCH_CHAR (pos_byte
));
648 DEFUN ("char-before", Fchar_before
, Schar_before
, 0, 1, 0,
649 "Return character in current buffer preceding position POS.\n\
650 POS is an integer or a buffer pointer.\n\
651 If POS is out of range, the value is nil.")
655 register Lisp_Object val
;
656 register int pos_byte
;
661 XSETFASTINT (pos
, PT
);
666 pos_byte
= marker_byte_position (pos
);
668 if (pos_byte
<= BEGV_BYTE
|| pos_byte
> ZV_BYTE
)
673 CHECK_NUMBER_COERCE_MARKER (pos
, 0);
675 if (XINT (pos
) <= BEGV
|| XINT (pos
) > ZV
)
678 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
681 if (!NILP (current_buffer
->enable_multibyte_characters
))
684 XSETFASTINT (val
, FETCH_CHAR (pos_byte
));
689 XSETFASTINT (val
, FETCH_BYTE (pos_byte
));
694 DEFUN ("user-login-name", Fuser_login_name
, Suser_login_name
, 0, 1, 0,
695 "Return the name under which the user logged in, as a string.\n\
696 This is based on the effective uid, not the real uid.\n\
697 Also, if the environment variable LOGNAME or USER is set,\n\
698 that determines the value of this function.\n\n\
699 If optional argument UID is an integer, return the login name of the user\n\
700 with that uid, or nil if there is no such user.")
706 /* Set up the user name info if we didn't do it before.
707 (That can happen if Emacs is dumpable
708 but you decide to run `temacs -l loadup' and not dump. */
709 if (INTEGERP (Vuser_login_name
))
713 return Vuser_login_name
;
715 CHECK_NUMBER (uid
, 0);
716 pw
= (struct passwd
*) getpwuid (XINT (uid
));
717 return (pw
? build_string (pw
->pw_name
) : Qnil
);
720 DEFUN ("user-real-login-name", Fuser_real_login_name
, Suser_real_login_name
,
722 "Return the name of the user's real uid, as a string.\n\
723 This ignores the environment variables LOGNAME and USER, so it differs from\n\
724 `user-login-name' when running under `su'.")
727 /* Set up the user name info if we didn't do it before.
728 (That can happen if Emacs is dumpable
729 but you decide to run `temacs -l loadup' and not dump. */
730 if (INTEGERP (Vuser_login_name
))
732 return Vuser_real_login_name
;
735 DEFUN ("user-uid", Fuser_uid
, Suser_uid
, 0, 0, 0,
736 "Return the effective uid of Emacs, as an integer.")
739 return make_number (geteuid ());
742 DEFUN ("user-real-uid", Fuser_real_uid
, Suser_real_uid
, 0, 0, 0,
743 "Return the real uid of Emacs, as an integer.")
746 return make_number (getuid ());
749 DEFUN ("user-full-name", Fuser_full_name
, Suser_full_name
, 0, 1, 0,
750 "Return the full name of the user logged in, as a string.\n\
751 If the full name corresponding to Emacs's userid is not known,\n\
752 return \"unknown\".\n\
754 If optional argument UID is an integer, return the full name of the user\n\
755 with that uid, or nil if there is no such user.\n\
756 If UID is a string, return the full name of the user with that login\n\
757 name, or nil if there is no such user.")
762 register unsigned char *p
, *q
;
763 extern char *index ();
767 return Vuser_full_name
;
768 else if (NUMBERP (uid
))
769 pw
= (struct passwd
*) getpwuid (XINT (uid
));
770 else if (STRINGP (uid
))
771 pw
= (struct passwd
*) getpwnam (XSTRING (uid
)->data
);
773 error ("Invalid UID specification");
778 p
= (unsigned char *) USER_FULL_NAME
;
779 /* Chop off everything after the first comma. */
780 q
= (unsigned char *) index (p
, ',');
781 full
= make_string (p
, q
? q
- p
: strlen (p
));
783 #ifdef AMPERSAND_FULL_NAME
784 p
= XSTRING (full
)->data
;
785 q
= (unsigned char *) index (p
, '&');
786 /* Substitute the login name for the &, upcasing the first character. */
789 register unsigned char *r
;
792 login
= Fuser_login_name (make_number (pw
->pw_uid
));
793 r
= (unsigned char *) alloca (strlen (p
) + XSTRING (login
)->size
+ 1);
796 strcat (r
, XSTRING (login
)->data
);
797 r
[q
- p
] = UPCASE (r
[q
- p
]);
799 full
= build_string (r
);
801 #endif /* AMPERSAND_FULL_NAME */
806 DEFUN ("system-name", Fsystem_name
, Ssystem_name
, 0, 0, 0,
807 "Return the name of the machine you are running on, as a string.")
813 /* For the benefit of callers who don't want to include lisp.h */
817 if (STRINGP (Vsystem_name
))
818 return (char *) XSTRING (Vsystem_name
)->data
;
823 DEFUN ("emacs-pid", Femacs_pid
, Semacs_pid
, 0, 0, 0,
824 "Return the process ID of Emacs, as an integer.")
827 return make_number (getpid ());
830 DEFUN ("current-time", Fcurrent_time
, Scurrent_time
, 0, 0, 0,
831 "Return the current time, as the number of seconds since 1970-01-01 00:00:00.\n\
832 The time is returned as a list of three integers. The first has the\n\
833 most significant 16 bits of the seconds, while the second has the\n\
834 least significant 16 bits. The third integer gives the microsecond\n\
837 The microsecond count is zero on systems that do not provide\n\
838 resolution finer than a second.")
842 Lisp_Object result
[3];
845 XSETINT (result
[0], (EMACS_SECS (t
) >> 16) & 0xffff);
846 XSETINT (result
[1], (EMACS_SECS (t
) >> 0) & 0xffff);
847 XSETINT (result
[2], EMACS_USECS (t
));
849 return Flist (3, result
);
854 lisp_time_argument (specified_time
, result
)
855 Lisp_Object specified_time
;
858 if (NILP (specified_time
))
859 return time (result
) != -1;
862 Lisp_Object high
, low
;
863 high
= Fcar (specified_time
);
864 CHECK_NUMBER (high
, 0);
865 low
= Fcdr (specified_time
);
868 CHECK_NUMBER (low
, 0);
869 *result
= (XINT (high
) << 16) + (XINT (low
) & 0xffff);
870 return *result
>> 16 == XINT (high
);
874 /* Write information into buffer S of size MAXSIZE, according to the
875 FORMAT of length FORMAT_LEN, using time information taken from *TP.
876 Return the number of bytes written, not including the terminating
877 '\0'. If S is NULL, nothing will be written anywhere; so to
878 determine how many bytes would be written, use NULL for S and
879 ((size_t) -1) for MAXSIZE.
881 This function behaves like emacs_strftime, except it allows null
884 emacs_memftime (s
, maxsize
, format
, format_len
, tp
)
893 /* Loop through all the null-terminated strings in the format
894 argument. Normally there's just one null-terminated string, but
895 there can be arbitrarily many, concatenated together, if the
896 format contains '\0' bytes. emacs_strftime stops at the first
897 '\0' byte so we must invoke it separately for each such string. */
906 result
= emacs_strftime (s
, maxsize
, format
, tp
);
910 if (result
== 0 && s
[0] != '\0')
915 maxsize
-= result
+ 1;
917 len
= strlen (format
);
918 if (len
== format_len
)
922 format_len
-= len
+ 1;
927 DEFUN ("format-time-string", Fformat_time_string, Sformat_time_string, 1, 3, 0,
928 "Use FORMAT-STRING to format the time TIME, or now if omitted.\n\
929 TIME is specified as (HIGH LOW . IGNORED) or (HIGH . LOW), as returned by\n\
930 `current-time' or `file-attributes'.\n\
931 The third, optional, argument UNIVERSAL, if non-nil, means describe TIME\n\
932 as Universal Time; nil means describe TIME in the local time zone.\n\
933 The value is a copy of FORMAT-STRING, but with certain constructs replaced\n\
934 by text that describes the specified date and time in TIME:\n\
936 %Y is the year, %y within the century, %C the century.\n\
937 %G is the year corresponding to the ISO week, %g within the century.\n\
938 %m is the numeric month.\n\
939 %b and %h are the locale's abbreviated month name, %B the full name.\n\
940 %d is the day of the month, zero-padded, %e is blank-padded.\n\
941 %u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.\n\
942 %a is the locale's abbreviated name of the day of week, %A the full name.\n\
943 %U is the week number starting on Sunday, %W starting on Monday,\n\
944 %V according to ISO 8601.\n\
945 %j is the day of the year.\n\
947 %H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H\n\
948 only blank-padded, %l is like %I blank-padded.\n\
949 %p is the locale's equivalent of either AM or PM.\n\
952 %Z is the time zone name, %z is the numeric form.\n\
953 %s is the number of seconds since 1970-01-01 00:00:00 +0000.\n\
955 %c is the locale's date and time format.\n\
956 %x is the locale's \"preferred\" date format.\n\
957 %D is like \"%m/%d/%y\".\n\
959 %R is like \"%H:%M\", %T is like \"%H:%M:%S\", %r is like \"%I:%M:%S %p\".\n\
960 %X is the locale's \"preferred\" time format.\n\
962 Finally, %n is a newline, %t is a tab, %% is a literal %.\n\
964 Certain flags and modifiers are available with some format controls.\n\
965 The flags are `_' and `-'. For certain characters X, %_X is like %X,\n\
966 but padded with blanks; %-X is like %X, but without padding.\n\
967 %NX (where N stands for an integer) is like %X,\n\
968 but takes up at least N (a number) positions.\n\
969 The modifiers are `E' and `O'. For certain characters X,\n\
970 %EX is a locale's alternative version of %X;\n\
971 %OX is like %X, but uses the locale's number symbols.\n\
973 For example, to produce full ISO 8601 format, use \"%Y-%m-%dT%T%z\".")
974 (format_string, time, universal)
977 DEFUN ("format-time-string", Fformat_time_string
, Sformat_time_string
, 1, 3, 0,
978 0 /* See immediately above */)
979 (format_string
, time
, universal
)
980 Lisp_Object format_string
, time
, universal
;
986 CHECK_STRING (format_string
, 1);
988 if (! lisp_time_argument (time
, &value
))
989 error ("Invalid time specification");
991 /* This is probably enough. */
992 size
= STRING_BYTES (XSTRING (format_string
)) * 6 + 50;
994 tm
= NILP (universal
) ? localtime (&value
) : gmtime (&value
);
996 error ("Specified time is not representable");
1000 char *buf
= (char *) alloca (size
+ 1);
1004 result
= emacs_memftime (buf
, size
, XSTRING (format_string
)->data
,
1005 STRING_BYTES (XSTRING (format_string
)),
1007 if ((result
> 0 && result
< size
) || (result
== 0 && buf
[0] == '\0'))
1008 return make_string (buf
, result
);
1010 /* If buffer was too small, make it bigger and try again. */
1011 result
= emacs_memftime (NULL
, (size_t) -1,
1012 XSTRING (format_string
)->data
,
1013 STRING_BYTES (XSTRING (format_string
)),
1019 DEFUN ("decode-time", Fdecode_time
, Sdecode_time
, 0, 1, 0,
1020 "Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST ZONE).\n\
1021 The optional SPECIFIED-TIME should be a list of (HIGH LOW . IGNORED)\n\
1022 or (HIGH . LOW), as from `current-time' and `file-attributes', or `nil'\n\
1023 to use the current time. The list has the following nine members:\n\
1024 SEC is an integer between 0 and 60; SEC is 60 for a leap second, which\n\
1025 only some operating systems support. MINUTE is an integer between 0 and 59.\n\
1026 HOUR is an integer between 0 and 23. DAY is an integer between 1 and 31.\n\
1027 MONTH is an integer between 1 and 12. YEAR is an integer indicating the\n\
1028 four-digit year. DOW is the day of week, an integer between 0 and 6, where\n\
1029 0 is Sunday. DST is t if daylight savings time is effect, otherwise nil.\n\
1030 ZONE is an integer indicating the number of seconds east of Greenwich.\n\
1031 \(Note that Common Lisp has different meanings for DOW and ZONE.)")
1033 Lisp_Object specified_time
;
1037 struct tm
*decoded_time
;
1038 Lisp_Object list_args
[9];
1040 if (! lisp_time_argument (specified_time
, &time_spec
))
1041 error ("Invalid time specification");
1043 decoded_time
= localtime (&time_spec
);
1045 error ("Specified time is not representable");
1046 XSETFASTINT (list_args
[0], decoded_time
->tm_sec
);
1047 XSETFASTINT (list_args
[1], decoded_time
->tm_min
);
1048 XSETFASTINT (list_args
[2], decoded_time
->tm_hour
);
1049 XSETFASTINT (list_args
[3], decoded_time
->tm_mday
);
1050 XSETFASTINT (list_args
[4], decoded_time
->tm_mon
+ 1);
1051 XSETINT (list_args
[5], decoded_time
->tm_year
+ 1900);
1052 XSETFASTINT (list_args
[6], decoded_time
->tm_wday
);
1053 list_args
[7] = (decoded_time
->tm_isdst
)? Qt
: Qnil
;
1055 /* Make a copy, in case gmtime modifies the struct. */
1056 save_tm
= *decoded_time
;
1057 decoded_time
= gmtime (&time_spec
);
1058 if (decoded_time
== 0)
1059 list_args
[8] = Qnil
;
1061 XSETINT (list_args
[8], tm_diff (&save_tm
, decoded_time
));
1062 return Flist (9, list_args
);
1065 DEFUN ("encode-time", Fencode_time
, Sencode_time
, 6, MANY
, 0,
1066 "Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.\n\
1067 This is the reverse operation of `decode-time', which see.\n\
1068 ZONE defaults to the current time zone rule. This can\n\
1069 be a string or t (as from `set-time-zone-rule'), or it can be a list\n\
1070 \(as from `current-time-zone') or an integer (as from `decode-time')\n\
1071 applied without consideration for daylight savings time.\n\
1073 You can pass more than 7 arguments; then the first six arguments\n\
1074 are used as SECOND through YEAR, and the *last* argument is used as ZONE.\n\
1075 The intervening arguments are ignored.\n\
1076 This feature lets (apply 'encode-time (decode-time ...)) work.\n\
1078 Out-of-range values for SEC, MINUTE, HOUR, DAY, or MONTH are allowed;\n\
1079 for example, a DAY of 0 means the day preceding the given month.\n\
1080 Year numbers less than 100 are treated just like other year numbers.\n\
1081 If you want them to stand for years in this century, you must do that yourself.")
1084 register Lisp_Object
*args
;
1088 Lisp_Object zone
= (nargs
> 6 ? args
[nargs
- 1] : Qnil
);
1090 CHECK_NUMBER (args
[0], 0); /* second */
1091 CHECK_NUMBER (args
[1], 1); /* minute */
1092 CHECK_NUMBER (args
[2], 2); /* hour */
1093 CHECK_NUMBER (args
[3], 3); /* day */
1094 CHECK_NUMBER (args
[4], 4); /* month */
1095 CHECK_NUMBER (args
[5], 5); /* year */
1097 tm
.tm_sec
= XINT (args
[0]);
1098 tm
.tm_min
= XINT (args
[1]);
1099 tm
.tm_hour
= XINT (args
[2]);
1100 tm
.tm_mday
= XINT (args
[3]);
1101 tm
.tm_mon
= XINT (args
[4]) - 1;
1102 tm
.tm_year
= XINT (args
[5]) - 1900;
1108 time
= mktime (&tm
);
1113 char **oldenv
= environ
, **newenv
;
1117 else if (STRINGP (zone
))
1118 tzstring
= (char *) XSTRING (zone
)->data
;
1119 else if (INTEGERP (zone
))
1121 int abszone
= abs (XINT (zone
));
1122 sprintf (tzbuf
, "XXX%s%d:%02d:%02d", "-" + (XINT (zone
) < 0),
1123 abszone
/ (60*60), (abszone
/60) % 60, abszone
% 60);
1127 error ("Invalid time zone specification");
1129 /* Set TZ before calling mktime; merely adjusting mktime's returned
1130 value doesn't suffice, since that would mishandle leap seconds. */
1131 set_time_zone_rule (tzstring
);
1133 time
= mktime (&tm
);
1135 /* Restore TZ to previous value. */
1139 #ifdef LOCALTIME_CACHE
1144 if (time
== (time_t) -1)
1145 error ("Specified time is not representable");
1147 return make_time (time
);
1150 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
, 0, 1, 0,
1151 "Return the current time, as a human-readable string.\n\
1152 Programs can use this function to decode a time,\n\
1153 since the number of columns in each field is fixed.\n\
1154 The format is `Sun Sep 16 01:03:52 1973'.\n\
1155 However, see also the functions `decode-time' and `format-time-string'\n\
1156 which provide a much more powerful and general facility.\n\
1158 If an argument is given, it specifies a time to format\n\
1159 instead of the current time. The argument should have the form:\n\
1162 (HIGH LOW . IGNORED).\n\
1163 Thus, you can use times obtained from `current-time'\n\
1164 and from `file-attributes'.")
1166 Lisp_Object specified_time
;
1172 if (! lisp_time_argument (specified_time
, &value
))
1174 tem
= (char *) ctime (&value
);
1176 strncpy (buf
, tem
, 24);
1179 return build_string (buf
);
1182 #define TM_YEAR_BASE 1900
1184 /* Yield A - B, measured in seconds.
1185 This function is copied from the GNU C Library. */
1190 /* Compute intervening leap days correctly even if year is negative.
1191 Take care to avoid int overflow in leap day calculations,
1192 but it's OK to assume that A and B are close to each other. */
1193 int a4
= (a
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (a
->tm_year
& 3);
1194 int b4
= (b
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (b
->tm_year
& 3);
1195 int a100
= a4
/ 25 - (a4
% 25 < 0);
1196 int b100
= b4
/ 25 - (b4
% 25 < 0);
1197 int a400
= a100
>> 2;
1198 int b400
= b100
>> 2;
1199 int intervening_leap_days
= (a4
- b4
) - (a100
- b100
) + (a400
- b400
);
1200 int years
= a
->tm_year
- b
->tm_year
;
1201 int days
= (365 * years
+ intervening_leap_days
1202 + (a
->tm_yday
- b
->tm_yday
));
1203 return (60 * (60 * (24 * days
+ (a
->tm_hour
- b
->tm_hour
))
1204 + (a
->tm_min
- b
->tm_min
))
1205 + (a
->tm_sec
- b
->tm_sec
));
1208 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 1, 0,
1209 "Return the offset and name for the local time zone.\n\
1210 This returns a list of the form (OFFSET NAME).\n\
1211 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).\n\
1212 A negative value means west of Greenwich.\n\
1213 NAME is a string giving the name of the time zone.\n\
1214 If an argument is given, it specifies when the time zone offset is determined\n\
1215 instead of using the current time. The argument should have the form:\n\
1218 (HIGH LOW . IGNORED).\n\
1219 Thus, you can use times obtained from `current-time'\n\
1220 and from `file-attributes'.\n\
1222 Some operating systems cannot provide all this information to Emacs;\n\
1223 in this case, `current-time-zone' returns a list containing nil for\n\
1224 the data it can't find.")
1226 Lisp_Object specified_time
;
1232 if (lisp_time_argument (specified_time
, &value
)
1233 && (t
= gmtime (&value
)) != 0
1234 && (gmt
= *t
, t
= localtime (&value
)) != 0)
1236 int offset
= tm_diff (t
, &gmt
);
1241 s
= (char *)t
->tm_zone
;
1242 #else /* not HAVE_TM_ZONE */
1244 if (t
->tm_isdst
== 0 || t
->tm_isdst
== 1)
1245 s
= tzname
[t
->tm_isdst
];
1247 #endif /* not HAVE_TM_ZONE */
1250 /* No local time zone name is available; use "+-NNNN" instead. */
1251 int am
= (offset
< 0 ? -offset
: offset
) / 60;
1252 sprintf (buf
, "%c%02d%02d", (offset
< 0 ? '-' : '+'), am
/60, am
%60);
1255 return Fcons (make_number (offset
), Fcons (build_string (s
), Qnil
));
1258 return Fmake_list (make_number (2), Qnil
);
1261 /* This holds the value of `environ' produced by the previous
1262 call to Fset_time_zone_rule, or 0 if Fset_time_zone_rule
1263 has never been called. */
1264 static char **environbuf
;
1266 DEFUN ("set-time-zone-rule", Fset_time_zone_rule
, Sset_time_zone_rule
, 1, 1, 0,
1267 "Set the local time zone using TZ, a string specifying a time zone rule.\n\
1268 If TZ is nil, use implementation-defined default time zone information.\n\
1269 If TZ is t, use Universal Time.")
1277 else if (EQ (tz
, Qt
))
1281 CHECK_STRING (tz
, 0);
1282 tzstring
= (char *) XSTRING (tz
)->data
;
1285 set_time_zone_rule (tzstring
);
1288 environbuf
= environ
;
1293 #ifdef LOCALTIME_CACHE
1295 /* These two values are known to load tz files in buggy implementations,
1296 i.e. Solaris 1 executables running under either Solaris 1 or Solaris 2.
1297 Their values shouldn't matter in non-buggy implementations.
1298 We don't use string literals for these strings,
1299 since if a string in the environment is in readonly
1300 storage, it runs afoul of bugs in SVR4 and Solaris 2.3.
1301 See Sun bugs 1113095 and 1114114, ``Timezone routines
1302 improperly modify environment''. */
1304 static char set_time_zone_rule_tz1
[] = "TZ=GMT+0";
1305 static char set_time_zone_rule_tz2
[] = "TZ=GMT+1";
1309 /* Set the local time zone rule to TZSTRING.
1310 This allocates memory into `environ', which it is the caller's
1311 responsibility to free. */
1313 set_time_zone_rule (tzstring
)
1317 char **from
, **to
, **newenv
;
1319 /* Make the ENVIRON vector longer with room for TZSTRING. */
1320 for (from
= environ
; *from
; from
++)
1322 envptrs
= from
- environ
+ 2;
1323 newenv
= to
= (char **) xmalloc (envptrs
* sizeof (char *)
1324 + (tzstring
? strlen (tzstring
) + 4 : 0));
1326 /* Add TZSTRING to the end of environ, as a value for TZ. */
1329 char *t
= (char *) (to
+ envptrs
);
1331 strcat (t
, tzstring
);
1335 /* Copy the old environ vector elements into NEWENV,
1336 but don't copy the TZ variable.
1337 So we have only one definition of TZ, which came from TZSTRING. */
1338 for (from
= environ
; *from
; from
++)
1339 if (strncmp (*from
, "TZ=", 3) != 0)
1345 /* If we do have a TZSTRING, NEWENV points to the vector slot where
1346 the TZ variable is stored. If we do not have a TZSTRING,
1347 TO points to the vector slot which has the terminating null. */
1349 #ifdef LOCALTIME_CACHE
1351 /* In SunOS 4.1.3_U1 and 4.1.4, if TZ has a value like
1352 "US/Pacific" that loads a tz file, then changes to a value like
1353 "XXX0" that does not load a tz file, and then changes back to
1354 its original value, the last change is (incorrectly) ignored.
1355 Also, if TZ changes twice in succession to values that do
1356 not load a tz file, tzset can dump core (see Sun bug#1225179).
1357 The following code works around these bugs. */
1361 /* Temporarily set TZ to a value that loads a tz file
1362 and that differs from tzstring. */
1364 *newenv
= (strcmp (tzstring
, set_time_zone_rule_tz1
+ 3) == 0
1365 ? set_time_zone_rule_tz2
: set_time_zone_rule_tz1
);
1371 /* The implied tzstring is unknown, so temporarily set TZ to
1372 two different values that each load a tz file. */
1373 *to
= set_time_zone_rule_tz1
;
1376 *to
= set_time_zone_rule_tz2
;
1381 /* Now TZ has the desired value, and tzset can be invoked safely. */
1388 /* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC
1389 (if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a
1390 type of object is Lisp_String). INHERIT is passed to
1391 INSERT_FROM_STRING_FUNC as the last argument. */
1394 general_insert_function (insert_func
, insert_from_string_func
,
1395 inherit
, nargs
, args
)
1396 void (*insert_func
) P_ ((unsigned char *, int));
1397 void (*insert_from_string_func
) P_ ((Lisp_Object
, int, int, int, int, int));
1399 register Lisp_Object
*args
;
1401 register int argnum
;
1402 register Lisp_Object val
;
1404 for (argnum
= 0; argnum
< nargs
; argnum
++)
1410 unsigned char workbuf
[4], *str
;
1413 if (!NILP (current_buffer
->enable_multibyte_characters
))
1414 len
= CHAR_STRING (XFASTINT (val
), workbuf
, str
);
1417 workbuf
[0] = (SINGLE_BYTE_CHAR_P (XINT (val
))
1419 : multibyte_char_to_unibyte (XINT (val
), Qnil
));
1423 (*insert_func
) (str
, len
);
1425 else if (STRINGP (val
))
1427 (*insert_from_string_func
) (val
, 0, 0,
1428 XSTRING (val
)->size
,
1429 STRING_BYTES (XSTRING (val
)),
1434 val
= wrong_type_argument (Qchar_or_string_p
, val
);
1448 /* Callers passing one argument to Finsert need not gcpro the
1449 argument "array", since the only element of the array will
1450 not be used after calling insert or insert_from_string, so
1451 we don't care if it gets trashed. */
1453 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
1454 "Insert the arguments, either strings or characters, at point.\n\
1455 Point and before-insertion markers move forward to end up\n\
1456 after the inserted text.\n\
1457 Any other markers at the point of insertion remain before the text.\n\
1459 If the current buffer is multibyte, unibyte strings are converted\n\
1460 to multibyte for insertion (see `unibyte-char-to-multibyte').\n\
1461 If the current buffer is unibyte, multibyte strings are converted\n\
1462 to unibyte for insertion.")
1465 register Lisp_Object
*args
;
1467 general_insert_function (insert
, insert_from_string
, 0, nargs
, args
);
1471 DEFUN ("insert-and-inherit", Finsert_and_inherit
, Sinsert_and_inherit
,
1473 "Insert the arguments at point, inheriting properties from adjoining text.\n\
1474 Point and before-insertion markers move forward to end up\n\
1475 after the inserted text.\n\
1476 Any other markers at the point of insertion remain before the text.\n\
1478 If the current buffer is multibyte, unibyte strings are converted\n\
1479 to multibyte for insertion (see `unibyte-char-to-multibyte').\n\
1480 If the current buffer is unibyte, multibyte strings are converted\n\
1481 to unibyte for insertion.")
1484 register Lisp_Object
*args
;
1486 general_insert_function (insert_and_inherit
, insert_from_string
, 1,
1491 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
1492 "Insert strings or characters at point, relocating markers after the text.\n\
1493 Point and markers move forward to end up after the inserted text.\n\
1495 If the current buffer is multibyte, unibyte strings are converted\n\
1496 to multibyte for insertion (see `unibyte-char-to-multibyte').\n\
1497 If the current buffer is unibyte, multibyte strings are converted\n\
1498 to unibyte for insertion.")
1501 register Lisp_Object
*args
;
1503 general_insert_function (insert_before_markers
,
1504 insert_from_string_before_markers
, 0,
1509 DEFUN ("insert-before-markers-and-inherit", Finsert_and_inherit_before_markers
,
1510 Sinsert_and_inherit_before_markers
, 0, MANY
, 0,
1511 "Insert text at point, relocating markers and inheriting properties.\n\
1512 Point and markers move forward to end up after the inserted text.\n\
1514 If the current buffer is multibyte, unibyte strings are converted\n\
1515 to multibyte for insertion (see `unibyte-char-to-multibyte').\n\
1516 If the current buffer is unibyte, multibyte strings are converted\n\
1517 to unibyte for insertion.")
1520 register Lisp_Object
*args
;
1522 general_insert_function (insert_before_markers_and_inherit
,
1523 insert_from_string_before_markers
, 1,
1528 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 2, 3, 0,
1529 "Insert COUNT (second arg) copies of CHARACTER (first arg).\n\
1530 Both arguments are required.\n\
1531 Point, and before-insertion markers, are relocated as in the function `insert'.\n\
1532 The optional third arg INHERIT, if non-nil, says to inherit text properties\n\
1533 from adjoining text, if those properties are sticky.")
1534 (character
, count
, inherit
)
1535 Lisp_Object character
, count
, inherit
;
1537 register unsigned char *string
;
1538 register int strlen
;
1541 unsigned char workbuf
[4], *str
;
1543 CHECK_NUMBER (character
, 0);
1544 CHECK_NUMBER (count
, 1);
1546 if (!NILP (current_buffer
->enable_multibyte_characters
))
1547 len
= CHAR_STRING (XFASTINT (character
), workbuf
, str
);
1549 workbuf
[0] = XFASTINT (character
), str
= workbuf
, len
= 1;
1550 n
= XINT (count
) * len
;
1553 strlen
= min (n
, 256 * len
);
1554 string
= (unsigned char *) alloca (strlen
);
1555 for (i
= 0; i
< strlen
; i
++)
1556 string
[i
] = str
[i
% len
];
1560 if (!NILP (inherit
))
1561 insert_and_inherit (string
, strlen
);
1563 insert (string
, strlen
);
1568 if (!NILP (inherit
))
1569 insert_and_inherit (string
, n
);
1577 /* Making strings from buffer contents. */
1579 /* Return a Lisp_String containing the text of the current buffer from
1580 START to END. If text properties are in use and the current buffer
1581 has properties in the range specified, the resulting string will also
1582 have them, if PROPS is nonzero.
1584 We don't want to use plain old make_string here, because it calls
1585 make_uninit_string, which can cause the buffer arena to be
1586 compacted. make_string has no way of knowing that the data has
1587 been moved, and thus copies the wrong data into the string. This
1588 doesn't effect most of the other users of make_string, so it should
1589 be left as is. But we should use this function when conjuring
1590 buffer substrings. */
1593 make_buffer_string (start
, end
, props
)
1597 int start_byte
= CHAR_TO_BYTE (start
);
1598 int end_byte
= CHAR_TO_BYTE (end
);
1600 return make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
);
1603 /* Return a Lisp_String containing the text of the current buffer from
1604 START / START_BYTE to END / END_BYTE.
1606 If text properties are in use and the current buffer
1607 has properties in the range specified, the resulting string will also
1608 have them, if PROPS is nonzero.
1610 We don't want to use plain old make_string here, because it calls
1611 make_uninit_string, which can cause the buffer arena to be
1612 compacted. make_string has no way of knowing that the data has
1613 been moved, and thus copies the wrong data into the string. This
1614 doesn't effect most of the other users of make_string, so it should
1615 be left as is. But we should use this function when conjuring
1616 buffer substrings. */
1619 make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
)
1620 int start
, start_byte
, end
, end_byte
;
1623 Lisp_Object result
, tem
, tem1
;
1625 if (start
< GPT
&& GPT
< end
)
1628 if (! NILP (current_buffer
->enable_multibyte_characters
))
1629 result
= make_uninit_multibyte_string (end
- start
, end_byte
- start_byte
);
1631 result
= make_uninit_string (end
- start
);
1632 bcopy (BYTE_POS_ADDR (start_byte
), XSTRING (result
)->data
,
1633 end_byte
- start_byte
);
1635 /* If desired, update and copy the text properties. */
1636 #ifdef USE_TEXT_PROPERTIES
1639 update_buffer_properties (start
, end
);
1641 tem
= Fnext_property_change (make_number (start
), Qnil
, make_number (end
));
1642 tem1
= Ftext_properties_at (make_number (start
), Qnil
);
1644 if (XINT (tem
) != end
|| !NILP (tem1
))
1645 copy_intervals_to_string (result
, current_buffer
, start
,
1653 /* Call Vbuffer_access_fontify_functions for the range START ... END
1654 in the current buffer, if necessary. */
1657 update_buffer_properties (start
, end
)
1660 #ifdef USE_TEXT_PROPERTIES
1661 /* If this buffer has some access functions,
1662 call them, specifying the range of the buffer being accessed. */
1663 if (!NILP (Vbuffer_access_fontify_functions
))
1665 Lisp_Object args
[3];
1668 args
[0] = Qbuffer_access_fontify_functions
;
1669 XSETINT (args
[1], start
);
1670 XSETINT (args
[2], end
);
1672 /* But don't call them if we can tell that the work
1673 has already been done. */
1674 if (!NILP (Vbuffer_access_fontified_property
))
1676 tem
= Ftext_property_any (args
[1], args
[2],
1677 Vbuffer_access_fontified_property
,
1680 Frun_hook_with_args (3, args
);
1683 Frun_hook_with_args (3, args
);
1688 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
1689 "Return the contents of part of the current buffer as a string.\n\
1690 The two arguments START and END are character positions;\n\
1691 they can be in either order.\n\
1692 The string returned is multibyte if the buffer is multibyte.")
1694 Lisp_Object start
, end
;
1698 validate_region (&start
, &end
);
1702 return make_buffer_string (b
, e
, 1);
1705 DEFUN ("buffer-substring-no-properties", Fbuffer_substring_no_properties
,
1706 Sbuffer_substring_no_properties
, 2, 2, 0,
1707 "Return the characters of part of the buffer, without the text properties.\n\
1708 The two arguments START and END are character positions;\n\
1709 they can be in either order.")
1711 Lisp_Object start
, end
;
1715 validate_region (&start
, &end
);
1719 return make_buffer_string (b
, e
, 0);
1722 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
1723 "Return the contents of the current buffer as a string.\n\
1724 If narrowing is in effect, this function returns only the visible part\n\
1725 of the buffer. If in a mini-buffer, don't include the prompt in the\n\
1731 if (INTEGERP (current_buffer
->prompt_end_charpos
))
1733 int len
= XFASTINT (current_buffer
->prompt_end_charpos
);
1734 start
= min (ZV
, max (len
, start
));
1737 return make_buffer_string (start
, ZV
, 1);
1740 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
1742 "Insert before point a substring of the contents of buffer BUFFER.\n\
1743 BUFFER may be a buffer or a buffer name.\n\
1744 Arguments START and END are character numbers specifying the substring.\n\
1745 They default to the beginning and the end of BUFFER.")
1747 Lisp_Object buf
, start
, end
;
1749 register int b
, e
, temp
;
1750 register struct buffer
*bp
, *obuf
;
1753 buffer
= Fget_buffer (buf
);
1756 bp
= XBUFFER (buffer
);
1757 if (NILP (bp
->name
))
1758 error ("Selecting deleted buffer");
1764 CHECK_NUMBER_COERCE_MARKER (start
, 0);
1771 CHECK_NUMBER_COERCE_MARKER (end
, 1);
1776 temp
= b
, b
= e
, e
= temp
;
1778 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
1779 args_out_of_range (start
, end
);
1781 obuf
= current_buffer
;
1782 set_buffer_internal_1 (bp
);
1783 update_buffer_properties (b
, e
);
1784 set_buffer_internal_1 (obuf
);
1786 insert_from_buffer (bp
, b
, e
- b
, 0);
1790 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
1792 "Compare two substrings of two buffers; return result as number.\n\
1793 the value is -N if first string is less after N-1 chars,\n\
1794 +N if first string is greater after N-1 chars, or 0 if strings match.\n\
1795 Each substring is represented as three arguments: BUFFER, START and END.\n\
1796 That makes six args in all, three for each substring.\n\n\
1797 The value of `case-fold-search' in the current buffer\n\
1798 determines whether case is significant or ignored.")
1799 (buffer1
, start1
, end1
, buffer2
, start2
, end2
)
1800 Lisp_Object buffer1
, start1
, end1
, buffer2
, start2
, end2
;
1802 register int begp1
, endp1
, begp2
, endp2
, temp
;
1803 register struct buffer
*bp1
, *bp2
;
1804 register Lisp_Object
*trt
1805 = (!NILP (current_buffer
->case_fold_search
)
1806 ? XCHAR_TABLE (current_buffer
->case_canon_table
)->contents
: 0);
1808 int i1
, i2
, i1_byte
, i2_byte
;
1810 /* Find the first buffer and its substring. */
1813 bp1
= current_buffer
;
1817 buf1
= Fget_buffer (buffer1
);
1820 bp1
= XBUFFER (buf1
);
1821 if (NILP (bp1
->name
))
1822 error ("Selecting deleted buffer");
1826 begp1
= BUF_BEGV (bp1
);
1829 CHECK_NUMBER_COERCE_MARKER (start1
, 1);
1830 begp1
= XINT (start1
);
1833 endp1
= BUF_ZV (bp1
);
1836 CHECK_NUMBER_COERCE_MARKER (end1
, 2);
1837 endp1
= XINT (end1
);
1841 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
1843 if (!(BUF_BEGV (bp1
) <= begp1
1845 && endp1
<= BUF_ZV (bp1
)))
1846 args_out_of_range (start1
, end1
);
1848 /* Likewise for second substring. */
1851 bp2
= current_buffer
;
1855 buf2
= Fget_buffer (buffer2
);
1858 bp2
= XBUFFER (buf2
);
1859 if (NILP (bp2
->name
))
1860 error ("Selecting deleted buffer");
1864 begp2
= BUF_BEGV (bp2
);
1867 CHECK_NUMBER_COERCE_MARKER (start2
, 4);
1868 begp2
= XINT (start2
);
1871 endp2
= BUF_ZV (bp2
);
1874 CHECK_NUMBER_COERCE_MARKER (end2
, 5);
1875 endp2
= XINT (end2
);
1879 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
1881 if (!(BUF_BEGV (bp2
) <= begp2
1883 && endp2
<= BUF_ZV (bp2
)))
1884 args_out_of_range (start2
, end2
);
1888 i1_byte
= buf_charpos_to_bytepos (bp1
, i1
);
1889 i2_byte
= buf_charpos_to_bytepos (bp2
, i2
);
1891 while (i1
< endp1
&& i2
< endp2
)
1893 /* When we find a mismatch, we must compare the
1894 characters, not just the bytes. */
1897 if (! NILP (bp1
->enable_multibyte_characters
))
1899 c1
= BUF_FETCH_MULTIBYTE_CHAR (bp1
, i1_byte
);
1900 BUF_INC_POS (bp1
, i1_byte
);
1905 c1
= BUF_FETCH_BYTE (bp1
, i1
);
1906 c1
= unibyte_char_to_multibyte (c1
);
1910 if (! NILP (bp2
->enable_multibyte_characters
))
1912 c2
= BUF_FETCH_MULTIBYTE_CHAR (bp2
, i2_byte
);
1913 BUF_INC_POS (bp2
, i2_byte
);
1918 c2
= BUF_FETCH_BYTE (bp2
, i2
);
1919 c2
= unibyte_char_to_multibyte (c2
);
1925 c1
= XINT (trt
[c1
]);
1926 c2
= XINT (trt
[c2
]);
1929 return make_number (- 1 - chars
);
1931 return make_number (chars
+ 1);
1936 /* The strings match as far as they go.
1937 If one is shorter, that one is less. */
1938 if (chars
< endp1
- begp1
)
1939 return make_number (chars
+ 1);
1940 else if (chars
< endp2
- begp2
)
1941 return make_number (- chars
- 1);
1943 /* Same length too => they are equal. */
1944 return make_number (0);
1948 subst_char_in_region_unwind (arg
)
1951 return current_buffer
->undo_list
= arg
;
1955 subst_char_in_region_unwind_1 (arg
)
1958 return current_buffer
->filename
= arg
;
1961 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
1962 Ssubst_char_in_region
, 4, 5, 0,
1963 "From START to END, replace FROMCHAR with TOCHAR each time it occurs.\n\
1964 If optional arg NOUNDO is non-nil, don't record this change for undo\n\
1965 and don't mark the buffer as really changed.\n\
1966 Both characters must have the same length of multi-byte form.")
1967 (start
, end
, fromchar
, tochar
, noundo
)
1968 Lisp_Object start
, end
, fromchar
, tochar
, noundo
;
1970 register int pos
, pos_byte
, stop
, i
, len
, end_byte
;
1972 unsigned char fromwork
[4], *fromstr
, towork
[4], *tostr
, *p
;
1973 int count
= specpdl_ptr
- specpdl
;
1974 #define COMBINING_NO 0
1975 #define COMBINING_BEFORE 1
1976 #define COMBINING_AFTER 2
1977 #define COMBINING_BOTH (COMBINING_BEFORE | COMBINING_AFTER)
1978 int maybe_byte_combining
= COMBINING_NO
;
1980 validate_region (&start
, &end
);
1981 CHECK_NUMBER (fromchar
, 2);
1982 CHECK_NUMBER (tochar
, 3);
1984 if (! NILP (current_buffer
->enable_multibyte_characters
))
1986 len
= CHAR_STRING (XFASTINT (fromchar
), fromwork
, fromstr
);
1987 if (CHAR_STRING (XFASTINT (tochar
), towork
, tostr
) != len
)
1988 error ("Characters in subst-char-in-region have different byte-lengths");
1989 if (!ASCII_BYTE_P (*tostr
))
1991 /* If *TOSTR is in the range 0x80..0x9F and TOCHAR is not a
1992 complete multibyte character, it may be combined with the
1993 after bytes. If it is in the range 0xA0..0xFF, it may be
1994 combined with the before and after bytes. */
1995 if (!CHAR_HEAD_P (*tostr
))
1996 maybe_byte_combining
= COMBINING_BOTH
;
1997 else if (BYTES_BY_CHAR_HEAD (*tostr
) > len
)
1998 maybe_byte_combining
= COMBINING_AFTER
;
2004 fromwork
[0] = XFASTINT (fromchar
), fromstr
= fromwork
;
2005 towork
[0] = XFASTINT (tochar
), tostr
= towork
;
2009 pos_byte
= CHAR_TO_BYTE (pos
);
2010 stop
= CHAR_TO_BYTE (XINT (end
));
2013 /* If we don't want undo, turn off putting stuff on the list.
2014 That's faster than getting rid of things,
2015 and it prevents even the entry for a first change.
2016 Also inhibit locking the file. */
2019 record_unwind_protect (subst_char_in_region_unwind
,
2020 current_buffer
->undo_list
);
2021 current_buffer
->undo_list
= Qt
;
2022 /* Don't do file-locking. */
2023 record_unwind_protect (subst_char_in_region_unwind_1
,
2024 current_buffer
->filename
);
2025 current_buffer
->filename
= Qnil
;
2028 if (pos_byte
< GPT_BYTE
)
2029 stop
= min (stop
, GPT_BYTE
);
2032 int pos_byte_next
= pos_byte
;
2034 if (pos_byte
>= stop
)
2036 if (pos_byte
>= end_byte
) break;
2039 p
= BYTE_POS_ADDR (pos_byte
);
2040 INC_POS (pos_byte_next
);
2041 if (pos_byte_next
- pos_byte
== len
2042 && p
[0] == fromstr
[0]
2044 || (p
[1] == fromstr
[1]
2045 && (len
== 2 || (p
[2] == fromstr
[2]
2046 && (len
== 3 || p
[3] == fromstr
[3]))))))
2050 modify_region (current_buffer
, XINT (start
), XINT (end
));
2052 if (! NILP (noundo
))
2054 if (MODIFF
- 1 == SAVE_MODIFF
)
2056 if (MODIFF
- 1 == current_buffer
->auto_save_modified
)
2057 current_buffer
->auto_save_modified
++;
2063 /* Take care of the case where the new character
2064 combines with neighboring bytes. */
2065 if (maybe_byte_combining
2066 && (maybe_byte_combining
== COMBINING_AFTER
2067 ? (pos_byte_next
< Z_BYTE
2068 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2069 : ((pos_byte_next
< Z_BYTE
2070 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2071 || (pos_byte
> BEG_BYTE
2072 && ! ASCII_BYTE_P (FETCH_BYTE (pos_byte
- 1))))))
2074 Lisp_Object tem
, string
;
2076 struct gcpro gcpro1
;
2078 tem
= current_buffer
->undo_list
;
2081 /* Make a multibyte string containing this single character. */
2082 string
= make_multibyte_string (tostr
, 1, len
);
2083 /* replace_range is less efficient, because it moves the gap,
2084 but it handles combining correctly. */
2085 replace_range (pos
, pos
+ 1, string
,
2087 pos_byte_next
= CHAR_TO_BYTE (pos
);
2088 if (pos_byte_next
> pos_byte
)
2089 /* Before combining happened. We should not increment
2090 POS. So, to cancel the later increment of POS,
2094 INC_POS (pos_byte_next
);
2096 if (! NILP (noundo
))
2097 current_buffer
->undo_list
= tem
;
2104 record_change (pos
, 1);
2105 for (i
= 0; i
< len
; i
++) *p
++ = tostr
[i
];
2108 pos_byte
= pos_byte_next
;
2113 signal_after_change (XINT (start
),
2114 XINT (end
) - XINT (start
), XINT (end
) - XINT (start
));
2116 unbind_to (count
, Qnil
);
2120 DEFUN ("translate-region", Ftranslate_region
, Stranslate_region
, 3, 3, 0,
2121 "From START to END, translate characters according to TABLE.\n\
2122 TABLE is a string; the Nth character in it is the mapping\n\
2123 for the character with code N.\n\
2124 This function does not alter multibyte characters.\n\
2125 It returns the number of characters changed.")
2129 register Lisp_Object table
;
2131 register int pos_byte
, stop
; /* Limits of the region. */
2132 register unsigned char *tt
; /* Trans table. */
2133 register int nc
; /* New character. */
2134 int cnt
; /* Number of changes made. */
2135 int size
; /* Size of translate table. */
2138 validate_region (&start
, &end
);
2139 CHECK_STRING (table
, 2);
2141 size
= STRING_BYTES (XSTRING (table
));
2142 tt
= XSTRING (table
)->data
;
2144 pos_byte
= CHAR_TO_BYTE (XINT (start
));
2145 stop
= CHAR_TO_BYTE (XINT (end
));
2146 modify_region (current_buffer
, XINT (start
), XINT (end
));
2150 for (; pos_byte
< stop
; )
2152 register unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
2157 oc
= STRING_CHAR_AND_LENGTH (p
, stop
- pos_byte
, len
);
2158 pos_byte_next
= pos_byte
+ len
;
2159 if (oc
< size
&& len
== 1)
2164 /* Take care of the case where the new character
2165 combines with neighboring bytes. */
2166 if (!ASCII_BYTE_P (nc
)
2167 && (CHAR_HEAD_P (nc
)
2168 ? ! CHAR_HEAD_P (FETCH_BYTE (pos_byte
+ 1))
2169 : (pos_byte
> BEG_BYTE
2170 && ! ASCII_BYTE_P (FETCH_BYTE (pos_byte
- 1)))))
2174 string
= make_multibyte_string (tt
+ oc
, 1, 1);
2175 /* This is less efficient, because it moves the gap,
2176 but it handles combining correctly. */
2177 replace_range (pos
, pos
+ 1, string
,
2179 pos_byte_next
= CHAR_TO_BYTE (pos
);
2180 if (pos_byte_next
> pos_byte
)
2181 /* Before combining happened. We should not
2182 increment POS. So, to cancel the later
2183 increment of POS, we decrease it now. */
2186 INC_POS (pos_byte_next
);
2190 record_change (pos
, 1);
2192 signal_after_change (pos
, 1, 1);
2197 pos_byte
= pos_byte_next
;
2201 return make_number (cnt
);
2204 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
2205 "Delete the text between point and mark.\n\
2206 When called from a program, expects two arguments,\n\
2207 positions (integers or markers) specifying the stretch to be deleted.")
2209 Lisp_Object start
, end
;
2211 validate_region (&start
, &end
);
2212 del_range (XINT (start
), XINT (end
));
2216 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
2217 "Remove restrictions (narrowing) from current buffer.\n\
2218 This allows the buffer's full text to be seen and edited.")
2221 if (BEG
!= BEGV
|| Z
!= ZV
)
2222 current_buffer
->clip_changed
= 1;
2224 BEGV_BYTE
= BEG_BYTE
;
2225 SET_BUF_ZV_BOTH (current_buffer
, Z
, Z_BYTE
);
2226 /* Changing the buffer bounds invalidates any recorded current column. */
2227 invalidate_current_column ();
2231 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
2232 "Restrict editing in this buffer to the current region.\n\
2233 The rest of the text becomes temporarily invisible and untouchable\n\
2234 but is not deleted; if you save the buffer in a file, the invisible\n\
2235 text is included in the file. \\[widen] makes all visible again.\n\
2236 See also `save-restriction'.\n\
2238 When calling from a program, pass two arguments; positions (integers\n\
2239 or markers) bounding the text that should remain visible.")
2241 register Lisp_Object start
, end
;
2243 CHECK_NUMBER_COERCE_MARKER (start
, 0);
2244 CHECK_NUMBER_COERCE_MARKER (end
, 1);
2246 if (XINT (start
) > XINT (end
))
2249 tem
= start
; start
= end
; end
= tem
;
2252 if (!(BEG
<= XINT (start
) && XINT (start
) <= XINT (end
) && XINT (end
) <= Z
))
2253 args_out_of_range (start
, end
);
2255 if (BEGV
!= XFASTINT (start
) || ZV
!= XFASTINT (end
))
2256 current_buffer
->clip_changed
= 1;
2258 SET_BUF_BEGV (current_buffer
, XFASTINT (start
));
2259 SET_BUF_ZV (current_buffer
, XFASTINT (end
));
2260 if (PT
< XFASTINT (start
))
2261 SET_PT (XFASTINT (start
));
2262 if (PT
> XFASTINT (end
))
2263 SET_PT (XFASTINT (end
));
2264 /* Changing the buffer bounds invalidates any recorded current column. */
2265 invalidate_current_column ();
2270 save_restriction_save ()
2272 register Lisp_Object bottom
, top
;
2273 /* Note: I tried using markers here, but it does not win
2274 because insertion at the end of the saved region
2275 does not advance mh and is considered "outside" the saved region. */
2276 XSETFASTINT (bottom
, BEGV
- BEG
);
2277 XSETFASTINT (top
, Z
- ZV
);
2279 return Fcons (Fcurrent_buffer (), Fcons (bottom
, top
));
2283 save_restriction_restore (data
)
2286 register struct buffer
*buf
;
2287 register int newhead
, newtail
;
2288 register Lisp_Object tem
;
2291 buf
= XBUFFER (XCONS (data
)->car
);
2293 data
= XCONS (data
)->cdr
;
2295 tem
= XCONS (data
)->car
;
2296 newhead
= XINT (tem
);
2297 tem
= XCONS (data
)->cdr
;
2298 newtail
= XINT (tem
);
2299 if (newhead
+ newtail
> BUF_Z (buf
) - BUF_BEG (buf
))
2305 obegv
= BUF_BEGV (buf
);
2308 SET_BUF_BEGV (buf
, BUF_BEG (buf
) + newhead
);
2309 SET_BUF_ZV (buf
, BUF_Z (buf
) - newtail
);
2311 if (obegv
!= BUF_BEGV (buf
) || ozv
!= BUF_ZV (buf
))
2312 current_buffer
->clip_changed
= 1;
2314 /* If point is outside the new visible range, move it inside. */
2315 SET_BUF_PT_BOTH (buf
,
2316 clip_to_bounds (BUF_BEGV (buf
), BUF_PT (buf
), BUF_ZV (buf
)),
2317 clip_to_bounds (BUF_BEGV_BYTE (buf
), BUF_PT_BYTE (buf
),
2318 BUF_ZV_BYTE (buf
)));
2323 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
2324 "Execute BODY, saving and restoring current buffer's restrictions.\n\
2325 The buffer's restrictions make parts of the beginning and end invisible.\n\
2326 \(They are set up with `narrow-to-region' and eliminated with `widen'.)\n\
2327 This special form, `save-restriction', saves the current buffer's restrictions\n\
2328 when it is entered, and restores them when it is exited.\n\
2329 So any `narrow-to-region' within BODY lasts only until the end of the form.\n\
2330 The old restrictions settings are restored\n\
2331 even in case of abnormal exit (throw or error).\n\
2333 The value returned is the value of the last form in BODY.\n\
2335 `save-restriction' can get confused if, within the BODY, you widen\n\
2336 and then make changes outside the area within the saved restrictions.\n\
2337 See Info node `(elisp)Narrowing' for details and an appropriate technique.\n\
2339 Note: if you are using both `save-excursion' and `save-restriction',\n\
2340 use `save-excursion' outermost:\n\
2341 (save-excursion (save-restriction ...))")
2345 register Lisp_Object val
;
2346 int count
= specpdl_ptr
- specpdl
;
2348 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
2349 val
= Fprogn (body
);
2350 return unbind_to (count
, val
);
2353 /* Buffer for the most recent text displayed by Fmessage. */
2354 static char *message_text
;
2356 /* Allocated length of that buffer. */
2357 static int message_length
;
2359 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
2360 "Print a one-line message at the bottom of the screen.\n\
2361 The first argument is a format control string, and the rest are data\n\
2362 to be formatted under control of the string. See `format' for details.\n\
2364 If the first argument is nil, clear any existing message; let the\n\
2365 minibuffer contents show.")
2377 register Lisp_Object val
;
2378 val
= Fformat (nargs
, args
);
2379 message3 (val
, STRING_BYTES (XSTRING (val
)), STRING_MULTIBYTE (val
));
2384 DEFUN ("message-box", Fmessage_box
, Smessage_box
, 1, MANY
, 0,
2385 "Display a message, in a dialog box if possible.\n\
2386 If a dialog box is not available, use the echo area.\n\
2387 The first argument is a format control string, and the rest are data\n\
2388 to be formatted under control of the string. See `format' for details.\n\
2390 If the first argument is nil, clear any existing message; let the\n\
2391 minibuffer contents show.")
2403 register Lisp_Object val
;
2404 val
= Fformat (nargs
, args
);
2407 Lisp_Object pane
, menu
, obj
;
2408 struct gcpro gcpro1
;
2409 pane
= Fcons (Fcons (build_string ("OK"), Qt
), Qnil
);
2411 menu
= Fcons (val
, pane
);
2412 obj
= Fx_popup_dialog (Qt
, menu
);
2416 #else /* not HAVE_MENUS */
2417 /* Copy the data so that it won't move when we GC. */
2420 message_text
= (char *)xmalloc (80);
2421 message_length
= 80;
2423 if (STRING_BYTES (XSTRING (val
)) > message_length
)
2425 message_length
= STRING_BYTES (XSTRING (val
));
2426 message_text
= (char *)xrealloc (message_text
, message_length
);
2428 bcopy (XSTRING (val
)->data
, message_text
, STRING_BYTES (XSTRING (val
)));
2429 message2 (message_text
, STRING_BYTES (XSTRING (val
)),
2430 STRING_MULTIBYTE (val
));
2432 #endif /* not HAVE_MENUS */
2436 extern Lisp_Object last_nonmenu_event
;
2439 DEFUN ("message-or-box", Fmessage_or_box
, Smessage_or_box
, 1, MANY
, 0,
2440 "Display a message in a dialog box or in the echo area.\n\
2441 If this command was invoked with the mouse, use a dialog box.\n\
2442 Otherwise, use the echo area.\n\
2443 The first argument is a format control string, and the rest are data\n\
2444 to be formatted under control of the string. See `format' for details.\n\
2446 If the first argument is nil, clear any existing message; let the\n\
2447 minibuffer contents show.")
2453 if (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2454 return Fmessage_box (nargs
, args
);
2456 return Fmessage (nargs
, args
);
2459 DEFUN ("current-message", Fcurrent_message
, Scurrent_message
, 0, 0, 0,
2460 "Return the string currently displayed in the echo area, or nil if none.")
2463 return current_message ();
2466 /* Number of bytes that STRING will occupy when put into the result.
2467 MULTIBYTE is nonzero if the result should be multibyte. */
2469 #define CONVERTED_BYTE_SIZE(MULTIBYTE, STRING) \
2470 (((MULTIBYTE) && ! STRING_MULTIBYTE (STRING)) \
2471 ? count_size_as_multibyte (XSTRING (STRING)->data, \
2472 STRING_BYTES (XSTRING (STRING))) \
2473 : STRING_BYTES (XSTRING (STRING)))
2475 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
2476 "Format a string out of a control-string and arguments.\n\
2477 The first argument is a control string.\n\
2478 The other arguments are substituted into it to make the result, a string.\n\
2479 It may contain %-sequences meaning to substitute the next argument.\n\
2480 %s means print a string argument. Actually, prints any object, with `princ'.\n\
2481 %d means print as number in decimal (%o octal, %x hex).\n\
2482 %e means print a number in exponential notation.\n\
2483 %f means print a number in decimal-point notation.\n\
2484 %g means print a number in exponential notation\n\
2485 or decimal-point notation, whichever uses fewer characters.\n\
2486 %c means print a number as a single character.\n\
2487 %S means print any object as an s-expression (using `prin1').\n\
2488 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.\n\
2489 Use %% to put a single % into the output.")
2492 register Lisp_Object
*args
;
2494 register int n
; /* The number of the next arg to substitute */
2495 register int total
; /* An estimate of the final length */
2497 register unsigned char *format
, *end
;
2499 /* Nonzero if the output should be a multibyte string,
2500 which is true if any of the inputs is one. */
2502 /* When we make a multibyte string, we must pay attention to the
2503 byte combining problem, i.e., a byte may be combined with a
2504 multibyte charcter of the previous string. This flag tells if we
2505 must consider such a situation or not. */
2506 int maybe_combine_byte
;
2507 unsigned char *this_format
;
2515 extern char *index ();
2517 /* It should not be necessary to GCPRO ARGS, because
2518 the caller in the interpreter should take care of that. */
2520 /* Try to determine whether the result should be multibyte.
2521 This is not always right; sometimes the result needs to be multibyte
2522 because of an object that we will pass through prin1,
2523 and in that case, we won't know it here. */
2524 for (n
= 0; n
< nargs
; n
++)
2525 if (STRINGP (args
[n
]) && STRING_MULTIBYTE (args
[n
]))
2528 CHECK_STRING (args
[0], 0);
2530 /* If we start out planning a unibyte result,
2531 and later find it has to be multibyte, we jump back to retry. */
2534 format
= XSTRING (args
[0])->data
;
2535 end
= format
+ STRING_BYTES (XSTRING (args
[0]));
2538 /* Make room in result for all the non-%-codes in the control string. */
2539 total
= 5 + CONVERTED_BYTE_SIZE (multibyte
, args
[0]);
2541 /* Add to TOTAL enough space to hold the converted arguments. */
2544 while (format
!= end
)
2545 if (*format
++ == '%')
2547 int minlen
, thissize
= 0;
2548 unsigned char *this_format_start
= format
- 1;
2550 /* Process a numeric arg and skip it. */
2551 minlen
= atoi (format
);
2555 while ((*format
>= '0' && *format
<= '9')
2556 || *format
== '-' || *format
== ' ' || *format
== '.')
2559 if (format
- this_format_start
+ 1 > longest_format
)
2560 longest_format
= format
- this_format_start
+ 1;
2563 error ("Format string ends in middle of format specifier");
2566 else if (++n
>= nargs
)
2567 error ("Not enough arguments for format string");
2568 else if (*format
== 'S')
2570 /* For `S', prin1 the argument and then treat like a string. */
2571 register Lisp_Object tem
;
2572 tem
= Fprin1_to_string (args
[n
], Qnil
);
2573 if (STRING_MULTIBYTE (tem
) && ! multibyte
)
2581 else if (SYMBOLP (args
[n
]))
2583 XSETSTRING (args
[n
], XSYMBOL (args
[n
])->name
);
2584 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
2591 else if (STRINGP (args
[n
]))
2594 if (*format
!= 's' && *format
!= 'S')
2595 error ("Format specifier doesn't match argument type");
2596 thissize
= CONVERTED_BYTE_SIZE (multibyte
, args
[n
]);
2598 /* Would get MPV otherwise, since Lisp_Int's `point' to low memory. */
2599 else if (INTEGERP (args
[n
]) && *format
!= 's')
2601 #ifdef LISP_FLOAT_TYPE
2602 /* The following loop assumes the Lisp type indicates
2603 the proper way to pass the argument.
2604 So make sure we have a flonum if the argument should
2606 if (*format
== 'e' || *format
== 'f' || *format
== 'g')
2607 args
[n
] = Ffloat (args
[n
]);
2610 if (*format
!= 'd' && *format
!= 'o' && *format
!= 'x'
2611 && *format
!= 'i' && *format
!= 'X' && *format
!= 'c')
2612 error ("Invalid format operation %%%c", *format
);
2616 && (! SINGLE_BYTE_CHAR_P (XINT (args
[n
]))
2617 || XINT (args
[n
]) == 0))
2624 args
[n
] = Fchar_to_string (args
[n
]);
2625 thissize
= STRING_BYTES (XSTRING (args
[n
]));
2628 #ifdef LISP_FLOAT_TYPE
2629 else if (FLOATP (args
[n
]) && *format
!= 's')
2631 if (! (*format
== 'e' || *format
== 'f' || *format
== 'g'))
2632 args
[n
] = Ftruncate (args
[n
], Qnil
);
2638 /* Anything but a string, convert to a string using princ. */
2639 register Lisp_Object tem
;
2640 tem
= Fprin1_to_string (args
[n
], Qt
);
2641 if (STRING_MULTIBYTE (tem
) & ! multibyte
)
2650 if (thissize
< minlen
)
2653 total
+= thissize
+ 4;
2656 /* Now we can no longer jump to retry.
2657 TOTAL and LONGEST_FORMAT are known for certain. */
2659 this_format
= (unsigned char *) alloca (longest_format
+ 1);
2661 /* Allocate the space for the result.
2662 Note that TOTAL is an overestimate. */
2664 buf
= (char *) alloca (total
+ 1);
2666 buf
= (char *) xmalloc (total
+ 1);
2672 /* Scan the format and store result in BUF. */
2673 format
= XSTRING (args
[0])->data
;
2674 maybe_combine_byte
= 0;
2675 while (format
!= end
)
2681 unsigned char *this_format_start
= format
;
2685 /* Process a numeric arg and skip it. */
2686 minlen
= atoi (format
);
2688 minlen
= - minlen
, negative
= 1;
2690 while ((*format
>= '0' && *format
<= '9')
2691 || *format
== '-' || *format
== ' ' || *format
== '.')
2694 if (*format
++ == '%')
2703 if (STRINGP (args
[n
]))
2705 int padding
, nbytes
;
2706 int width
= strwidth (XSTRING (args
[n
])->data
,
2707 STRING_BYTES (XSTRING (args
[n
])));
2710 /* If spec requires it, pad on right with spaces. */
2711 padding
= minlen
- width
;
2713 while (padding
-- > 0)
2721 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
2722 && STRING_MULTIBYTE (args
[n
])
2723 && !CHAR_HEAD_P (XSTRING (args
[n
])->data
[0]))
2724 maybe_combine_byte
= 1;
2725 nbytes
= copy_text (XSTRING (args
[n
])->data
, p
,
2726 STRING_BYTES (XSTRING (args
[n
])),
2727 STRING_MULTIBYTE (args
[n
]), multibyte
);
2729 nchars
+= XSTRING (args
[n
])->size
;
2732 while (padding
-- > 0)
2738 /* If this argument has text properties, record where
2739 in the result string it appears. */
2740 if (XSTRING (args
[n
])->intervals
)
2744 int nbytes
= nargs
* sizeof *info
;
2745 info
= (struct info
*) alloca (nbytes
);
2746 bzero (info
, nbytes
);
2749 info
[n
].start
= start
;
2750 info
[n
].end
= nchars
;
2753 else if (INTEGERP (args
[n
]) || FLOATP (args
[n
]))
2757 bcopy (this_format_start
, this_format
,
2758 format
- this_format_start
);
2759 this_format
[format
- this_format_start
] = 0;
2761 if (INTEGERP (args
[n
]))
2762 sprintf (p
, this_format
, XINT (args
[n
]));
2764 sprintf (p
, this_format
, XFLOAT (args
[n
])->data
);
2768 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
2769 && !CHAR_HEAD_P (*((unsigned char *) p
)))
2770 maybe_combine_byte
= 1;
2771 this_nchars
= strlen (p
);
2773 nchars
+= this_nchars
;
2776 else if (STRING_MULTIBYTE (args
[0]))
2778 /* Copy a whole multibyte character. */
2781 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
2782 && !CHAR_HEAD_P (*format
))
2783 maybe_combine_byte
= 1;
2785 while (! CHAR_HEAD_P (*format
)) *p
++ = *format
++;
2790 /* Convert a single-byte character to multibyte. */
2791 int len
= copy_text (format
, p
, 1, 0, 1);
2798 *p
++ = *format
++, nchars
++;
2801 if (maybe_combine_byte
)
2802 nchars
= multibyte_chars_in_text (buf
, p
- buf
);
2803 val
= make_specified_string (buf
, nchars
, p
- buf
, multibyte
);
2805 /* If we allocated BUF with malloc, free it too. */
2809 /* If the format string has text properties, or any of the string
2810 arguments has text properties, set up text properties of the
2813 if (XSTRING (args
[0])->intervals
|| info
)
2815 Lisp_Object len
, new_len
, props
;
2816 struct gcpro gcpro1
;
2818 /* Add text properties from the format string. */
2819 len
= make_number (XSTRING (args
[0])->size
);
2820 props
= text_property_list (args
[0], make_number (0), len
, Qnil
);
2825 new_len
= make_number (XSTRING (val
)->size
);
2826 extend_property_ranges (props
, len
, new_len
);
2827 add_text_properties_from_list (val
, props
, make_number (0));
2830 /* Add text properties from arguments. */
2832 for (n
= 1; n
< nargs
; ++n
)
2835 len
= make_number (XSTRING (args
[n
])->size
);
2836 new_len
= make_number (info
[n
].end
- info
[n
].start
);
2837 props
= text_property_list (args
[n
], make_number (0), len
, Qnil
);
2838 extend_property_ranges (props
, len
, new_len
);
2839 add_text_properties_from_list (val
, props
,
2840 make_number (info
[n
].start
));
2852 format1 (string1
, arg0
, arg1
, arg2
, arg3
, arg4
)
2853 EMACS_INT arg0
, arg1
, arg2
, arg3
, arg4
;
2867 doprnt (buf
, sizeof buf
, string1
, (char *)0, 5, (char **) args
);
2869 doprnt (buf
, sizeof buf
, string1
, (char *)0, 5, &string1
+ 1);
2871 return build_string (buf
);
2874 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
2875 "Return t if two characters match, optionally ignoring case.\n\
2876 Both arguments must be characters (i.e. integers).\n\
2877 Case is ignored if `case-fold-search' is non-nil in the current buffer.")
2879 register Lisp_Object c1
, c2
;
2882 CHECK_NUMBER (c1
, 0);
2883 CHECK_NUMBER (c2
, 1);
2885 if (XINT (c1
) == XINT (c2
))
2887 if (NILP (current_buffer
->case_fold_search
))
2890 /* Do these in separate statements,
2891 then compare the variables.
2892 because of the way DOWNCASE uses temp variables. */
2893 i1
= DOWNCASE (XFASTINT (c1
));
2894 i2
= DOWNCASE (XFASTINT (c2
));
2895 return (i1
== i2
? Qt
: Qnil
);
2898 /* Transpose the markers in two regions of the current buffer, and
2899 adjust the ones between them if necessary (i.e.: if the regions
2902 START1, END1 are the character positions of the first region.
2903 START1_BYTE, END1_BYTE are the byte positions.
2904 START2, END2 are the character positions of the second region.
2905 START2_BYTE, END2_BYTE are the byte positions.
2907 Traverses the entire marker list of the buffer to do so, adding an
2908 appropriate amount to some, subtracting from some, and leaving the
2909 rest untouched. Most of this is copied from adjust_markers in insdel.c.
2911 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
2914 transpose_markers (start1
, end1
, start2
, end2
,
2915 start1_byte
, end1_byte
, start2_byte
, end2_byte
)
2916 register int start1
, end1
, start2
, end2
;
2917 register int start1_byte
, end1_byte
, start2_byte
, end2_byte
;
2919 register int amt1
, amt1_byte
, amt2
, amt2_byte
, diff
, diff_byte
, mpos
;
2920 register Lisp_Object marker
;
2922 /* Update point as if it were a marker. */
2926 TEMP_SET_PT_BOTH (PT
+ (end2
- end1
),
2927 PT_BYTE
+ (end2_byte
- end1_byte
));
2928 else if (PT
< start2
)
2929 TEMP_SET_PT_BOTH (PT
+ (end2
- start2
) - (end1
- start1
),
2930 (PT_BYTE
+ (end2_byte
- start2_byte
)
2931 - (end1_byte
- start1_byte
)));
2933 TEMP_SET_PT_BOTH (PT
- (start2
- start1
),
2934 PT_BYTE
- (start2_byte
- start1_byte
));
2936 /* We used to adjust the endpoints here to account for the gap, but that
2937 isn't good enough. Even if we assume the caller has tried to move the
2938 gap out of our way, it might still be at start1 exactly, for example;
2939 and that places it `inside' the interval, for our purposes. The amount
2940 of adjustment is nontrivial if there's a `denormalized' marker whose
2941 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
2942 the dirty work to Fmarker_position, below. */
2944 /* The difference between the region's lengths */
2945 diff
= (end2
- start2
) - (end1
- start1
);
2946 diff_byte
= (end2_byte
- start2_byte
) - (end1_byte
- start1_byte
);
2948 /* For shifting each marker in a region by the length of the other
2949 region plus the distance between the regions. */
2950 amt1
= (end2
- start2
) + (start2
- end1
);
2951 amt2
= (end1
- start1
) + (start2
- end1
);
2952 amt1_byte
= (end2_byte
- start2_byte
) + (start2_byte
- end1_byte
);
2953 amt2_byte
= (end1_byte
- start1_byte
) + (start2_byte
- end1_byte
);
2955 for (marker
= BUF_MARKERS (current_buffer
); !NILP (marker
);
2956 marker
= XMARKER (marker
)->chain
)
2958 mpos
= marker_byte_position (marker
);
2959 if (mpos
>= start1_byte
&& mpos
< end2_byte
)
2961 if (mpos
< end1_byte
)
2963 else if (mpos
< start2_byte
)
2967 XMARKER (marker
)->bytepos
= mpos
;
2969 mpos
= XMARKER (marker
)->charpos
;
2970 if (mpos
>= start1
&& mpos
< end2
)
2974 else if (mpos
< start2
)
2979 XMARKER (marker
)->charpos
= mpos
;
2983 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
2984 "Transpose region START1 to END1 with START2 to END2.\n\
2985 The regions may not be overlapping, because the size of the buffer is\n\
2986 never changed in a transposition.\n\
2988 Optional fifth arg LEAVE_MARKERS, if non-nil, means don't update\n\
2989 any markers that happen to be located in the regions.\n\
2991 Transposing beyond buffer boundaries is an error.")
2992 (startr1
, endr1
, startr2
, endr2
, leave_markers
)
2993 Lisp_Object startr1
, endr1
, startr2
, endr2
, leave_markers
;
2995 register int start1
, end1
, start2
, end2
;
2996 int start1_byte
, start2_byte
, len1_byte
, len2_byte
;
2997 int gap
, len1
, len_mid
, len2
;
2998 unsigned char *start1_addr
, *start2_addr
, *temp
;
2999 int combined_before_bytes_1
, combined_after_bytes_1
;
3000 int combined_before_bytes_2
, combined_after_bytes_2
;
3001 struct gcpro gcpro1
, gcpro2
;
3003 #ifdef USE_TEXT_PROPERTIES
3004 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
;
3005 cur_intv
= BUF_INTERVALS (current_buffer
);
3006 #endif /* USE_TEXT_PROPERTIES */
3008 validate_region (&startr1
, &endr1
);
3009 validate_region (&startr2
, &endr2
);
3011 start1
= XFASTINT (startr1
);
3012 end1
= XFASTINT (endr1
);
3013 start2
= XFASTINT (startr2
);
3014 end2
= XFASTINT (endr2
);
3017 /* Swap the regions if they're reversed. */
3020 register int glumph
= start1
;
3028 len1
= end1
- start1
;
3029 len2
= end2
- start2
;
3032 error ("Transposed regions overlap");
3033 else if (start1
== end1
|| start2
== end2
)
3034 error ("Transposed region has length 0");
3036 /* The possibilities are:
3037 1. Adjacent (contiguous) regions, or separate but equal regions
3038 (no, really equal, in this case!), or
3039 2. Separate regions of unequal size.
3041 The worst case is usually No. 2. It means that (aside from
3042 potential need for getting the gap out of the way), there also
3043 needs to be a shifting of the text between the two regions. So
3044 if they are spread far apart, we are that much slower... sigh. */
3046 /* It must be pointed out that the really studly thing to do would
3047 be not to move the gap at all, but to leave it in place and work
3048 around it if necessary. This would be extremely efficient,
3049 especially considering that people are likely to do
3050 transpositions near where they are working interactively, which
3051 is exactly where the gap would be found. However, such code
3052 would be much harder to write and to read. So, if you are
3053 reading this comment and are feeling squirrely, by all means have
3054 a go! I just didn't feel like doing it, so I will simply move
3055 the gap the minimum distance to get it out of the way, and then
3056 deal with an unbroken array. */
3058 /* Make sure the gap won't interfere, by moving it out of the text
3059 we will operate on. */
3060 if (start1
< gap
&& gap
< end2
)
3062 if (gap
- start1
< end2
- gap
)
3068 start1_byte
= CHAR_TO_BYTE (start1
);
3069 start2_byte
= CHAR_TO_BYTE (start2
);
3070 len1_byte
= CHAR_TO_BYTE (end1
) - start1_byte
;
3071 len2_byte
= CHAR_TO_BYTE (end2
) - start2_byte
;
3075 combined_before_bytes_2
3076 = count_combining_before (BYTE_POS_ADDR (start2_byte
),
3077 len2_byte
, start1
, start1_byte
);
3078 combined_before_bytes_1
3079 = count_combining_before (BYTE_POS_ADDR (start1_byte
),
3080 len1_byte
, end2
, start2_byte
+ len2_byte
);
3081 combined_after_bytes_1
3082 = count_combining_after (BYTE_POS_ADDR (start1_byte
),
3083 len1_byte
, end2
, start2_byte
+ len2_byte
);
3084 combined_after_bytes_2
= 0;
3088 combined_before_bytes_2
3089 = count_combining_before (BYTE_POS_ADDR (start2_byte
),
3090 len2_byte
, start1
, start1_byte
);
3091 combined_before_bytes_1
3092 = count_combining_before (BYTE_POS_ADDR (start1_byte
),
3093 len1_byte
, start2
, start2_byte
);
3094 combined_after_bytes_2
3095 = count_combining_after (BYTE_POS_ADDR (start2_byte
),
3096 len2_byte
, end1
, start1_byte
+ len1_byte
);
3097 combined_after_bytes_1
3098 = count_combining_after (BYTE_POS_ADDR (start1_byte
),
3099 len1_byte
, end2
, start2_byte
+ len2_byte
);
3102 /* If any combining is going to happen, do this the stupid way,
3103 because replace handles combining properly. */
3104 if (combined_before_bytes_1
|| combined_before_bytes_2
3105 || combined_after_bytes_1
|| combined_after_bytes_2
)
3107 Lisp_Object text1
, text2
;
3109 text1
= text2
= Qnil
;
3110 GCPRO2 (text1
, text2
);
3112 text1
= make_buffer_string_both (start1
, start1_byte
,
3113 end1
, start1_byte
+ len1_byte
, 1);
3114 text2
= make_buffer_string_both (start2
, start2_byte
,
3115 end2
, start2_byte
+ len2_byte
, 1);
3117 transpose_markers (start1
, end1
, start2
, end2
,
3118 start1_byte
, start1_byte
+ len1_byte
,
3119 start2_byte
, start2_byte
+ len2_byte
);
3121 replace_range (start2
, end2
, text1
, 1, 0, 0);
3122 replace_range (start1
, end1
, text2
, 1, 0, 0);
3128 /* Hmmm... how about checking to see if the gap is large
3129 enough to use as the temporary storage? That would avoid an
3130 allocation... interesting. Later, don't fool with it now. */
3132 /* Working without memmove, for portability (sigh), so must be
3133 careful of overlapping subsections of the array... */
3135 if (end1
== start2
) /* adjacent regions */
3137 modify_region (current_buffer
, start1
, end2
);
3138 record_change (start1
, len1
+ len2
);
3140 #ifdef USE_TEXT_PROPERTIES
3141 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
3142 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
3143 Fset_text_properties (make_number (start1
), make_number (end2
),
3145 #endif /* USE_TEXT_PROPERTIES */
3147 /* First region smaller than second. */
3148 if (len1_byte
< len2_byte
)
3150 /* We use alloca only if it is small,
3151 because we want to avoid stack overflow. */
3152 if (len2_byte
> 20000)
3153 temp
= (unsigned char *) xmalloc (len2_byte
);
3155 temp
= (unsigned char *) alloca (len2_byte
);
3157 /* Don't precompute these addresses. We have to compute them
3158 at the last minute, because the relocating allocator might
3159 have moved the buffer around during the xmalloc. */
3160 start1_addr
= BYTE_POS_ADDR (start1_byte
);
3161 start2_addr
= BYTE_POS_ADDR (start2_byte
);
3163 bcopy (start2_addr
, temp
, len2_byte
);
3164 bcopy (start1_addr
, start1_addr
+ len2_byte
, len1_byte
);
3165 bcopy (temp
, start1_addr
, len2_byte
);
3166 if (len2_byte
> 20000)
3170 /* First region not smaller than second. */
3172 if (len1_byte
> 20000)
3173 temp
= (unsigned char *) xmalloc (len1_byte
);
3175 temp
= (unsigned char *) alloca (len1_byte
);
3176 start1_addr
= BYTE_POS_ADDR (start1_byte
);
3177 start2_addr
= BYTE_POS_ADDR (start2_byte
);
3178 bcopy (start1_addr
, temp
, len1_byte
);
3179 bcopy (start2_addr
, start1_addr
, len2_byte
);
3180 bcopy (temp
, start1_addr
+ len2_byte
, len1_byte
);
3181 if (len1_byte
> 20000)
3184 #ifdef USE_TEXT_PROPERTIES
3185 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
3186 len1
, current_buffer
, 0);
3187 graft_intervals_into_buffer (tmp_interval2
, start1
,
3188 len2
, current_buffer
, 0);
3189 #endif /* USE_TEXT_PROPERTIES */
3191 /* Non-adjacent regions, because end1 != start2, bleagh... */
3194 len_mid
= start2_byte
- (start1_byte
+ len1_byte
);
3196 if (len1_byte
== len2_byte
)
3197 /* Regions are same size, though, how nice. */
3199 modify_region (current_buffer
, start1
, end1
);
3200 modify_region (current_buffer
, start2
, end2
);
3201 record_change (start1
, len1
);
3202 record_change (start2
, len2
);
3203 #ifdef USE_TEXT_PROPERTIES
3204 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
3205 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
3206 Fset_text_properties (make_number (start1
), make_number (end1
),
3208 Fset_text_properties (make_number (start2
), make_number (end2
),
3210 #endif /* USE_TEXT_PROPERTIES */
3212 if (len1_byte
> 20000)
3213 temp
= (unsigned char *) xmalloc (len1_byte
);
3215 temp
= (unsigned char *) alloca (len1_byte
);
3216 start1_addr
= BYTE_POS_ADDR (start1_byte
);
3217 start2_addr
= BYTE_POS_ADDR (start2_byte
);
3218 bcopy (start1_addr
, temp
, len1_byte
);
3219 bcopy (start2_addr
, start1_addr
, len2_byte
);
3220 bcopy (temp
, start2_addr
, len1_byte
);
3221 if (len1_byte
> 20000)
3223 #ifdef USE_TEXT_PROPERTIES
3224 graft_intervals_into_buffer (tmp_interval1
, start2
,
3225 len1
, current_buffer
, 0);
3226 graft_intervals_into_buffer (tmp_interval2
, start1
,
3227 len2
, current_buffer
, 0);
3228 #endif /* USE_TEXT_PROPERTIES */
3231 else if (len1_byte
< len2_byte
) /* Second region larger than first */
3232 /* Non-adjacent & unequal size, area between must also be shifted. */
3234 modify_region (current_buffer
, start1
, end2
);
3235 record_change (start1
, (end2
- start1
));
3236 #ifdef USE_TEXT_PROPERTIES
3237 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
3238 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
3239 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
3240 Fset_text_properties (make_number (start1
), make_number (end2
),
3242 #endif /* USE_TEXT_PROPERTIES */
3244 /* holds region 2 */
3245 if (len2_byte
> 20000)
3246 temp
= (unsigned char *) xmalloc (len2_byte
);
3248 temp
= (unsigned char *) alloca (len2_byte
);
3249 start1_addr
= BYTE_POS_ADDR (start1_byte
);
3250 start2_addr
= BYTE_POS_ADDR (start2_byte
);
3251 bcopy (start2_addr
, temp
, len2_byte
);
3252 bcopy (start1_addr
, start1_addr
+ len_mid
+ len2_byte
, len1_byte
);
3253 safe_bcopy (start1_addr
+ len1_byte
, start1_addr
+ len2_byte
, len_mid
);
3254 bcopy (temp
, start1_addr
, len2_byte
);
3255 if (len2_byte
> 20000)
3257 #ifdef USE_TEXT_PROPERTIES
3258 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
3259 len1
, current_buffer
, 0);
3260 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
3261 len_mid
, current_buffer
, 0);
3262 graft_intervals_into_buffer (tmp_interval2
, start1
,
3263 len2
, current_buffer
, 0);
3264 #endif /* USE_TEXT_PROPERTIES */
3267 /* Second region smaller than first. */
3269 record_change (start1
, (end2
- start1
));
3270 modify_region (current_buffer
, start1
, end2
);
3272 #ifdef USE_TEXT_PROPERTIES
3273 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
3274 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
3275 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
3276 Fset_text_properties (make_number (start1
), make_number (end2
),
3278 #endif /* USE_TEXT_PROPERTIES */
3280 /* holds region 1 */
3281 if (len1_byte
> 20000)
3282 temp
= (unsigned char *) xmalloc (len1_byte
);
3284 temp
= (unsigned char *) alloca (len1_byte
);
3285 start1_addr
= BYTE_POS_ADDR (start1_byte
);
3286 start2_addr
= BYTE_POS_ADDR (start2_byte
);
3287 bcopy (start1_addr
, temp
, len1_byte
);
3288 bcopy (start2_addr
, start1_addr
, len2_byte
);
3289 bcopy (start1_addr
+ len1_byte
, start1_addr
+ len2_byte
, len_mid
);
3290 bcopy (temp
, start1_addr
+ len2_byte
+ len_mid
, len1_byte
);
3291 if (len1_byte
> 20000)
3293 #ifdef USE_TEXT_PROPERTIES
3294 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
3295 len1
, current_buffer
, 0);
3296 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
3297 len_mid
, current_buffer
, 0);
3298 graft_intervals_into_buffer (tmp_interval2
, start1
,
3299 len2
, current_buffer
, 0);
3300 #endif /* USE_TEXT_PROPERTIES */
3304 /* When doing multiple transpositions, it might be nice
3305 to optimize this. Perhaps the markers in any one buffer
3306 should be organized in some sorted data tree. */
3307 if (NILP (leave_markers
))
3309 transpose_markers (start1
, end1
, start2
, end2
,
3310 start1_byte
, start1_byte
+ len1_byte
,
3311 start2_byte
, start2_byte
+ len2_byte
);
3312 fix_overlays_in_range (start1
, end2
);
3324 Qbuffer_access_fontify_functions
3325 = intern ("buffer-access-fontify-functions");
3326 staticpro (&Qbuffer_access_fontify_functions
);
3328 DEFVAR_LISP ("buffer-access-fontify-functions",
3329 &Vbuffer_access_fontify_functions
,
3330 "List of functions called by `buffer-substring' to fontify if necessary.\n\
3331 Each function is called with two arguments which specify the range\n\
3332 of the buffer being accessed.");
3333 Vbuffer_access_fontify_functions
= Qnil
;
3337 extern Lisp_Object Vprin1_to_string_buffer
;
3338 obuf
= Fcurrent_buffer ();
3339 /* Do this here, because init_buffer_once is too early--it won't work. */
3340 Fset_buffer (Vprin1_to_string_buffer
);
3341 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
3342 Fset (Fmake_local_variable (intern ("buffer-access-fontify-functions")),
3347 DEFVAR_LISP ("buffer-access-fontified-property",
3348 &Vbuffer_access_fontified_property
,
3349 "Property which (if non-nil) indicates text has been fontified.\n\
3350 `buffer-substring' need not call the `buffer-access-fontify-functions'\n\
3351 functions if all the text being accessed has this property.");
3352 Vbuffer_access_fontified_property
= Qnil
;
3354 DEFVAR_LISP ("system-name", &Vsystem_name
,
3355 "The name of the machine Emacs is running on.");
3357 DEFVAR_LISP ("user-full-name", &Vuser_full_name
,
3358 "The full name of the user logged in.");
3360 DEFVAR_LISP ("user-login-name", &Vuser_login_name
,
3361 "The user's name, taken from environment variables if possible.");
3363 DEFVAR_LISP ("user-real-login-name", &Vuser_real_login_name
,
3364 "The user's name, based upon the real uid only.");
3366 defsubr (&Schar_equal
);
3367 defsubr (&Sgoto_char
);
3368 defsubr (&Sstring_to_char
);
3369 defsubr (&Schar_to_string
);
3370 defsubr (&Sbuffer_substring
);
3371 defsubr (&Sbuffer_substring_no_properties
);
3372 defsubr (&Sbuffer_string
);
3374 defsubr (&Spoint_marker
);
3375 defsubr (&Smark_marker
);
3377 defsubr (&Sregion_beginning
);
3378 defsubr (&Sregion_end
);
3380 defsubr (&Sline_beginning_position
);
3381 defsubr (&Sline_end_position
);
3383 /* defsubr (&Smark); */
3384 /* defsubr (&Sset_mark); */
3385 defsubr (&Ssave_excursion
);
3386 defsubr (&Ssave_current_buffer
);
3388 defsubr (&Sbufsize
);
3389 defsubr (&Spoint_max
);
3390 defsubr (&Spoint_min
);
3391 defsubr (&Spoint_min_marker
);
3392 defsubr (&Spoint_max_marker
);
3393 defsubr (&Sgap_position
);
3394 defsubr (&Sgap_size
);
3395 defsubr (&Sposition_bytes
);
3396 defsubr (&Sbyte_to_position
);
3402 defsubr (&Sfollowing_char
);
3403 defsubr (&Sprevious_char
);
3404 defsubr (&Schar_after
);
3405 defsubr (&Schar_before
);
3407 defsubr (&Sinsert_before_markers
);
3408 defsubr (&Sinsert_and_inherit
);
3409 defsubr (&Sinsert_and_inherit_before_markers
);
3410 defsubr (&Sinsert_char
);
3412 defsubr (&Suser_login_name
);
3413 defsubr (&Suser_real_login_name
);
3414 defsubr (&Suser_uid
);
3415 defsubr (&Suser_real_uid
);
3416 defsubr (&Suser_full_name
);
3417 defsubr (&Semacs_pid
);
3418 defsubr (&Scurrent_time
);
3419 defsubr (&Sformat_time_string
);
3420 defsubr (&Sdecode_time
);
3421 defsubr (&Sencode_time
);
3422 defsubr (&Scurrent_time_string
);
3423 defsubr (&Scurrent_time_zone
);
3424 defsubr (&Sset_time_zone_rule
);
3425 defsubr (&Ssystem_name
);
3426 defsubr (&Smessage
);
3427 defsubr (&Smessage_box
);
3428 defsubr (&Smessage_or_box
);
3429 defsubr (&Scurrent_message
);
3432 defsubr (&Sinsert_buffer_substring
);
3433 defsubr (&Scompare_buffer_substrings
);
3434 defsubr (&Ssubst_char_in_region
);
3435 defsubr (&Stranslate_region
);
3436 defsubr (&Sdelete_region
);
3438 defsubr (&Snarrow_to_region
);
3439 defsubr (&Ssave_restriction
);
3440 defsubr (&Stranspose_regions
);