1 /* Lisp functions pertaining to editing.
2 Copyright (C) 1985,86,87,89,93,94,95,96,97 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>
33 #include "intervals.h"
40 #define min(a, b) ((a) < (b) ? (a) : (b))
41 #define max(a, b) ((a) > (b) ? (a) : (b))
47 extern char **environ
;
48 extern Lisp_Object
make_time ();
49 extern void insert_from_buffer ();
50 static int tm_diff ();
51 static void update_buffer_properties ();
52 size_t emacs_strftime ();
53 void set_time_zone_rule ();
55 Lisp_Object Vbuffer_access_fontify_functions
;
56 Lisp_Object Qbuffer_access_fontify_functions
;
57 Lisp_Object Vbuffer_access_fontified_property
;
59 Lisp_Object
Fuser_full_name ();
61 /* Some static data, and a function to initialize it for each run */
63 Lisp_Object Vsystem_name
;
64 Lisp_Object Vuser_real_login_name
; /* login name of current user ID */
65 Lisp_Object Vuser_full_name
; /* full name of current user */
66 Lisp_Object Vuser_login_name
; /* user name from LOGNAME or USER */
72 register unsigned char *p
, *q
, *r
;
73 struct passwd
*pw
; /* password entry for the current user */
76 /* Set up system_name even when dumping. */
80 /* Don't bother with this on initial start when just dumping out */
83 #endif /* not CANNOT_DUMP */
85 pw
= (struct passwd
*) getpwuid (getuid ());
87 /* We let the real user name default to "root" because that's quite
88 accurate on MSDOG and because it lets Emacs find the init file.
89 (The DVX libraries override the Djgpp libraries here.) */
90 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "root");
92 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "unknown");
95 /* Get the effective user name, by consulting environment variables,
96 or the effective uid if those are unset. */
97 user_name
= (char *) getenv ("LOGNAME");
100 user_name
= (char *) getenv ("USERNAME"); /* it's USERNAME on NT */
101 #else /* WINDOWSNT */
102 user_name
= (char *) getenv ("USER");
103 #endif /* WINDOWSNT */
106 pw
= (struct passwd
*) getpwuid (geteuid ());
107 user_name
= (char *) (pw
? pw
->pw_name
: "unknown");
109 Vuser_login_name
= build_string (user_name
);
111 /* If the user name claimed in the environment vars differs from
112 the real uid, use the claimed name to find the full name. */
113 tem
= Fstring_equal (Vuser_login_name
, Vuser_real_login_name
);
114 Vuser_full_name
= Fuser_full_name (NILP (tem
)? make_number (geteuid())
117 p
= (unsigned char *) getenv ("NAME");
119 Vuser_full_name
= build_string (p
);
120 else if (NILP (Vuser_full_name
))
121 Vuser_full_name
= build_string ("unknown");
124 DEFUN ("char-to-string", Fchar_to_string
, Schar_to_string
, 1, 1, 0,
125 "Convert arg CHAR to a string containing multi-byte form of that character.")
127 Lisp_Object character
;
130 unsigned char workbuf
[4], *str
;
132 CHECK_NUMBER (character
, 0);
134 len
= CHAR_STRING (XFASTINT (character
), workbuf
, str
);
135 return make_string (str
, len
);
138 DEFUN ("string-to-char", Fstring_to_char
, Sstring_to_char
, 1, 1, 0,
139 "Convert arg STRING to a character, the first character of that string.\n\
140 A multibyte character is handled correctly.")
142 register Lisp_Object string
;
144 register Lisp_Object val
;
145 register struct Lisp_String
*p
;
146 CHECK_STRING (string
, 0);
147 p
= XSTRING (string
);
149 XSETFASTINT (val
, STRING_CHAR (p
->data
, p
->size
));
151 XSETFASTINT (val
, 0);
155 DEFUN ("sref", Fsref
, Ssref
, 2, 2, 0,
156 "Return the character in STRING at INDEX. INDEX starts at 0.\n\
157 A multibyte character is handled correctly.\n\
158 INDEX not pointing at character boundary is an error.")
160 Lisp_Object str
, idx
;
162 register int idxval
, len
, i
;
163 register unsigned char *p
, *q
;
164 register Lisp_Object val
;
166 CHECK_STRING (str
, 0);
167 CHECK_NUMBER (idx
, 1);
169 if (idxval
< 0 || idxval
>= (len
= XVECTOR (str
)->size
))
170 args_out_of_range (str
, idx
);
172 p
= XSTRING (str
)->data
+ idxval
;
173 if (!NILP (current_buffer
->enable_multibyte_characters
)
177 /* We must check if P points to a tailing byte of a multibyte
178 form. If so, we signal error. */
181 while (i
> 0 && *q
>= 0xA0) i
--, q
--;
183 if (*q
== LEADING_CODE_COMPOSITION
)
184 i
= multibyte_form_length (XSTRING (str
)->data
+ i
, len
- i
);
186 i
= BYTES_BY_CHAR_HEAD (*q
);
188 error ("Not character boundary");
191 len
= XSTRING (str
)->size
- idxval
;
192 XSETFASTINT (val
, STRING_CHAR (p
, len
));
198 buildmark (charpos
, bytepos
)
199 int charpos
, bytepos
;
201 register Lisp_Object mark
;
202 mark
= Fmake_marker ();
203 set_marker_both (mark
, Qnil
, charpos
, bytepos
);
207 DEFUN ("point", Fpoint
, Spoint
, 0, 0, 0,
208 "Return value of point, as an integer.\n\
209 Beginning of buffer is position (point-min)")
213 XSETFASTINT (temp
, PT
);
217 DEFUN ("point-marker", Fpoint_marker
, Spoint_marker
, 0, 0, 0,
218 "Return value of point, as a marker object.")
221 return buildmark (PT
, PT_BYTE
);
225 clip_to_bounds (lower
, num
, upper
)
226 int lower
, num
, upper
;
230 else if (num
> upper
)
236 DEFUN ("goto-char", Fgoto_char
, Sgoto_char
, 1, 1, "NGoto char: ",
237 "Set point to POSITION, a number or marker.\n\
238 Beginning of buffer is position (point-min), end is (point-max).\n\
239 If the position is in the middle of a multibyte form,\n\
240 the actual point is set at the head of the multibyte form\n\
241 except in the case that `enable-multibyte-characters' is nil.")
243 register Lisp_Object position
;
248 if (MARKERP (position
))
250 pos
= marker_position (position
);
252 SET_PT_BOTH (BEGV
, BEGV_BYTE
);
254 SET_PT_BOTH (ZV
, ZV_BYTE
);
256 SET_PT_BOTH (pos
, marker_byte_position (position
));
261 CHECK_NUMBER_COERCE_MARKER (position
, 0);
263 pos
= clip_to_bounds (BEGV
, XINT (position
), ZV
);
269 region_limit (beginningp
)
272 extern Lisp_Object Vmark_even_if_inactive
; /* Defined in callint.c. */
273 register Lisp_Object m
;
274 if (!NILP (Vtransient_mark_mode
) && NILP (Vmark_even_if_inactive
)
275 && NILP (current_buffer
->mark_active
))
276 Fsignal (Qmark_inactive
, Qnil
);
277 m
= Fmarker_position (current_buffer
->mark
);
278 if (NILP (m
)) error ("There is no region now");
279 if ((PT
< XFASTINT (m
)) == beginningp
)
280 return (make_number (PT
));
285 DEFUN ("region-beginning", Fregion_beginning
, Sregion_beginning
, 0, 0, 0,
286 "Return position of beginning of region, as an integer.")
289 return (region_limit (1));
292 DEFUN ("region-end", Fregion_end
, Sregion_end
, 0, 0, 0,
293 "Return position of end of region, as an integer.")
296 return (region_limit (0));
299 DEFUN ("mark-marker", Fmark_marker
, Smark_marker
, 0, 0, 0,
300 "Return this buffer's mark, as a marker object.\n\
301 Watch out! Moving this marker changes the mark position.\n\
302 If you set the marker not to point anywhere, the buffer will have no mark.")
305 return current_buffer
->mark
;
308 DEFUN ("line-beginning-position", Fline_beginning_position
, Sline_beginning_position
,
310 "Return the character position of the first character on the current line.\n\
311 With argument N not nil or 1, move forward N - 1 lines first.\n\
312 If scan reaches end of buffer, return that position.\n\
313 This function does not move point.")
317 register int orig
, orig_byte
, end
;
326 Fforward_line (make_number (XINT (n
) - 1));
328 SET_PT_BOTH (orig
, orig_byte
);
330 return make_number (end
);
333 DEFUN ("line-end-position", Fline_end_position
, Sline_end_position
,
335 "Return the character position of the last character on the current line.\n\
336 With argument N not nil or 1, move forward N - 1 lines first.\n\
337 If scan reaches end of buffer, return that position.\n\
338 This function does not move point.")
347 return make_number (find_before_next_newline
348 (PT
, 0, XINT (n
) - (XINT (n
) <= 0)));
352 save_excursion_save ()
354 register int visible
= (XBUFFER (XWINDOW (selected_window
)->buffer
)
357 return Fcons (Fpoint_marker (),
358 Fcons (Fcopy_marker (current_buffer
->mark
, Qnil
),
359 Fcons (visible
? Qt
: Qnil
,
360 current_buffer
->mark_active
)));
364 save_excursion_restore (info
)
367 Lisp_Object tem
, tem1
, omark
, nmark
;
368 struct gcpro gcpro1
, gcpro2
, gcpro3
;
370 tem
= Fmarker_buffer (Fcar (info
));
371 /* If buffer being returned to is now deleted, avoid error */
372 /* Otherwise could get error here while unwinding to top level
374 /* In that case, Fmarker_buffer returns nil now. */
378 omark
= nmark
= Qnil
;
379 GCPRO3 (info
, omark
, nmark
);
384 unchain_marker (tem
);
385 tem
= Fcar (Fcdr (info
));
386 omark
= Fmarker_position (current_buffer
->mark
);
387 Fset_marker (current_buffer
->mark
, tem
, Fcurrent_buffer ());
388 nmark
= Fmarker_position (tem
);
389 unchain_marker (tem
);
390 tem
= Fcdr (Fcdr (info
));
391 #if 0 /* We used to make the current buffer visible in the selected window
392 if that was true previously. That avoids some anomalies.
393 But it creates others, and it wasn't documented, and it is simpler
394 and cleaner never to alter the window/buffer connections. */
397 && current_buffer
!= XBUFFER (XWINDOW (selected_window
)->buffer
))
398 Fswitch_to_buffer (Fcurrent_buffer (), Qnil
);
401 tem1
= current_buffer
->mark_active
;
402 current_buffer
->mark_active
= Fcdr (tem
);
403 if (!NILP (Vrun_hooks
))
405 /* If mark is active now, and either was not active
406 or was at a different place, run the activate hook. */
407 if (! NILP (current_buffer
->mark_active
))
409 if (! EQ (omark
, nmark
))
410 call1 (Vrun_hooks
, intern ("activate-mark-hook"));
412 /* If mark has ceased to be active, run deactivate hook. */
413 else if (! NILP (tem1
))
414 call1 (Vrun_hooks
, intern ("deactivate-mark-hook"));
420 DEFUN ("save-excursion", Fsave_excursion
, Ssave_excursion
, 0, UNEVALLED
, 0,
421 "Save point, mark, and current buffer; execute BODY; restore those things.\n\
422 Executes BODY just like `progn'.\n\
423 The values of point, mark and the current buffer are restored\n\
424 even in case of abnormal exit (throw or error).\n\
425 The state of activation of the mark is also restored.")
429 register Lisp_Object val
;
430 int count
= specpdl_ptr
- specpdl
;
432 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
435 return unbind_to (count
, val
);
438 DEFUN ("save-current-buffer", Fsave_current_buffer
, Ssave_current_buffer
, 0, UNEVALLED
, 0,
439 "Save the current buffer; execute BODY; restore the current buffer.\n\
440 Executes BODY just like `progn'.")
444 register Lisp_Object val
;
445 int count
= specpdl_ptr
- specpdl
;
447 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
450 return unbind_to (count
, val
);
453 DEFUN ("buffer-size", Fbufsize
, Sbufsize
, 0, 0, 0,
454 "Return the number of characters in the current buffer.")
458 XSETFASTINT (temp
, Z
- BEG
);
462 DEFUN ("point-min", Fpoint_min
, Spoint_min
, 0, 0, 0,
463 "Return the minimum permissible value of point in the current buffer.\n\
464 This is 1, unless narrowing (a buffer restriction) is in effect.")
468 XSETFASTINT (temp
, BEGV
);
472 DEFUN ("point-min-marker", Fpoint_min_marker
, Spoint_min_marker
, 0, 0, 0,
473 "Return a marker to the minimum permissible value of point in this buffer.\n\
474 This is the beginning, unless narrowing (a buffer restriction) is in effect.")
477 return buildmark (BEGV
, BEGV_BYTE
);
480 DEFUN ("point-max", Fpoint_max
, Spoint_max
, 0, 0, 0,
481 "Return the maximum permissible value of point in the current buffer.\n\
482 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)\n\
483 is in effect, in which case it is less.")
487 XSETFASTINT (temp
, ZV
);
491 DEFUN ("point-max-marker", Fpoint_max_marker
, Spoint_max_marker
, 0, 0, 0,
492 "Return a marker to the maximum permissible value of point in this buffer.\n\
493 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)\n\
494 is in effect, in which case it is less.")
497 return buildmark (ZV
, ZV_BYTE
);
500 DEFUN ("following-char", Ffollowing_char
, Sfollowing_char
, 0, 0, 0,
501 "Return the character following point, as a number.\n\
502 At the end of the buffer or accessible region, return 0.\n\
503 If `enable-multibyte-characters' is nil or point is not\n\
504 at character boundary, multibyte form is ignored,\n\
505 and only one byte following point is returned as a character.")
510 XSETFASTINT (temp
, 0);
512 XSETFASTINT (temp
, FETCH_CHAR (PT_BYTE
));
516 DEFUN ("preceding-char", Fprevious_char
, Sprevious_char
, 0, 0, 0,
517 "Return the character preceding point, as a number.\n\
518 At the beginning of the buffer or accessible region, return 0.\n\
519 If `enable-multibyte-characters' is nil or point is not\n\
520 at character boundary, multi-byte form is ignored,\n\
521 and only one byte preceding point is returned as a character.")
526 XSETFASTINT (temp
, 0);
527 else if (!NILP (current_buffer
->enable_multibyte_characters
))
531 XSETFASTINT (temp
, FETCH_CHAR (pos
));
534 XSETFASTINT (temp
, FETCH_BYTE (PT_BYTE
- 1));
538 DEFUN ("bobp", Fbobp
, Sbobp
, 0, 0, 0,
539 "Return t if point is at the beginning of the buffer.\n\
540 If the buffer is narrowed, this means the beginning of the narrowed part.")
548 DEFUN ("eobp", Feobp
, Seobp
, 0, 0, 0,
549 "Return t if point is at the end of the buffer.\n\
550 If the buffer is narrowed, this means the end of the narrowed part.")
558 DEFUN ("bolp", Fbolp
, Sbolp
, 0, 0, 0,
559 "Return t if point is at the beginning of a line.")
562 if (PT
== BEGV
|| FETCH_BYTE (PT_BYTE
- 1) == '\n')
567 DEFUN ("eolp", Feolp
, Seolp
, 0, 0, 0,
568 "Return t if point is at the end of a line.\n\
569 `End of a line' includes point being at the end of the buffer.")
572 if (PT
== ZV
|| FETCH_BYTE (PT_BYTE
) == '\n')
577 DEFUN ("char-after", Fchar_after
, Schar_after
, 0, 1, 0,
578 "Return character in current buffer at position POS.\n\
579 POS is an integer or a buffer pointer.\n\
580 If POS is out of range, the value is nil.\n\
581 If `enable-multibyte-characters' is nil or POS is not at character boundary,\n\
582 multi-byte form is ignored, and only one byte at POS\n\
583 is returned as a character.")
587 register int pos_byte
;
588 register Lisp_Object val
;
591 return make_number (FETCH_CHAR (PT_BYTE
));
594 pos_byte
= marker_byte_position (pos
);
597 CHECK_NUMBER_COERCE_MARKER (pos
, 0);
599 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
602 if (pos_byte
< BEGV_BYTE
|| pos_byte
>= ZV_BYTE
)
605 return make_number (FETCH_CHAR (pos_byte
));
608 DEFUN ("char-before", Fchar_before
, Schar_before
, 0, 1, 0,
609 "Return character in current buffer preceding position POS.\n\
610 POS is an integer or a buffer pointer.\n\
611 If POS is out of range, the value is nil.\n\
612 If `enable-multibyte-characters' is nil or POS is not at character boundary,\n\
613 multi-byte form is ignored, and only one byte preceding POS\n\
614 is returned as a character.")
618 register Lisp_Object val
;
619 register int pos_byte
;
623 else if (MARKERP (pos
))
624 pos_byte
= marker_byte_position (pos
);
627 CHECK_NUMBER_COERCE_MARKER (pos
, 0);
629 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
632 if (pos_byte
<= BEGV_BYTE
|| pos_byte
> ZV_BYTE
)
635 if (!NILP (current_buffer
->enable_multibyte_characters
))
638 XSETFASTINT (val
, FETCH_CHAR (pos_byte
));
643 XSETFASTINT (val
, FETCH_BYTE (pos_byte
));
648 DEFUN ("user-login-name", Fuser_login_name
, Suser_login_name
, 0, 1, 0,
649 "Return the name under which the user logged in, as a string.\n\
650 This is based on the effective uid, not the real uid.\n\
651 Also, if the environment variable LOGNAME or USER is set,\n\
652 that determines the value of this function.\n\n\
653 If optional argument UID is an integer, return the login name of the user\n\
654 with that uid, or nil if there is no such user.")
660 /* Set up the user name info if we didn't do it before.
661 (That can happen if Emacs is dumpable
662 but you decide to run `temacs -l loadup' and not dump. */
663 if (INTEGERP (Vuser_login_name
))
667 return Vuser_login_name
;
669 CHECK_NUMBER (uid
, 0);
670 pw
= (struct passwd
*) getpwuid (XINT (uid
));
671 return (pw
? build_string (pw
->pw_name
) : Qnil
);
674 DEFUN ("user-real-login-name", Fuser_real_login_name
, Suser_real_login_name
,
676 "Return the name of the user's real uid, as a string.\n\
677 This ignores the environment variables LOGNAME and USER, so it differs from\n\
678 `user-login-name' when running under `su'.")
681 /* Set up the user name info if we didn't do it before.
682 (That can happen if Emacs is dumpable
683 but you decide to run `temacs -l loadup' and not dump. */
684 if (INTEGERP (Vuser_login_name
))
686 return Vuser_real_login_name
;
689 DEFUN ("user-uid", Fuser_uid
, Suser_uid
, 0, 0, 0,
690 "Return the effective uid of Emacs, as an integer.")
693 return make_number (geteuid ());
696 DEFUN ("user-real-uid", Fuser_real_uid
, Suser_real_uid
, 0, 0, 0,
697 "Return the real uid of Emacs, as an integer.")
700 return make_number (getuid ());
703 DEFUN ("user-full-name", Fuser_full_name
, Suser_full_name
, 0, 1, 0,
704 "Return the full name of the user logged in, as a string.\n\
705 If optional argument UID is an integer, return the full name of the user\n\
706 with that uid, or \"unknown\" if there is no such user.\n\
707 If UID is a string, return the full name of the user with that login\n\
708 name, or \"unknown\" if no such user could be found.")
713 register unsigned char *p
, *q
;
714 extern char *index ();
718 return Vuser_full_name
;
719 else if (NUMBERP (uid
))
720 pw
= (struct passwd
*) getpwuid (XINT (uid
));
721 else if (STRINGP (uid
))
722 pw
= (struct passwd
*) getpwnam (XSTRING (uid
)->data
);
724 error ("Invalid UID specification");
729 p
= (unsigned char *) USER_FULL_NAME
;
730 /* Chop off everything after the first comma. */
731 q
= (unsigned char *) index (p
, ',');
732 full
= make_string (p
, q
? q
- p
: strlen (p
));
734 #ifdef AMPERSAND_FULL_NAME
735 p
= XSTRING (full
)->data
;
736 q
= (unsigned char *) index (p
, '&');
737 /* Substitute the login name for the &, upcasing the first character. */
740 register unsigned char *r
;
743 login
= Fuser_login_name (make_number (pw
->pw_uid
));
744 r
= (unsigned char *) alloca (strlen (p
) + XSTRING (login
)->size
+ 1);
747 strcat (r
, XSTRING (login
)->data
);
748 r
[q
- p
] = UPCASE (r
[q
- p
]);
750 full
= build_string (r
);
752 #endif /* AMPERSAND_FULL_NAME */
757 DEFUN ("system-name", Fsystem_name
, Ssystem_name
, 0, 0, 0,
758 "Return the name of the machine you are running on, as a string.")
764 /* For the benefit of callers who don't want to include lisp.h */
768 if (STRINGP (Vsystem_name
))
769 return (char *) XSTRING (Vsystem_name
)->data
;
774 DEFUN ("emacs-pid", Femacs_pid
, Semacs_pid
, 0, 0, 0,
775 "Return the process ID of Emacs, as an integer.")
778 return make_number (getpid ());
781 DEFUN ("current-time", Fcurrent_time
, Scurrent_time
, 0, 0, 0,
782 "Return the current time, as the number of seconds since 1970-01-01 00:00:00.\n\
783 The time is returned as a list of three integers. The first has the\n\
784 most significant 16 bits of the seconds, while the second has the\n\
785 least significant 16 bits. The third integer gives the microsecond\n\
788 The microsecond count is zero on systems that do not provide\n\
789 resolution finer than a second.")
793 Lisp_Object result
[3];
796 XSETINT (result
[0], (EMACS_SECS (t
) >> 16) & 0xffff);
797 XSETINT (result
[1], (EMACS_SECS (t
) >> 0) & 0xffff);
798 XSETINT (result
[2], EMACS_USECS (t
));
800 return Flist (3, result
);
805 lisp_time_argument (specified_time
, result
)
806 Lisp_Object specified_time
;
809 if (NILP (specified_time
))
810 return time (result
) != -1;
813 Lisp_Object high
, low
;
814 high
= Fcar (specified_time
);
815 CHECK_NUMBER (high
, 0);
816 low
= Fcdr (specified_time
);
819 CHECK_NUMBER (low
, 0);
820 *result
= (XINT (high
) << 16) + (XINT (low
) & 0xffff);
821 return *result
>> 16 == XINT (high
);
826 DEFUN ("format-time-string", Fformat_time_string, Sformat_time_string, 1, 3, 0,
827 "Use FORMAT-STRING to format the time TIME, or now if omitted.\n\
828 TIME is specified as (HIGH LOW . IGNORED) or (HIGH . LOW), as returned by\n\
829 `current-time' or `file-attributes'.\n\
830 The third, optional, argument UNIVERSAL, if non-nil, means describe TIME\n\
831 as Universal Time; nil means describe TIME in the local time zone.\n\
832 The value is a copy of FORMAT-STRING, but with certain constructs replaced\n\
833 by text that describes the specified date and time in TIME:\n\
835 %Y is the year, %y within the century, %C the century.\n\
836 %G is the year corresponding to the ISO week, %g within the century.\n\
837 %m is the numeric month.\n\
838 %b and %h are the locale's abbreviated month name, %B the full name.\n\
839 %d is the day of the month, zero-padded, %e is blank-padded.\n\
840 %u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.\n\
841 %a is the locale's abbreviated name of the day of week, %A the full name.\n\
842 %U is the week number starting on Sunday, %W starting on Monday,\n\
843 %V according to ISO 8601.\n\
844 %j is the day of the year.\n\
846 %H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H\n\
847 only blank-padded, %l is like %I blank-padded.\n\
848 %p is the locale's equivalent of either AM or PM.\n\
851 %Z is the time zone name, %z is the numeric form.\n\
852 %s is the number of seconds since 1970-01-01 00:00:00 +0000.\n\
854 %c is the locale's date and time format.\n\
855 %x is the locale's \"preferred\" date format.\n\
856 %D is like \"%m/%d/%y\".\n\
858 %R is like \"%H:%M\", %T is like \"%H:%M:%S\", %r is like \"%I:%M:%S %p\".\n\
859 %X is the locale's \"preferred\" time format.\n\
861 Finally, %n is a newline, %t is a tab, %% is a literal %.\n\
863 Certain flags and modifiers are available with some format controls.\n\
864 The flags are `_' and `-'. For certain characters X, %_X is like %X,\n\
865 but padded with blanks; %-X is like %X, but without padding.\n\
866 %NX (where N stands for an integer) is like %X,\n\
867 but takes up at least N (a number) positions.\n\
868 The modifiers are `E' and `O'. For certain characters X,\n\
869 %EX is a locale's alternative version of %X;\n\
870 %OX is like %X, but uses the locale's number symbols.\n\
872 For example, to produce full ISO 8601 format, use \"%Y-%m-%dT%T%z\".")
873 (format_string, time, universal)
876 DEFUN ("format-time-string", Fformat_time_string
, Sformat_time_string
, 1, 3, 0,
877 0 /* See immediately above */)
878 (format_string
, time
, universal
)
879 Lisp_Object format_string
, time
, universal
;
884 CHECK_STRING (format_string
, 1);
886 if (! lisp_time_argument (time
, &value
))
887 error ("Invalid time specification");
889 /* This is probably enough. */
890 size
= XSTRING (format_string
)->size
* 6 + 50;
894 char *buf
= (char *) alloca (size
+ 1);
898 result
= emacs_strftime (buf
, size
, XSTRING (format_string
)->data
,
899 (NILP (universal
) ? localtime (&value
)
901 if ((result
> 0 && result
< size
) || (result
== 0 && buf
[0] == '\0'))
902 return build_string (buf
);
904 /* If buffer was too small, make it bigger and try again. */
905 result
= emacs_strftime (NULL
, 0x7fffffff, XSTRING (format_string
)->data
,
906 (NILP (universal
) ? localtime (&value
)
912 DEFUN ("decode-time", Fdecode_time
, Sdecode_time
, 0, 1, 0,
913 "Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST ZONE).\n\
914 The optional SPECIFIED-TIME should be a list of (HIGH LOW . IGNORED)\n\
915 or (HIGH . LOW), as from `current-time' and `file-attributes', or `nil'\n\
916 to use the current time. The list has the following nine members:\n\
917 SEC is an integer between 0 and 60; SEC is 60 for a leap second, which\n\
918 only some operating systems support. MINUTE is an integer between 0 and 59.\n\
919 HOUR is an integer between 0 and 23. DAY is an integer between 1 and 31.\n\
920 MONTH is an integer between 1 and 12. YEAR is an integer indicating the\n\
921 four-digit year. DOW is the day of week, an integer between 0 and 6, where\n\
922 0 is Sunday. DST is t if daylight savings time is effect, otherwise nil.\n\
923 ZONE is an integer indicating the number of seconds east of Greenwich.\n\
924 \(Note that Common Lisp has different meanings for DOW and ZONE.)")
926 Lisp_Object specified_time
;
930 struct tm
*decoded_time
;
931 Lisp_Object list_args
[9];
933 if (! lisp_time_argument (specified_time
, &time_spec
))
934 error ("Invalid time specification");
936 decoded_time
= localtime (&time_spec
);
937 XSETFASTINT (list_args
[0], decoded_time
->tm_sec
);
938 XSETFASTINT (list_args
[1], decoded_time
->tm_min
);
939 XSETFASTINT (list_args
[2], decoded_time
->tm_hour
);
940 XSETFASTINT (list_args
[3], decoded_time
->tm_mday
);
941 XSETFASTINT (list_args
[4], decoded_time
->tm_mon
+ 1);
942 XSETINT (list_args
[5], decoded_time
->tm_year
+ 1900);
943 XSETFASTINT (list_args
[6], decoded_time
->tm_wday
);
944 list_args
[7] = (decoded_time
->tm_isdst
)? Qt
: Qnil
;
946 /* Make a copy, in case gmtime modifies the struct. */
947 save_tm
= *decoded_time
;
948 decoded_time
= gmtime (&time_spec
);
949 if (decoded_time
== 0)
952 XSETINT (list_args
[8], tm_diff (&save_tm
, decoded_time
));
953 return Flist (9, list_args
);
956 DEFUN ("encode-time", Fencode_time
, Sencode_time
, 6, MANY
, 0,
957 "Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.\n\
958 This is the reverse operation of `decode-time', which see.\n\
959 ZONE defaults to the current time zone rule. This can\n\
960 be a string or t (as from `set-time-zone-rule'), or it can be a list\n\
961 \(as from `current-time-zone') or an integer (as from `decode-time')\n\
962 applied without consideration for daylight savings time.\n\
964 You can pass more than 7 arguments; then the first six arguments\n\
965 are used as SECOND through YEAR, and the *last* argument is used as ZONE.\n\
966 The intervening arguments are ignored.\n\
967 This feature lets (apply 'encode-time (decode-time ...)) work.\n\
969 Out-of-range values for SEC, MINUTE, HOUR, DAY, or MONTH are allowed;\n\
970 for example, a DAY of 0 means the day preceding the given month.\n\
971 Year numbers less than 100 are treated just like other year numbers.\n\
972 If you want them to stand for years in this century, you must do that yourself.")
975 register Lisp_Object
*args
;
979 Lisp_Object zone
= (nargs
> 6 ? args
[nargs
- 1] : Qnil
);
981 CHECK_NUMBER (args
[0], 0); /* second */
982 CHECK_NUMBER (args
[1], 1); /* minute */
983 CHECK_NUMBER (args
[2], 2); /* hour */
984 CHECK_NUMBER (args
[3], 3); /* day */
985 CHECK_NUMBER (args
[4], 4); /* month */
986 CHECK_NUMBER (args
[5], 5); /* year */
988 tm
.tm_sec
= XINT (args
[0]);
989 tm
.tm_min
= XINT (args
[1]);
990 tm
.tm_hour
= XINT (args
[2]);
991 tm
.tm_mday
= XINT (args
[3]);
992 tm
.tm_mon
= XINT (args
[4]) - 1;
993 tm
.tm_year
= XINT (args
[5]) - 1900;
1004 char **oldenv
= environ
, **newenv
;
1008 else if (STRINGP (zone
))
1009 tzstring
= (char *) XSTRING (zone
)->data
;
1010 else if (INTEGERP (zone
))
1012 int abszone
= abs (XINT (zone
));
1013 sprintf (tzbuf
, "XXX%s%d:%02d:%02d", "-" + (XINT (zone
) < 0),
1014 abszone
/ (60*60), (abszone
/60) % 60, abszone
% 60);
1018 error ("Invalid time zone specification");
1020 /* Set TZ before calling mktime; merely adjusting mktime's returned
1021 value doesn't suffice, since that would mishandle leap seconds. */
1022 set_time_zone_rule (tzstring
);
1024 time
= mktime (&tm
);
1026 /* Restore TZ to previous value. */
1030 #ifdef LOCALTIME_CACHE
1035 if (time
== (time_t) -1)
1036 error ("Specified time is not representable");
1038 return make_time (time
);
1041 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
, 0, 1, 0,
1042 "Return the current time, as a human-readable string.\n\
1043 Programs can use this function to decode a time,\n\
1044 since the number of columns in each field is fixed.\n\
1045 The format is `Sun Sep 16 01:03:52 1973'.\n\
1046 However, see also the functions `decode-time' and `format-time-string'\n\
1047 which provide a much more powerful and general facility.\n\
1049 If an argument is given, it specifies a time to format\n\
1050 instead of the current time. The argument should have the form:\n\
1053 (HIGH LOW . IGNORED).\n\
1054 Thus, you can use times obtained from `current-time'\n\
1055 and from `file-attributes'.")
1057 Lisp_Object specified_time
;
1063 if (! lisp_time_argument (specified_time
, &value
))
1065 tem
= (char *) ctime (&value
);
1067 strncpy (buf
, tem
, 24);
1070 return build_string (buf
);
1073 #define TM_YEAR_BASE 1900
1075 /* Yield A - B, measured in seconds.
1076 This function is copied from the GNU C Library. */
1081 /* Compute intervening leap days correctly even if year is negative.
1082 Take care to avoid int overflow in leap day calculations,
1083 but it's OK to assume that A and B are close to each other. */
1084 int a4
= (a
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (a
->tm_year
& 3);
1085 int b4
= (b
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (b
->tm_year
& 3);
1086 int a100
= a4
/ 25 - (a4
% 25 < 0);
1087 int b100
= b4
/ 25 - (b4
% 25 < 0);
1088 int a400
= a100
>> 2;
1089 int b400
= b100
>> 2;
1090 int intervening_leap_days
= (a4
- b4
) - (a100
- b100
) + (a400
- b400
);
1091 int years
= a
->tm_year
- b
->tm_year
;
1092 int days
= (365 * years
+ intervening_leap_days
1093 + (a
->tm_yday
- b
->tm_yday
));
1094 return (60 * (60 * (24 * days
+ (a
->tm_hour
- b
->tm_hour
))
1095 + (a
->tm_min
- b
->tm_min
))
1096 + (a
->tm_sec
- b
->tm_sec
));
1099 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 1, 0,
1100 "Return the offset and name for the local time zone.\n\
1101 This returns a list of the form (OFFSET NAME).\n\
1102 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).\n\
1103 A negative value means west of Greenwich.\n\
1104 NAME is a string giving the name of the time zone.\n\
1105 If an argument is given, it specifies when the time zone offset is determined\n\
1106 instead of using the current time. The argument should have the form:\n\
1109 (HIGH LOW . IGNORED).\n\
1110 Thus, you can use times obtained from `current-time'\n\
1111 and from `file-attributes'.\n\
1113 Some operating systems cannot provide all this information to Emacs;\n\
1114 in this case, `current-time-zone' returns a list containing nil for\n\
1115 the data it can't find.")
1117 Lisp_Object specified_time
;
1122 if (lisp_time_argument (specified_time
, &value
)
1123 && (t
= gmtime (&value
)) != 0)
1129 gmt
= *t
; /* Make a copy, in case localtime modifies *t. */
1130 t
= localtime (&value
);
1131 offset
= tm_diff (t
, &gmt
);
1135 s
= (char *)t
->tm_zone
;
1136 #else /* not HAVE_TM_ZONE */
1138 if (t
->tm_isdst
== 0 || t
->tm_isdst
== 1)
1139 s
= tzname
[t
->tm_isdst
];
1141 #endif /* not HAVE_TM_ZONE */
1144 /* No local time zone name is available; use "+-NNNN" instead. */
1145 int am
= (offset
< 0 ? -offset
: offset
) / 60;
1146 sprintf (buf
, "%c%02d%02d", (offset
< 0 ? '-' : '+'), am
/60, am
%60);
1149 return Fcons (make_number (offset
), Fcons (build_string (s
), Qnil
));
1152 return Fmake_list (make_number (2), Qnil
);
1155 /* This holds the value of `environ' produced by the previous
1156 call to Fset_time_zone_rule, or 0 if Fset_time_zone_rule
1157 has never been called. */
1158 static char **environbuf
;
1160 DEFUN ("set-time-zone-rule", Fset_time_zone_rule
, Sset_time_zone_rule
, 1, 1, 0,
1161 "Set the local time zone using TZ, a string specifying a time zone rule.\n\
1162 If TZ is nil, use implementation-defined default time zone information.\n\
1163 If TZ is t, use Universal Time.")
1171 else if (EQ (tz
, Qt
))
1175 CHECK_STRING (tz
, 0);
1176 tzstring
= (char *) XSTRING (tz
)->data
;
1179 set_time_zone_rule (tzstring
);
1182 environbuf
= environ
;
1187 #ifdef LOCALTIME_CACHE
1189 /* These two values are known to load tz files in buggy implementations,
1190 i.e. Solaris 1 executables running under either Solaris 1 or Solaris 2.
1191 Their values shouldn't matter in non-buggy implementations.
1192 We don't use string literals for these strings,
1193 since if a string in the environment is in readonly
1194 storage, it runs afoul of bugs in SVR4 and Solaris 2.3.
1195 See Sun bugs 1113095 and 1114114, ``Timezone routines
1196 improperly modify environment''. */
1198 static char set_time_zone_rule_tz1
[] = "TZ=GMT+0";
1199 static char set_time_zone_rule_tz2
[] = "TZ=GMT+1";
1203 /* Set the local time zone rule to TZSTRING.
1204 This allocates memory into `environ', which it is the caller's
1205 responsibility to free. */
1207 set_time_zone_rule (tzstring
)
1211 char **from
, **to
, **newenv
;
1213 /* Make the ENVIRON vector longer with room for TZSTRING. */
1214 for (from
= environ
; *from
; from
++)
1216 envptrs
= from
- environ
+ 2;
1217 newenv
= to
= (char **) xmalloc (envptrs
* sizeof (char *)
1218 + (tzstring
? strlen (tzstring
) + 4 : 0));
1220 /* Add TZSTRING to the end of environ, as a value for TZ. */
1223 char *t
= (char *) (to
+ envptrs
);
1225 strcat (t
, tzstring
);
1229 /* Copy the old environ vector elements into NEWENV,
1230 but don't copy the TZ variable.
1231 So we have only one definition of TZ, which came from TZSTRING. */
1232 for (from
= environ
; *from
; from
++)
1233 if (strncmp (*from
, "TZ=", 3) != 0)
1239 /* If we do have a TZSTRING, NEWENV points to the vector slot where
1240 the TZ variable is stored. If we do not have a TZSTRING,
1241 TO points to the vector slot which has the terminating null. */
1243 #ifdef LOCALTIME_CACHE
1245 /* In SunOS 4.1.3_U1 and 4.1.4, if TZ has a value like
1246 "US/Pacific" that loads a tz file, then changes to a value like
1247 "XXX0" that does not load a tz file, and then changes back to
1248 its original value, the last change is (incorrectly) ignored.
1249 Also, if TZ changes twice in succession to values that do
1250 not load a tz file, tzset can dump core (see Sun bug#1225179).
1251 The following code works around these bugs. */
1255 /* Temporarily set TZ to a value that loads a tz file
1256 and that differs from tzstring. */
1258 *newenv
= (strcmp (tzstring
, set_time_zone_rule_tz1
+ 3) == 0
1259 ? set_time_zone_rule_tz2
: set_time_zone_rule_tz1
);
1265 /* The implied tzstring is unknown, so temporarily set TZ to
1266 two different values that each load a tz file. */
1267 *to
= set_time_zone_rule_tz1
;
1270 *to
= set_time_zone_rule_tz2
;
1275 /* Now TZ has the desired value, and tzset can be invoked safely. */
1282 /* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC
1283 (if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a
1284 type of object is Lisp_String). INHERIT is passed to
1285 INSERT_FROM_STRING_FUNC as the last argument. */
1288 general_insert_function (insert_func
, insert_from_string_func
,
1289 inherit
, nargs
, args
)
1290 void (*insert_func
) P_ ((unsigned char *, int));
1291 void (*insert_from_string_func
) P_ ((Lisp_Object
, int, int, int));
1293 register Lisp_Object
*args
;
1295 register int argnum
;
1296 register Lisp_Object val
;
1298 for (argnum
= 0; argnum
< nargs
; argnum
++)
1304 unsigned char workbuf
[4], *str
;
1307 if (!NILP (current_buffer
->enable_multibyte_characters
))
1308 len
= CHAR_STRING (XFASTINT (val
), workbuf
, str
);
1310 workbuf
[0] = XINT (val
), str
= workbuf
, len
= 1;
1311 (*insert_func
) (str
, len
);
1313 else if (STRINGP (val
))
1315 (*insert_from_string_func
) (val
, 0, XSTRING (val
)->size
, inherit
);
1319 val
= wrong_type_argument (Qchar_or_string_p
, val
);
1333 /* Callers passing one argument to Finsert need not gcpro the
1334 argument "array", since the only element of the array will
1335 not be used after calling insert or insert_from_string, so
1336 we don't care if it gets trashed. */
1338 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
1339 "Insert the arguments, either strings or characters, at point.\n\
1340 Point and before-insertion-markers move forward so that it ends up\n\
1341 after the inserted text.\n\
1342 Any other markers at the point of insertion remain before the text.")
1345 register Lisp_Object
*args
;
1347 general_insert_function (insert
, insert_from_string
, 0, nargs
, args
);
1351 DEFUN ("insert-and-inherit", Finsert_and_inherit
, Sinsert_and_inherit
,
1353 "Insert the arguments at point, inheriting properties from adjoining text.\n\
1354 Point and before-insertion-markers move forward so that it ends up\n\
1355 after the inserted text.\n\
1356 Any other markers at the point of insertion remain before the text.")
1359 register Lisp_Object
*args
;
1361 general_insert_function (insert_and_inherit
, insert_from_string
, 1,
1366 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
1367 "Insert strings or characters at point, relocating markers after the text.\n\
1368 Point and before-insertion-markers move forward so that it ends up\n\
1369 after the inserted text.\n\
1370 Any other markers at the point of insertion also end up after the text.")
1373 register Lisp_Object
*args
;
1375 general_insert_function (insert_before_markers
,
1376 insert_from_string_before_markers
, 0,
1381 DEFUN ("insert-before-markers-and-inherit", Finsert_and_inherit_before_markers
,
1382 Sinsert_and_inherit_before_markers
, 0, MANY
, 0,
1383 "Insert text at point, relocating markers and inheriting properties.\n\
1384 Point moves forward so that it ends up after the inserted text.\n\
1385 Any other markers at the point of insertion also end up after the text.")
1388 register Lisp_Object
*args
;
1390 general_insert_function (insert_before_markers_and_inherit
,
1391 insert_from_string_before_markers
, 1,
1396 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 2, 3, 0,
1397 "Insert COUNT (second arg) copies of CHARACTER (first arg).\n\
1398 Point and before-insertion-markers are affected as in the function `insert'.\n\
1399 Both arguments are required.\n\
1400 The optional third arg INHERIT, if non-nil, says to inherit text properties\n\
1401 from adjoining text, if those properties are sticky.")
1402 (character
, count
, inherit
)
1403 Lisp_Object character
, count
, inherit
;
1405 register unsigned char *string
;
1406 register int strlen
;
1409 unsigned char workbuf
[4], *str
;
1411 CHECK_NUMBER (character
, 0);
1412 CHECK_NUMBER (count
, 1);
1414 if (!NILP (current_buffer
->enable_multibyte_characters
))
1415 len
= CHAR_STRING (XFASTINT (character
), workbuf
, str
);
1417 workbuf
[0] = XFASTINT (character
), str
= workbuf
, len
= 1;
1418 n
= XINT (count
) * len
;
1421 strlen
= min (n
, 256 * len
);
1422 string
= (unsigned char *) alloca (strlen
);
1423 for (i
= 0; i
< strlen
; i
++)
1424 string
[i
] = str
[i
% len
];
1428 if (!NILP (inherit
))
1429 insert_and_inherit (string
, strlen
);
1431 insert (string
, strlen
);
1436 if (!NILP (inherit
))
1437 insert_and_inherit (string
, n
);
1445 /* Making strings from buffer contents. */
1447 /* Return a Lisp_String containing the text of the current buffer from
1448 START to END. If text properties are in use and the current buffer
1449 has properties in the range specified, the resulting string will also
1450 have them, if PROPS is nonzero.
1452 We don't want to use plain old make_string here, because it calls
1453 make_uninit_string, which can cause the buffer arena to be
1454 compacted. make_string has no way of knowing that the data has
1455 been moved, and thus copies the wrong data into the string. This
1456 doesn't effect most of the other users of make_string, so it should
1457 be left as is. But we should use this function when conjuring
1458 buffer substrings. */
1461 make_buffer_string (start
, end
, props
)
1465 Lisp_Object result
, tem
, tem1
;
1466 int start_byte
= CHAR_TO_BYTE (start
);
1467 int end_byte
= CHAR_TO_BYTE (end
);
1469 if (start
< GPT
&& GPT
< end
)
1472 result
= make_uninit_string (end_byte
- start_byte
);
1473 bcopy (BYTE_POS_ADDR (start_byte
), XSTRING (result
)->data
,
1474 end_byte
- start_byte
);
1476 /* If desired, update and copy the text properties. */
1477 #ifdef USE_TEXT_PROPERTIES
1480 update_buffer_properties (start
, end
);
1482 tem
= Fnext_property_change (make_number (start
), Qnil
, make_number (end
));
1483 tem1
= Ftext_properties_at (make_number (start
), Qnil
);
1485 if (XINT (tem
) != end
|| !NILP (tem1
))
1486 copy_intervals_to_string (result
, current_buffer
, start
,
1494 /* Call Vbuffer_access_fontify_functions for the range START ... END
1495 in the current buffer, if necessary. */
1498 update_buffer_properties (start
, end
)
1501 #ifdef USE_TEXT_PROPERTIES
1502 /* If this buffer has some access functions,
1503 call them, specifying the range of the buffer being accessed. */
1504 if (!NILP (Vbuffer_access_fontify_functions
))
1506 Lisp_Object args
[3];
1509 args
[0] = Qbuffer_access_fontify_functions
;
1510 XSETINT (args
[1], start
);
1511 XSETINT (args
[2], end
);
1513 /* But don't call them if we can tell that the work
1514 has already been done. */
1515 if (!NILP (Vbuffer_access_fontified_property
))
1517 tem
= Ftext_property_any (args
[1], args
[2],
1518 Vbuffer_access_fontified_property
,
1521 Frun_hook_with_args (3, args
);
1524 Frun_hook_with_args (3, args
);
1529 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
1530 "Return the contents of part of the current buffer as a string.\n\
1531 The two arguments START and END are character positions;\n\
1532 they can be in either order.")
1534 Lisp_Object start
, end
;
1538 validate_region (&start
, &end
);
1542 return make_buffer_string (b
, e
, 1);
1545 DEFUN ("buffer-substring-no-properties", Fbuffer_substring_no_properties
,
1546 Sbuffer_substring_no_properties
, 2, 2, 0,
1547 "Return the characters of part of the buffer, without the text properties.\n\
1548 The two arguments START and END are character positions;\n\
1549 they can be in either order.")
1551 Lisp_Object start
, end
;
1555 validate_region (&start
, &end
);
1559 return make_buffer_string (b
, e
, 0);
1562 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
1563 "Return the contents of the current buffer as a string.\n\
1564 If narrowing is in effect, this function returns only the visible part\n\
1568 return make_buffer_string (BEGV
, ZV
, 1);
1571 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
1573 "Insert before point a substring of the contents of buffer BUFFER.\n\
1574 BUFFER may be a buffer or a buffer name.\n\
1575 Arguments START and END are character numbers specifying the substring.\n\
1576 They default to the beginning and the end of BUFFER.")
1578 Lisp_Object buf
, start
, end
;
1580 register int b
, e
, temp
;
1581 register struct buffer
*bp
, *obuf
;
1584 buffer
= Fget_buffer (buf
);
1587 bp
= XBUFFER (buffer
);
1588 if (NILP (bp
->name
))
1589 error ("Selecting deleted buffer");
1595 CHECK_NUMBER_COERCE_MARKER (start
, 0);
1602 CHECK_NUMBER_COERCE_MARKER (end
, 1);
1607 temp
= b
, b
= e
, e
= temp
;
1609 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
1610 args_out_of_range (start
, end
);
1612 obuf
= current_buffer
;
1613 set_buffer_internal_1 (bp
);
1614 update_buffer_properties (b
, e
);
1615 set_buffer_internal_1 (obuf
);
1617 insert_from_buffer (bp
, b
, e
- b
, 0);
1621 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
1623 "Compare two substrings of two buffers; return result as number.\n\
1624 the value is -N if first string is less after N-1 chars,\n\
1625 +N if first string is greater after N-1 chars, or 0 if strings match.\n\
1626 Each substring is represented as three arguments: BUFFER, START and END.\n\
1627 That makes six args in all, three for each substring.\n\n\
1628 The value of `case-fold-search' in the current buffer\n\
1629 determines whether case is significant or ignored.")
1630 (buffer1
, start1
, end1
, buffer2
, start2
, end2
)
1631 Lisp_Object buffer1
, start1
, end1
, buffer2
, start2
, end2
;
1633 register int begp1
, endp1
, begp2
, endp2
, temp
, len1
, len2
, length
, i
;
1634 register struct buffer
*bp1
, *bp2
;
1635 register Lisp_Object
*trt
1636 = (!NILP (current_buffer
->case_fold_search
)
1637 ? XCHAR_TABLE (current_buffer
->case_canon_table
)->contents
: 0);
1639 int beg1_byte
, beg2_byte
;
1641 /* Find the first buffer and its substring. */
1644 bp1
= current_buffer
;
1648 buf1
= Fget_buffer (buffer1
);
1651 bp1
= XBUFFER (buf1
);
1652 if (NILP (bp1
->name
))
1653 error ("Selecting deleted buffer");
1657 begp1
= BUF_BEGV (bp1
);
1660 CHECK_NUMBER_COERCE_MARKER (start1
, 1);
1661 begp1
= XINT (start1
);
1664 endp1
= BUF_ZV (bp1
);
1667 CHECK_NUMBER_COERCE_MARKER (end1
, 2);
1668 endp1
= XINT (end1
);
1672 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
1674 if (!(BUF_BEGV (bp1
) <= begp1
1676 && endp1
<= BUF_ZV (bp1
)))
1677 args_out_of_range (start1
, end1
);
1679 /* Likewise for second substring. */
1682 bp2
= current_buffer
;
1686 buf2
= Fget_buffer (buffer2
);
1689 bp2
= XBUFFER (buf2
);
1690 if (NILP (bp2
->name
))
1691 error ("Selecting deleted buffer");
1695 begp2
= BUF_BEGV (bp2
);
1698 CHECK_NUMBER_COERCE_MARKER (start2
, 4);
1699 begp2
= XINT (start2
);
1702 endp2
= BUF_ZV (bp2
);
1705 CHECK_NUMBER_COERCE_MARKER (end2
, 5);
1706 endp2
= XINT (end2
);
1710 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
1712 if (!(BUF_BEGV (bp2
) <= begp2
1714 && endp2
<= BUF_ZV (bp2
)))
1715 args_out_of_range (start2
, end2
);
1717 beg1_byte
= buf_charpos_to_bytepos (bp1
, begp1
);
1718 beg2_byte
= buf_charpos_to_bytepos (bp2
, begp2
);
1719 len1
= buf_charpos_to_bytepos (bp1
, endp1
) - begp1
;
1720 len2
= buf_charpos_to_bytepos (bp2
, endp2
) - begp2
;
1725 for (i
= 0; i
< length
; i
++)
1727 unsigned char *p1
= BUF_BYTE_ADDRESS (bp1
, beg1_byte
+ i
);
1729 int c2
= *BUF_BYTE_ADDRESS (bp2
, beg2_byte
+ i
);
1731 /* If a character begins here,
1732 count the previous character now. */
1734 && (NILP (current_buffer
->enable_multibyte_characters
)
1735 || CHAR_HEAD_P (*p1
)))
1740 c1
= XINT (trt
[c1
]);
1741 c2
= XINT (trt
[c2
]);
1744 return make_number (- 1 - chars
);
1746 return make_number (chars
+ 1);
1749 /* The strings match as far as they go.
1750 If one is shorter, that one is less. */
1752 return make_number (chars
+ 1);
1753 else if (length
< len2
)
1754 return make_number (- chars
- 1);
1756 /* Same length too => they are equal. */
1757 return make_number (0);
1761 subst_char_in_region_unwind (arg
)
1764 return current_buffer
->undo_list
= arg
;
1768 subst_char_in_region_unwind_1 (arg
)
1771 return current_buffer
->filename
= arg
;
1774 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
1775 Ssubst_char_in_region
, 4, 5, 0,
1776 "From START to END, replace FROMCHAR with TOCHAR each time it occurs.\n\
1777 If optional arg NOUNDO is non-nil, don't record this change for undo\n\
1778 and don't mark the buffer as really changed.\n\
1779 Both characters must have the same length of multi-byte form.")
1780 (start
, end
, fromchar
, tochar
, noundo
)
1781 Lisp_Object start
, end
, fromchar
, tochar
, noundo
;
1783 register int pos
, stop
, i
, len
, end_byte
;
1785 unsigned char fromwork
[4], *fromstr
, towork
[4], *tostr
, *p
;
1786 int count
= specpdl_ptr
- specpdl
;
1788 validate_region (&start
, &end
);
1789 CHECK_NUMBER (fromchar
, 2);
1790 CHECK_NUMBER (tochar
, 3);
1792 if (! NILP (current_buffer
->enable_multibyte_characters
))
1794 len
= CHAR_STRING (XFASTINT (fromchar
), fromwork
, fromstr
);
1795 if (CHAR_STRING (XFASTINT (tochar
), towork
, tostr
) != len
)
1796 error ("Characters in subst-char-in-region have different byte-lengths");
1801 fromwork
[0] = XFASTINT (fromchar
), fromstr
= fromwork
;
1802 towork
[0] = XFASTINT (tochar
), tostr
= towork
;
1805 pos
= CHAR_TO_BYTE (XINT (start
));
1806 stop
= CHAR_TO_BYTE (XINT (end
));
1809 /* If we don't want undo, turn off putting stuff on the list.
1810 That's faster than getting rid of things,
1811 and it prevents even the entry for a first change.
1812 Also inhibit locking the file. */
1815 record_unwind_protect (subst_char_in_region_unwind
,
1816 current_buffer
->undo_list
);
1817 current_buffer
->undo_list
= Qt
;
1818 /* Don't do file-locking. */
1819 record_unwind_protect (subst_char_in_region_unwind_1
,
1820 current_buffer
->filename
);
1821 current_buffer
->filename
= Qnil
;
1825 stop
= min (stop
, GPT_BYTE
);
1826 p
= BYTE_POS_ADDR (pos
);
1831 if (pos
>= end_byte
) break;
1833 p
= BYTE_POS_ADDR (pos
);
1835 if (p
[0] == fromstr
[0]
1837 || (p
[1] == fromstr
[1]
1838 && (len
== 2 || (p
[2] == fromstr
[2]
1839 && (len
== 3 || p
[3] == fromstr
[3]))))))
1843 modify_region (current_buffer
, XINT (start
), XINT (end
));
1845 if (! NILP (noundo
))
1847 if (MODIFF
- 1 == SAVE_MODIFF
)
1849 if (MODIFF
- 1 == current_buffer
->auto_save_modified
)
1850 current_buffer
->auto_save_modified
++;
1857 record_change (pos
, len
);
1858 for (i
= 0; i
< len
; i
++) *p
++ = tostr
[i
];
1866 signal_after_change (XINT (start
),
1867 stop
- XINT (start
), stop
- XINT (start
));
1869 unbind_to (count
, Qnil
);
1873 DEFUN ("translate-region", Ftranslate_region
, Stranslate_region
, 3, 3, 0,
1874 "From START to END, translate characters according to TABLE.\n\
1875 TABLE is a string; the Nth character in it is the mapping\n\
1876 for the character with code N. Returns the number of characters changed.")
1880 register Lisp_Object table
;
1882 register int pos_byte
, stop
; /* Limits of the region. */
1883 register unsigned char *tt
; /* Trans table. */
1884 register int nc
; /* New character. */
1885 int cnt
; /* Number of changes made. */
1886 int size
; /* Size of translate table. */
1889 validate_region (&start
, &end
);
1890 CHECK_STRING (table
, 2);
1892 size
= XSTRING (table
)->size
;
1893 tt
= XSTRING (table
)->data
;
1895 pos_byte
= CHAR_TO_BYTE (XINT (start
));
1896 stop
= CHAR_TO_BYTE (XINT (end
));
1897 modify_region (current_buffer
, XINT (start
), XINT (end
));
1898 charpos
= XINT (start
);
1901 for (; pos_byte
< stop
; ++pos_byte
)
1903 register unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
1904 register int oc
= *p
; /* Old character. */
1905 if (CHAR_HEAD_P (*p
))
1913 record_change (charpos
, 1);
1915 signal_after_change (charpos
, 1, 1);
1921 return make_number (cnt
);
1924 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
1925 "Delete the text between point and mark.\n\
1926 When called from a program, expects two arguments,\n\
1927 positions (integers or markers) specifying the stretch to be deleted.")
1929 Lisp_Object start
, end
;
1931 validate_region (&start
, &end
);
1932 del_range (XINT (start
), XINT (end
));
1936 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
1937 "Remove restrictions (narrowing) from current buffer.\n\
1938 This allows the buffer's full text to be seen and edited.")
1941 if (BEG
!= BEGV
|| Z
!= ZV
)
1942 current_buffer
->clip_changed
= 1;
1944 BEGV_BYTE
= BEG_BYTE
;
1945 SET_BUF_ZV_BOTH (current_buffer
, Z
, Z_BYTE
);
1946 /* Changing the buffer bounds invalidates any recorded current column. */
1947 invalidate_current_column ();
1951 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
1952 "Restrict editing in this buffer to the current region.\n\
1953 The rest of the text becomes temporarily invisible and untouchable\n\
1954 but is not deleted; if you save the buffer in a file, the invisible\n\
1955 text is included in the file. \\[widen] makes all visible again.\n\
1956 See also `save-restriction'.\n\
1958 When calling from a program, pass two arguments; positions (integers\n\
1959 or markers) bounding the text that should remain visible.")
1961 register Lisp_Object start
, end
;
1963 CHECK_NUMBER_COERCE_MARKER (start
, 0);
1964 CHECK_NUMBER_COERCE_MARKER (end
, 1);
1966 if (XINT (start
) > XINT (end
))
1969 tem
= start
; start
= end
; end
= tem
;
1972 if (!(BEG
<= XINT (start
) && XINT (start
) <= XINT (end
) && XINT (end
) <= Z
))
1973 args_out_of_range (start
, end
);
1975 if (BEGV
!= XFASTINT (start
) || ZV
!= XFASTINT (end
))
1976 current_buffer
->clip_changed
= 1;
1978 SET_BUF_BEGV (current_buffer
, XFASTINT (start
));
1979 SET_BUF_ZV (current_buffer
, XFASTINT (end
));
1980 if (PT
< XFASTINT (start
))
1981 SET_PT (XFASTINT (start
));
1982 if (PT
> XFASTINT (end
))
1983 SET_PT (XFASTINT (end
));
1984 /* Changing the buffer bounds invalidates any recorded current column. */
1985 invalidate_current_column ();
1990 save_restriction_save ()
1992 register Lisp_Object bottom
, top
;
1993 /* Note: I tried using markers here, but it does not win
1994 because insertion at the end of the saved region
1995 does not advance mh and is considered "outside" the saved region. */
1996 XSETFASTINT (bottom
, BEGV
- BEG
);
1997 XSETFASTINT (top
, Z
- ZV
);
1999 return Fcons (Fcurrent_buffer (), Fcons (bottom
, top
));
2003 save_restriction_restore (data
)
2006 register struct buffer
*buf
;
2007 register int newhead
, newtail
;
2008 register Lisp_Object tem
;
2011 buf
= XBUFFER (XCONS (data
)->car
);
2013 data
= XCONS (data
)->cdr
;
2015 tem
= XCONS (data
)->car
;
2016 newhead
= XINT (tem
);
2017 tem
= XCONS (data
)->cdr
;
2018 newtail
= XINT (tem
);
2019 if (newhead
+ newtail
> BUF_Z (buf
) - BUF_BEG (buf
))
2025 obegv
= BUF_BEGV (buf
);
2028 SET_BUF_BEGV (buf
, BUF_BEG (buf
) + newhead
);
2029 SET_BUF_ZV (buf
, BUF_Z (buf
) - newtail
);
2031 if (obegv
!= BUF_BEGV (buf
) || ozv
!= BUF_ZV (buf
))
2032 current_buffer
->clip_changed
= 1;
2034 /* If point is outside the new visible range, move it inside. */
2035 SET_BUF_PT_BOTH (buf
,
2036 clip_to_bounds (BUF_BEGV (buf
), BUF_PT (buf
), BUF_ZV (buf
)),
2037 clip_to_bounds (BUF_BEGV_BYTE (buf
), BUF_PT_BYTE (buf
),
2038 BUF_ZV_BYTE (buf
)));
2043 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
2044 "Execute BODY, saving and restoring current buffer's restrictions.\n\
2045 The buffer's restrictions make parts of the beginning and end invisible.\n\
2046 \(They are set up with `narrow-to-region' and eliminated with `widen'.)\n\
2047 This special form, `save-restriction', saves the current buffer's restrictions\n\
2048 when it is entered, and restores them when it is exited.\n\
2049 So any `narrow-to-region' within BODY lasts only until the end of the form.\n\
2050 The old restrictions settings are restored\n\
2051 even in case of abnormal exit (throw or error).\n\
2053 The value returned is the value of the last form in BODY.\n\
2055 `save-restriction' can get confused if, within the BODY, you widen\n\
2056 and then make changes outside the area within the saved restrictions.\n\
2058 Note: if you are using both `save-excursion' and `save-restriction',\n\
2059 use `save-excursion' outermost:\n\
2060 (save-excursion (save-restriction ...))")
2064 register Lisp_Object val
;
2065 int count
= specpdl_ptr
- specpdl
;
2067 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
2068 val
= Fprogn (body
);
2069 return unbind_to (count
, val
);
2072 /* Buffer for the most recent text displayed by Fmessage. */
2073 static char *message_text
;
2075 /* Allocated length of that buffer. */
2076 static int message_length
;
2078 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
2079 "Print a one-line message at the bottom of the screen.\n\
2080 The first argument is a format control string, and the rest are data\n\
2081 to be formatted under control of the string. See `format' for details.\n\
2083 If the first argument is nil, clear any existing message; let the\n\
2084 minibuffer contents show.")
2096 register Lisp_Object val
;
2097 val
= Fformat (nargs
, args
);
2098 /* Copy the data so that it won't move when we GC. */
2101 message_text
= (char *)xmalloc (80);
2102 message_length
= 80;
2104 if (XSTRING (val
)->size
> message_length
)
2106 message_length
= XSTRING (val
)->size
;
2107 message_text
= (char *)xrealloc (message_text
, message_length
);
2109 bcopy (XSTRING (val
)->data
, message_text
, XSTRING (val
)->size
);
2110 message2 (message_text
, XSTRING (val
)->size
);
2115 DEFUN ("message-box", Fmessage_box
, Smessage_box
, 1, MANY
, 0,
2116 "Display a message, in a dialog box if possible.\n\
2117 If a dialog box is not available, use the echo area.\n\
2118 The first argument is a format control string, and the rest are data\n\
2119 to be formatted under control of the string. See `format' for details.\n\
2121 If the first argument is nil, clear any existing message; let the\n\
2122 minibuffer contents show.")
2134 register Lisp_Object val
;
2135 val
= Fformat (nargs
, args
);
2138 Lisp_Object pane
, menu
, obj
;
2139 struct gcpro gcpro1
;
2140 pane
= Fcons (Fcons (build_string ("OK"), Qt
), Qnil
);
2142 menu
= Fcons (val
, pane
);
2143 obj
= Fx_popup_dialog (Qt
, menu
);
2147 #else /* not HAVE_MENUS */
2148 /* Copy the data so that it won't move when we GC. */
2151 message_text
= (char *)xmalloc (80);
2152 message_length
= 80;
2154 if (XSTRING (val
)->size
> message_length
)
2156 message_length
= XSTRING (val
)->size
;
2157 message_text
= (char *)xrealloc (message_text
, message_length
);
2159 bcopy (XSTRING (val
)->data
, message_text
, XSTRING (val
)->size
);
2160 message2 (message_text
, XSTRING (val
)->size
);
2162 #endif /* not HAVE_MENUS */
2166 extern Lisp_Object last_nonmenu_event
;
2169 DEFUN ("message-or-box", Fmessage_or_box
, Smessage_or_box
, 1, MANY
, 0,
2170 "Display a message in a dialog box or in the echo area.\n\
2171 If this command was invoked with the mouse, use a dialog box.\n\
2172 Otherwise, use the echo area.\n\
2173 The first argument is a format control string, and the rest are data\n\
2174 to be formatted under control of the string. See `format' for details.\n\
2176 If the first argument is nil, clear any existing message; let the\n\
2177 minibuffer contents show.")
2183 if (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2184 return Fmessage_box (nargs
, args
);
2186 return Fmessage (nargs
, args
);
2189 DEFUN ("current-message", Fcurrent_message
, Scurrent_message
, 0, 0, 0,
2190 "Return the string currently displayed in the echo area, or nil if none.")
2193 return (echo_area_glyphs
2194 ? make_string (echo_area_glyphs
, echo_area_glyphs_length
)
2198 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
2199 "Format a string out of a control-string and arguments.\n\
2200 The first argument is a control string.\n\
2201 The other arguments are substituted into it to make the result, a string.\n\
2202 It may contain %-sequences meaning to substitute the next argument.\n\
2203 %s means print a string argument. Actually, prints any object, with `princ'.\n\
2204 %d means print as number in decimal (%o octal, %x hex).\n\
2205 %e means print a number in exponential notation.\n\
2206 %f means print a number in decimal-point notation.\n\
2207 %g means print a number in exponential notation\n\
2208 or decimal-point notation, whichever uses fewer characters.\n\
2209 %c means print a number as a single character.\n\
2210 %S means print any object as an s-expression (using prin1).\n\
2211 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.\n\
2212 Use %% to put a single % into the output.")
2215 register Lisp_Object
*args
;
2217 register int n
; /* The number of the next arg to substitute */
2218 register int total
= 5; /* An estimate of the final length */
2220 register unsigned char *format
, *end
;
2222 extern char *index ();
2223 /* It should not be necessary to GCPRO ARGS, because
2224 the caller in the interpreter should take care of that. */
2226 CHECK_STRING (args
[0], 0);
2227 format
= XSTRING (args
[0])->data
;
2228 end
= format
+ XSTRING (args
[0])->size
;
2231 while (format
!= end
)
2232 if (*format
++ == '%')
2236 /* Process a numeric arg and skip it. */
2237 minlen
= atoi (format
);
2241 while ((*format
>= '0' && *format
<= '9')
2242 || *format
== '-' || *format
== ' ' || *format
== '.')
2247 else if (++n
>= nargs
)
2248 error ("Not enough arguments for format string");
2249 else if (*format
== 'S')
2251 /* For `S', prin1 the argument and then treat like a string. */
2252 register Lisp_Object tem
;
2253 tem
= Fprin1_to_string (args
[n
], Qnil
);
2257 else if (SYMBOLP (args
[n
]))
2259 XSETSTRING (args
[n
], XSYMBOL (args
[n
])->name
);
2262 else if (STRINGP (args
[n
]))
2265 if (*format
!= 's' && *format
!= 'S')
2266 error ("format specifier doesn't match argument type");
2267 total
+= XSTRING (args
[n
])->size
;
2268 /* We have to put an arbitrary limit on minlen
2269 since otherwise it could make alloca fail. */
2270 if (minlen
< XSTRING (args
[n
])->size
+ 1000)
2273 /* Would get MPV otherwise, since Lisp_Int's `point' to low memory. */
2274 else if (INTEGERP (args
[n
]) && *format
!= 's')
2276 #ifdef LISP_FLOAT_TYPE
2277 /* The following loop assumes the Lisp type indicates
2278 the proper way to pass the argument.
2279 So make sure we have a flonum if the argument should
2281 if (*format
== 'e' || *format
== 'f' || *format
== 'g')
2282 args
[n
] = Ffloat (args
[n
]);
2285 /* We have to put an arbitrary limit on minlen
2286 since otherwise it could make alloca fail. */
2290 #ifdef LISP_FLOAT_TYPE
2291 else if (FLOATP (args
[n
]) && *format
!= 's')
2293 if (! (*format
== 'e' || *format
== 'f' || *format
== 'g'))
2294 args
[n
] = Ftruncate (args
[n
], Qnil
);
2296 /* We have to put an arbitrary limit on minlen
2297 since otherwise it could make alloca fail. */
2304 /* Anything but a string, convert to a string using princ. */
2305 register Lisp_Object tem
;
2306 tem
= Fprin1_to_string (args
[n
], Qt
);
2313 register int nstrings
= n
+ 1;
2315 /* Allocate twice as many strings as we have %-escapes; floats occupy
2316 two slots, and we're not sure how many of those we have. */
2317 register unsigned char **strings
2318 = (unsigned char **) alloca (2 * nstrings
* sizeof (unsigned char *));
2322 for (n
= 0; n
< nstrings
; n
++)
2325 strings
[i
++] = (unsigned char *) "";
2326 else if (INTEGERP (args
[n
]))
2327 /* We checked above that the corresponding format effector
2328 isn't %s, which would cause MPV. */
2329 strings
[i
++] = (unsigned char *) XINT (args
[n
]);
2330 #ifdef LISP_FLOAT_TYPE
2331 else if (FLOATP (args
[n
]))
2333 union { double d
; char *half
[2]; } u
;
2335 u
.d
= XFLOAT (args
[n
])->data
;
2336 strings
[i
++] = (unsigned char *) u
.half
[0];
2337 strings
[i
++] = (unsigned char *) u
.half
[1];
2341 /* The first string is treated differently
2342 because it is the format string. */
2343 strings
[i
++] = XSTRING (args
[n
])->data
;
2345 strings
[i
++] = (unsigned char *) XSTRING (args
[n
]);
2348 /* Make room in result for all the non-%-codes in the control string. */
2349 total
+= XSTRING (args
[0])->size
;
2351 /* Format it in bigger and bigger buf's until it all fits. */
2354 buf
= (char *) alloca (total
+ 1);
2357 length
= doprnt_lisp (buf
, total
+ 1, strings
[0],
2358 end
, i
-1, (char **) strings
+ 1);
2359 if (buf
[total
- 1] == 0)
2367 return make_string (buf
, length
);
2373 format1 (string1
, arg0
, arg1
, arg2
, arg3
, arg4
)
2374 EMACS_INT arg0
, arg1
, arg2
, arg3
, arg4
;
2388 doprnt (buf
, sizeof buf
, string1
, (char *)0, 5, args
);
2390 doprnt (buf
, sizeof buf
, string1
, (char *)0, 5, &string1
+ 1);
2392 return build_string (buf
);
2395 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
2396 "Return t if two characters match, optionally ignoring case.\n\
2397 Both arguments must be characters (i.e. integers).\n\
2398 Case is ignored if `case-fold-search' is non-nil in the current buffer.")
2400 register Lisp_Object c1
, c2
;
2402 CHECK_NUMBER (c1
, 0);
2403 CHECK_NUMBER (c2
, 1);
2405 if (XINT (c1
) == XINT (c2
)
2406 && (NILP (current_buffer
->case_fold_search
)
2407 || DOWNCASE (XFASTINT (c1
)) == DOWNCASE (XFASTINT (c2
))))
2412 /* Transpose the markers in two regions of the current buffer, and
2413 adjust the ones between them if necessary (i.e.: if the regions
2416 START1, END1 are the character positions of the first region.
2417 START1_BYTE, END1_BYTE are the byte positions.
2418 START2, END2 are the character positions of the second region.
2419 START2_BYTE, END2_BYTE are the byte positions.
2421 Traverses the entire marker list of the buffer to do so, adding an
2422 appropriate amount to some, subtracting from some, and leaving the
2423 rest untouched. Most of this is copied from adjust_markers in insdel.c.
2425 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
2428 transpose_markers (start1
, end1
, start2
, end2
,
2429 start1_byte
, end1_byte
, start2_byte
, end2_byte
)
2430 register int start1
, end1
, start2
, end2
;
2431 register int start1_byte
, end1_byte
, start2_byte
, end2_byte
;
2433 register int amt1
, amt1_byte
, amt2
, amt2_byte
, diff
, diff_byte
, mpos
;
2434 register Lisp_Object marker
;
2436 /* Update point as if it were a marker. */
2440 TEMP_SET_PT_BOTH (PT
+ (end2
- end1
),
2441 PT_BYTE
+ (end2_byte
- end1_byte
));
2442 else if (PT
< start2
)
2443 TEMP_SET_PT_BOTH (PT
+ (end2
- start2
) - (end1
- start1
),
2444 (PT_BYTE
+ (end2_byte
- start2_byte
)
2445 - (end1_byte
- start1_byte
)));
2447 TEMP_SET_PT_BOTH (PT
- (start2
- start1
),
2448 PT_BYTE
- (start2_byte
- start1_byte
));
2450 /* We used to adjust the endpoints here to account for the gap, but that
2451 isn't good enough. Even if we assume the caller has tried to move the
2452 gap out of our way, it might still be at start1 exactly, for example;
2453 and that places it `inside' the interval, for our purposes. The amount
2454 of adjustment is nontrivial if there's a `denormalized' marker whose
2455 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
2456 the dirty work to Fmarker_position, below. */
2458 /* The difference between the region's lengths */
2459 diff
= (end2
- start2
) - (end1
- start1
);
2460 diff_byte
= (end2_byte
- start2_byte
) - (end1_byte
- start1_byte
);
2462 /* For shifting each marker in a region by the length of the other
2463 region plus the distance between the regions. */
2464 amt1
= (end2
- start2
) + (start2
- end1
);
2465 amt2
= (end1
- start1
) + (start2
- end1
);
2466 amt1_byte
= (end2_byte
- start2_byte
) + (start2_byte
- end1_byte
);
2467 amt2_byte
= (end1_byte
- start1_byte
) + (start2_byte
- end1_byte
);
2469 for (marker
= BUF_MARKERS (current_buffer
); !NILP (marker
);
2470 marker
= XMARKER (marker
)->chain
)
2472 mpos
= marker_byte_position (marker
);
2473 if (mpos
>= start1_byte
&& mpos
< end2_byte
)
2475 if (mpos
< end1_byte
)
2477 else if (mpos
< start2_byte
)
2481 XMARKER (marker
)->bytepos
= mpos
;
2483 mpos
= XMARKER (marker
)->charpos
;
2484 if (mpos
>= start1
&& mpos
< end2
)
2488 else if (mpos
< start2
)
2493 XMARKER (marker
)->charpos
= mpos
;
2497 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
2498 "Transpose region START1 to END1 with START2 to END2.\n\
2499 The regions may not be overlapping, because the size of the buffer is\n\
2500 never changed in a transposition.\n\
2502 Optional fifth arg LEAVE_MARKERS, if non-nil, means don't update\n\
2503 any markers that happen to be located in the regions.\n\
2505 Transposing beyond buffer boundaries is an error.")
2506 (startr1
, endr1
, startr2
, endr2
, leave_markers
)
2507 Lisp_Object startr1
, endr1
, startr2
, endr2
, leave_markers
;
2509 register int start1
, end1
, start2
, end2
;
2510 int start1_byte
, start2_byte
, len1_byte
, len2_byte
;
2511 int gap
, len1
, len_mid
, len2
;
2512 unsigned char *start1_addr
, *start2_addr
, *temp
;
2514 #ifdef USE_TEXT_PROPERTIES
2515 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
;
2516 cur_intv
= BUF_INTERVALS (current_buffer
);
2517 #endif /* USE_TEXT_PROPERTIES */
2519 validate_region (&startr1
, &endr1
);
2520 validate_region (&startr2
, &endr2
);
2522 start1
= XFASTINT (startr1
);
2523 end1
= XFASTINT (endr1
);
2524 start2
= XFASTINT (startr2
);
2525 end2
= XFASTINT (endr2
);
2528 /* Swap the regions if they're reversed. */
2531 register int glumph
= start1
;
2539 len1
= end1
- start1
;
2540 len2
= end2
- start2
;
2543 error ("Transposed regions not properly ordered");
2544 else if (start1
== end1
|| start2
== end2
)
2545 error ("Transposed region may not be of length 0");
2547 /* The possibilities are:
2548 1. Adjacent (contiguous) regions, or separate but equal regions
2549 (no, really equal, in this case!), or
2550 2. Separate regions of unequal size.
2552 The worst case is usually No. 2. It means that (aside from
2553 potential need for getting the gap out of the way), there also
2554 needs to be a shifting of the text between the two regions. So
2555 if they are spread far apart, we are that much slower... sigh. */
2557 /* It must be pointed out that the really studly thing to do would
2558 be not to move the gap at all, but to leave it in place and work
2559 around it if necessary. This would be extremely efficient,
2560 especially considering that people are likely to do
2561 transpositions near where they are working interactively, which
2562 is exactly where the gap would be found. However, such code
2563 would be much harder to write and to read. So, if you are
2564 reading this comment and are feeling squirrely, by all means have
2565 a go! I just didn't feel like doing it, so I will simply move
2566 the gap the minimum distance to get it out of the way, and then
2567 deal with an unbroken array. */
2569 /* Make sure the gap won't interfere, by moving it out of the text
2570 we will operate on. */
2571 if (start1
< gap
&& gap
< end2
)
2573 if (gap
- start1
< end2
- gap
)
2579 start1_byte
= CHAR_TO_BYTE (start1
);
2580 start2_byte
= CHAR_TO_BYTE (start2
);
2581 len1_byte
= CHAR_TO_BYTE (end1
) - start1_byte
;
2582 len2_byte
= CHAR_TO_BYTE (end2
) - start2_byte
;
2584 /* Hmmm... how about checking to see if the gap is large
2585 enough to use as the temporary storage? That would avoid an
2586 allocation... interesting. Later, don't fool with it now. */
2588 /* Working without memmove, for portability (sigh), so must be
2589 careful of overlapping subsections of the array... */
2591 if (end1
== start2
) /* adjacent regions */
2593 modify_region (current_buffer
, start1
, end2
);
2594 record_change (start1
, len1
+ len2
);
2596 #ifdef USE_TEXT_PROPERTIES
2597 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
2598 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
2599 Fset_text_properties (make_number (start1
), make_number (end2
),
2601 #endif /* USE_TEXT_PROPERTIES */
2603 /* First region smaller than second. */
2604 if (len1_byte
< len2_byte
)
2606 /* We use alloca only if it is small,
2607 because we want to avoid stack overflow. */
2608 if (len2_byte
> 20000)
2609 temp
= (unsigned char *) xmalloc (len2_byte
);
2611 temp
= (unsigned char *) alloca (len2_byte
);
2613 /* Don't precompute these addresses. We have to compute them
2614 at the last minute, because the relocating allocator might
2615 have moved the buffer around during the xmalloc. */
2616 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1_byte
);
2617 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2_byte
);
2619 bcopy (start2_addr
, temp
, len2_byte
);
2620 bcopy (start1_addr
, start1_addr
+ len2_byte
, len1_byte
);
2621 bcopy (temp
, start1_addr
, len2_byte
);
2622 if (len2_byte
> 20000)
2626 /* First region not smaller than second. */
2628 if (len1_byte
> 20000)
2629 temp
= (unsigned char *) xmalloc (len1_byte
);
2631 temp
= (unsigned char *) alloca (len1_byte
);
2632 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1_byte
);
2633 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2_byte
);
2634 bcopy (start1_addr
, temp
, len1_byte
);
2635 bcopy (start2_addr
, start1_addr
, len2_byte
);
2636 bcopy (temp
, start1_addr
+ len2_byte
, len1_byte
);
2637 if (len1_byte
> 20000)
2640 #ifdef USE_TEXT_PROPERTIES
2641 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
2642 len1
, current_buffer
, 0);
2643 graft_intervals_into_buffer (tmp_interval2
, start1
,
2644 len2
, current_buffer
, 0);
2645 #endif /* USE_TEXT_PROPERTIES */
2647 /* Non-adjacent regions, because end1 != start2, bleagh... */
2650 len_mid
= start2_byte
- (start1_byte
+ len1_byte
);
2652 if (len1_byte
== len2_byte
)
2653 /* Regions are same size, though, how nice. */
2655 modify_region (current_buffer
, start1
, end1
);
2656 modify_region (current_buffer
, start2
, end2
);
2657 record_change (start1
, len1
);
2658 record_change (start2
, len2
);
2659 #ifdef USE_TEXT_PROPERTIES
2660 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
2661 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
2662 Fset_text_properties (make_number (start1
), make_number (end1
),
2664 Fset_text_properties (make_number (start2
), make_number (end2
),
2666 #endif /* USE_TEXT_PROPERTIES */
2668 if (len1_byte
> 20000)
2669 temp
= (unsigned char *) xmalloc (len1_byte
);
2671 temp
= (unsigned char *) alloca (len1_byte
);
2672 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1_byte
);
2673 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2_byte
);
2674 bcopy (start1_addr
, temp
, len1_byte
);
2675 bcopy (start2_addr
, start1_addr
, len2_byte
);
2676 bcopy (temp
, start2_addr
, len1_byte
);
2677 if (len1_byte
> 20000)
2679 #ifdef USE_TEXT_PROPERTIES
2680 graft_intervals_into_buffer (tmp_interval1
, start2
,
2681 len1
, current_buffer
, 0);
2682 graft_intervals_into_buffer (tmp_interval2
, start1
,
2683 len2
, current_buffer
, 0);
2684 #endif /* USE_TEXT_PROPERTIES */
2687 else if (len1_byte
< len2_byte
) /* Second region larger than first */
2688 /* Non-adjacent & unequal size, area between must also be shifted. */
2690 modify_region (current_buffer
, start1
, end2
);
2691 record_change (start1
, (end2
- start1
));
2692 #ifdef USE_TEXT_PROPERTIES
2693 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
2694 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
2695 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
2696 Fset_text_properties (make_number (start1
), make_number (end2
),
2698 #endif /* USE_TEXT_PROPERTIES */
2700 /* holds region 2 */
2701 if (len2_byte
> 20000)
2702 temp
= (unsigned char *) xmalloc (len2_byte
);
2704 temp
= (unsigned char *) alloca (len2_byte
);
2705 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1_byte
);
2706 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2_byte
);
2707 bcopy (start2_addr
, temp
, len2_byte
);
2708 bcopy (start1_addr
, start1_addr
+ len_mid
+ len2_byte
, len1_byte
);
2709 safe_bcopy (start1_addr
+ len1_byte
, start1_addr
+ len2_byte
, len_mid
);
2710 bcopy (temp
, start1_addr
, len2_byte
);
2711 if (len2_byte
> 20000)
2713 #ifdef USE_TEXT_PROPERTIES
2714 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
2715 len1
, current_buffer
, 0);
2716 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
2717 len_mid
, current_buffer
, 0);
2718 graft_intervals_into_buffer (tmp_interval2
, start1
,
2719 len2
, current_buffer
, 0);
2720 #endif /* USE_TEXT_PROPERTIES */
2723 /* Second region smaller than first. */
2725 record_change (start1
, (end2
- start1
));
2726 modify_region (current_buffer
, start1
, end2
);
2728 #ifdef USE_TEXT_PROPERTIES
2729 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
2730 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
2731 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
2732 Fset_text_properties (make_number (start1
), make_number (end2
),
2734 #endif /* USE_TEXT_PROPERTIES */
2736 /* holds region 1 */
2737 if (len1_byte
> 20000)
2738 temp
= (unsigned char *) xmalloc (len1_byte
);
2740 temp
= (unsigned char *) alloca (len1_byte
);
2741 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1_byte
);
2742 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2_byte
);
2743 bcopy (start1_addr
, temp
, len1_byte
);
2744 bcopy (start2_addr
, start1_addr
, len2_byte
);
2745 bcopy (start1_addr
+ len1_byte
, start1_addr
+ len2_byte
, len_mid
);
2746 bcopy (temp
, start1_addr
+ len2_byte
+ len_mid
, len1_byte
);
2747 if (len1_byte
> 20000)
2749 #ifdef USE_TEXT_PROPERTIES
2750 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
2751 len1
, current_buffer
, 0);
2752 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
2753 len_mid
, current_buffer
, 0);
2754 graft_intervals_into_buffer (tmp_interval2
, start1
,
2755 len2
, current_buffer
, 0);
2756 #endif /* USE_TEXT_PROPERTIES */
2760 /* When doing multiple transpositions, it might be nice
2761 to optimize this. Perhaps the markers in any one buffer
2762 should be organized in some sorted data tree. */
2763 if (NILP (leave_markers
))
2765 transpose_markers (start1
, end1
, start2
, end2
,
2766 start1_byte
, start1_byte
+ len1_byte
,
2767 start2_byte
, start2_byte
+ len2_byte
);
2768 fix_overlays_in_range (start1
, end2
);
2780 Qbuffer_access_fontify_functions
2781 = intern ("buffer-access-fontify-functions");
2782 staticpro (&Qbuffer_access_fontify_functions
);
2784 DEFVAR_LISP ("buffer-access-fontify-functions",
2785 &Vbuffer_access_fontify_functions
,
2786 "List of functions called by `buffer-substring' to fontify if necessary.\n\
2787 Each function is called with two arguments which specify the range\n\
2788 of the buffer being accessed.");
2789 Vbuffer_access_fontify_functions
= Qnil
;
2793 extern Lisp_Object Vprin1_to_string_buffer
;
2794 obuf
= Fcurrent_buffer ();
2795 /* Do this here, because init_buffer_once is too early--it won't work. */
2796 Fset_buffer (Vprin1_to_string_buffer
);
2797 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
2798 Fset (Fmake_local_variable (intern ("buffer-access-fontify-functions")),
2803 DEFVAR_LISP ("buffer-access-fontified-property",
2804 &Vbuffer_access_fontified_property
,
2805 "Property which (if non-nil) indicates text has been fontified.\n\
2806 `buffer-substring' need not call the `buffer-access-fontify-functions'\n\
2807 functions if all the text being accessed has this property.");
2808 Vbuffer_access_fontified_property
= Qnil
;
2810 DEFVAR_LISP ("system-name", &Vsystem_name
,
2811 "The name of the machine Emacs is running on.");
2813 DEFVAR_LISP ("user-full-name", &Vuser_full_name
,
2814 "The full name of the user logged in.");
2816 DEFVAR_LISP ("user-login-name", &Vuser_login_name
,
2817 "The user's name, taken from environment variables if possible.");
2819 DEFVAR_LISP ("user-real-login-name", &Vuser_real_login_name
,
2820 "The user's name, based upon the real uid only.");
2822 defsubr (&Schar_equal
);
2823 defsubr (&Sgoto_char
);
2824 defsubr (&Sstring_to_char
);
2825 defsubr (&Schar_to_string
);
2827 defsubr (&Sbuffer_substring
);
2828 defsubr (&Sbuffer_substring_no_properties
);
2829 defsubr (&Sbuffer_string
);
2831 defsubr (&Spoint_marker
);
2832 defsubr (&Smark_marker
);
2834 defsubr (&Sregion_beginning
);
2835 defsubr (&Sregion_end
);
2836 /* defsubr (&Smark); */
2837 /* defsubr (&Sset_mark); */
2838 defsubr (&Ssave_excursion
);
2839 defsubr (&Ssave_current_buffer
);
2841 defsubr (&Sbufsize
);
2842 defsubr (&Spoint_max
);
2843 defsubr (&Spoint_min
);
2844 defsubr (&Spoint_min_marker
);
2845 defsubr (&Spoint_max_marker
);
2847 defsubr (&Sline_beginning_position
);
2848 defsubr (&Sline_end_position
);
2854 defsubr (&Sfollowing_char
);
2855 defsubr (&Sprevious_char
);
2856 defsubr (&Schar_after
);
2857 defsubr (&Schar_before
);
2859 defsubr (&Sinsert_before_markers
);
2860 defsubr (&Sinsert_and_inherit
);
2861 defsubr (&Sinsert_and_inherit_before_markers
);
2862 defsubr (&Sinsert_char
);
2864 defsubr (&Suser_login_name
);
2865 defsubr (&Suser_real_login_name
);
2866 defsubr (&Suser_uid
);
2867 defsubr (&Suser_real_uid
);
2868 defsubr (&Suser_full_name
);
2869 defsubr (&Semacs_pid
);
2870 defsubr (&Scurrent_time
);
2871 defsubr (&Sformat_time_string
);
2872 defsubr (&Sdecode_time
);
2873 defsubr (&Sencode_time
);
2874 defsubr (&Scurrent_time_string
);
2875 defsubr (&Scurrent_time_zone
);
2876 defsubr (&Sset_time_zone_rule
);
2877 defsubr (&Ssystem_name
);
2878 defsubr (&Smessage
);
2879 defsubr (&Smessage_box
);
2880 defsubr (&Smessage_or_box
);
2881 defsubr (&Scurrent_message
);
2884 defsubr (&Sinsert_buffer_substring
);
2885 defsubr (&Scompare_buffer_substrings
);
2886 defsubr (&Ssubst_char_in_region
);
2887 defsubr (&Stranslate_region
);
2888 defsubr (&Sdelete_region
);
2890 defsubr (&Snarrow_to_region
);
2891 defsubr (&Ssave_restriction
);
2892 defsubr (&Stranspose_regions
);