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>
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_multibyte_string (str
, 1, 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_byte
));
151 XSETFASTINT (val
, 0);
156 buildmark (charpos
, bytepos
)
157 int charpos
, bytepos
;
159 register Lisp_Object mark
;
160 mark
= Fmake_marker ();
161 set_marker_both (mark
, Qnil
, charpos
, bytepos
);
165 DEFUN ("point", Fpoint
, Spoint
, 0, 0, 0,
166 "Return value of point, as an integer.\n\
167 Beginning of buffer is position (point-min)")
171 XSETFASTINT (temp
, PT
);
175 DEFUN ("point-marker", Fpoint_marker
, Spoint_marker
, 0, 0, 0,
176 "Return value of point, as a marker object.")
179 return buildmark (PT
, PT_BYTE
);
183 clip_to_bounds (lower
, num
, upper
)
184 int lower
, num
, upper
;
188 else if (num
> upper
)
194 DEFUN ("goto-char", Fgoto_char
, Sgoto_char
, 1, 1, "NGoto char: ",
195 "Set point to POSITION, a number or marker.\n\
196 Beginning of buffer is position (point-min), end is (point-max).\n\
197 If the position is in the middle of a multibyte form,\n\
198 the actual point is set at the head of the multibyte form\n\
199 except in the case that `enable-multibyte-characters' is nil.")
201 register Lisp_Object position
;
206 if (MARKERP (position
))
208 pos
= marker_position (position
);
210 SET_PT_BOTH (BEGV
, BEGV_BYTE
);
212 SET_PT_BOTH (ZV
, ZV_BYTE
);
214 SET_PT_BOTH (pos
, marker_byte_position (position
));
219 CHECK_NUMBER_COERCE_MARKER (position
, 0);
221 pos
= clip_to_bounds (BEGV
, XINT (position
), ZV
);
227 region_limit (beginningp
)
230 extern Lisp_Object Vmark_even_if_inactive
; /* Defined in callint.c. */
231 register Lisp_Object m
;
232 if (!NILP (Vtransient_mark_mode
) && NILP (Vmark_even_if_inactive
)
233 && NILP (current_buffer
->mark_active
))
234 Fsignal (Qmark_inactive
, Qnil
);
235 m
= Fmarker_position (current_buffer
->mark
);
236 if (NILP (m
)) error ("There is no region now");
237 if ((PT
< XFASTINT (m
)) == beginningp
)
238 return (make_number (PT
));
243 DEFUN ("region-beginning", Fregion_beginning
, Sregion_beginning
, 0, 0, 0,
244 "Return position of beginning of region, as an integer.")
247 return (region_limit (1));
250 DEFUN ("region-end", Fregion_end
, Sregion_end
, 0, 0, 0,
251 "Return position of end of region, as an integer.")
254 return (region_limit (0));
257 DEFUN ("mark-marker", Fmark_marker
, Smark_marker
, 0, 0, 0,
258 "Return this buffer's mark, as a marker object.\n\
259 Watch out! Moving this marker changes the mark position.\n\
260 If you set the marker not to point anywhere, the buffer will have no mark.")
263 return current_buffer
->mark
;
266 DEFUN ("line-beginning-position", Fline_beginning_position
, Sline_beginning_position
,
268 "Return the character position of the first character on the current line.\n\
269 With argument N not nil or 1, move forward N - 1 lines first.\n\
270 If scan reaches end of buffer, return that position.\n\
271 This function does not move point.")
275 register int orig
, orig_byte
, end
;
284 Fforward_line (make_number (XINT (n
) - 1));
286 SET_PT_BOTH (orig
, orig_byte
);
288 return make_number (end
);
291 DEFUN ("line-end-position", Fline_end_position
, Sline_end_position
,
293 "Return the character position of the last character on the current line.\n\
294 With argument N not nil or 1, move forward N - 1 lines first.\n\
295 If scan reaches end of buffer, return that position.\n\
296 This function does not move point.")
305 return make_number (find_before_next_newline
306 (PT
, 0, XINT (n
) - (XINT (n
) <= 0)));
310 save_excursion_save ()
312 register int visible
= (XBUFFER (XWINDOW (selected_window
)->buffer
)
315 return Fcons (Fpoint_marker (),
316 Fcons (Fcopy_marker (current_buffer
->mark
, Qnil
),
317 Fcons (visible
? Qt
: Qnil
,
318 current_buffer
->mark_active
)));
322 save_excursion_restore (info
)
325 Lisp_Object tem
, tem1
, omark
, nmark
;
326 struct gcpro gcpro1
, gcpro2
, gcpro3
;
328 tem
= Fmarker_buffer (Fcar (info
));
329 /* If buffer being returned to is now deleted, avoid error */
330 /* Otherwise could get error here while unwinding to top level
332 /* In that case, Fmarker_buffer returns nil now. */
336 omark
= nmark
= Qnil
;
337 GCPRO3 (info
, omark
, nmark
);
342 unchain_marker (tem
);
343 tem
= Fcar (Fcdr (info
));
344 omark
= Fmarker_position (current_buffer
->mark
);
345 Fset_marker (current_buffer
->mark
, tem
, Fcurrent_buffer ());
346 nmark
= Fmarker_position (tem
);
347 unchain_marker (tem
);
348 tem
= Fcdr (Fcdr (info
));
349 #if 0 /* We used to make the current buffer visible in the selected window
350 if that was true previously. That avoids some anomalies.
351 But it creates others, and it wasn't documented, and it is simpler
352 and cleaner never to alter the window/buffer connections. */
355 && current_buffer
!= XBUFFER (XWINDOW (selected_window
)->buffer
))
356 Fswitch_to_buffer (Fcurrent_buffer (), Qnil
);
359 tem1
= current_buffer
->mark_active
;
360 current_buffer
->mark_active
= Fcdr (tem
);
361 if (!NILP (Vrun_hooks
))
363 /* If mark is active now, and either was not active
364 or was at a different place, run the activate hook. */
365 if (! NILP (current_buffer
->mark_active
))
367 if (! EQ (omark
, nmark
))
368 call1 (Vrun_hooks
, intern ("activate-mark-hook"));
370 /* If mark has ceased to be active, run deactivate hook. */
371 else if (! NILP (tem1
))
372 call1 (Vrun_hooks
, intern ("deactivate-mark-hook"));
378 DEFUN ("save-excursion", Fsave_excursion
, Ssave_excursion
, 0, UNEVALLED
, 0,
379 "Save point, mark, and current buffer; execute BODY; restore those things.\n\
380 Executes BODY just like `progn'.\n\
381 The values of point, mark and the current buffer are restored\n\
382 even in case of abnormal exit (throw or error).\n\
383 The state of activation of the mark is also restored.")
387 register Lisp_Object val
;
388 int count
= specpdl_ptr
- specpdl
;
390 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
393 return unbind_to (count
, val
);
396 DEFUN ("save-current-buffer", Fsave_current_buffer
, Ssave_current_buffer
, 0, UNEVALLED
, 0,
397 "Save the current buffer; execute BODY; restore the current buffer.\n\
398 Executes BODY just like `progn'.")
402 register Lisp_Object val
;
403 int count
= specpdl_ptr
- specpdl
;
405 record_unwind_protect (set_buffer_if_live
, Fcurrent_buffer ());
408 return unbind_to (count
, val
);
411 DEFUN ("buffer-size", Fbufsize
, Sbufsize
, 0, 0, 0,
412 "Return the number of characters in the current buffer.")
416 XSETFASTINT (temp
, Z
- BEG
);
420 DEFUN ("point-min", Fpoint_min
, Spoint_min
, 0, 0, 0,
421 "Return the minimum permissible value of point in the current buffer.\n\
422 This is 1, unless narrowing (a buffer restriction) is in effect.")
426 XSETFASTINT (temp
, BEGV
);
430 DEFUN ("point-min-marker", Fpoint_min_marker
, Spoint_min_marker
, 0, 0, 0,
431 "Return a marker to the minimum permissible value of point in this buffer.\n\
432 This is the beginning, unless narrowing (a buffer restriction) is in effect.")
435 return buildmark (BEGV
, BEGV_BYTE
);
438 DEFUN ("point-max", Fpoint_max
, Spoint_max
, 0, 0, 0,
439 "Return the maximum permissible value of point in the current buffer.\n\
440 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)\n\
441 is in effect, in which case it is less.")
445 XSETFASTINT (temp
, ZV
);
449 DEFUN ("point-max-marker", Fpoint_max_marker
, Spoint_max_marker
, 0, 0, 0,
450 "Return a marker to the maximum permissible value of point in this buffer.\n\
451 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)\n\
452 is in effect, in which case it is less.")
455 return buildmark (ZV
, ZV_BYTE
);
458 DEFUN ("position-bytes", Fposition_bytes
, Sposition_bytes
, 1, 1, 0,
459 "Return the byte position for character position POSITION.")
462 CHECK_NUMBER (position
, 1);
463 return make_number (CHAR_TO_BYTE (position
));
466 DEFUN ("following-char", Ffollowing_char
, Sfollowing_char
, 0, 0, 0,
467 "Return the character following point, as a number.\n\
468 At the end of the buffer or accessible region, return 0.\n\
469 If `enable-multibyte-characters' is nil or point is not\n\
470 at character boundary, multibyte form is ignored,\n\
471 and only one byte following point is returned as a character.")
476 XSETFASTINT (temp
, 0);
478 XSETFASTINT (temp
, FETCH_CHAR (PT_BYTE
));
482 DEFUN ("preceding-char", Fprevious_char
, Sprevious_char
, 0, 0, 0,
483 "Return the character preceding point, as a number.\n\
484 At the beginning of the buffer or accessible region, return 0.\n\
485 If `enable-multibyte-characters' is nil or point is not\n\
486 at character boundary, multi-byte form is ignored,\n\
487 and only one byte preceding point is returned as a character.")
492 XSETFASTINT (temp
, 0);
493 else if (!NILP (current_buffer
->enable_multibyte_characters
))
497 XSETFASTINT (temp
, FETCH_CHAR (pos
));
500 XSETFASTINT (temp
, FETCH_BYTE (PT_BYTE
- 1));
504 DEFUN ("bobp", Fbobp
, Sbobp
, 0, 0, 0,
505 "Return t if point is at the beginning of the buffer.\n\
506 If the buffer is narrowed, this means the beginning of the narrowed part.")
514 DEFUN ("eobp", Feobp
, Seobp
, 0, 0, 0,
515 "Return t if point is at the end of the buffer.\n\
516 If the buffer is narrowed, this means the end of the narrowed part.")
524 DEFUN ("bolp", Fbolp
, Sbolp
, 0, 0, 0,
525 "Return t if point is at the beginning of a line.")
528 if (PT
== BEGV
|| FETCH_BYTE (PT_BYTE
- 1) == '\n')
533 DEFUN ("eolp", Feolp
, Seolp
, 0, 0, 0,
534 "Return t if point is at the end of a line.\n\
535 `End of a line' includes point being at the end of the buffer.")
538 if (PT
== ZV
|| FETCH_BYTE (PT_BYTE
) == '\n')
543 DEFUN ("char-after", Fchar_after
, Schar_after
, 0, 1, 0,
544 "Return character in current buffer at position POS.\n\
545 POS is an integer or a buffer pointer.\n\
546 If POS is out of range, the value is nil.\n\
547 If `enable-multibyte-characters' is nil or POS is not at character boundary,\n\
548 multi-byte form is ignored, and only one byte at POS\n\
549 is returned as a character.")
553 register int pos_byte
;
554 register Lisp_Object val
;
557 return make_number (FETCH_CHAR (PT_BYTE
));
560 pos_byte
= marker_byte_position (pos
);
563 CHECK_NUMBER_COERCE_MARKER (pos
, 0);
565 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
568 if (pos_byte
< BEGV_BYTE
|| pos_byte
>= ZV_BYTE
)
571 return make_number (FETCH_CHAR (pos_byte
));
574 DEFUN ("char-before", Fchar_before
, Schar_before
, 0, 1, 0,
575 "Return character in current buffer preceding position POS.\n\
576 POS is an integer or a buffer pointer.\n\
577 If POS is out of range, the value is nil.\n\
578 If `enable-multibyte-characters' is nil or POS is not at character boundary,\n\
579 multi-byte form is ignored, and only one byte preceding POS\n\
580 is returned as a character.")
584 register Lisp_Object val
;
585 register int pos_byte
;
589 else if (MARKERP (pos
))
590 pos_byte
= marker_byte_position (pos
);
593 CHECK_NUMBER_COERCE_MARKER (pos
, 0);
595 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
598 if (pos_byte
<= BEGV_BYTE
|| pos_byte
> ZV_BYTE
)
601 if (!NILP (current_buffer
->enable_multibyte_characters
))
604 XSETFASTINT (val
, FETCH_CHAR (pos_byte
));
609 XSETFASTINT (val
, FETCH_BYTE (pos_byte
));
614 DEFUN ("user-login-name", Fuser_login_name
, Suser_login_name
, 0, 1, 0,
615 "Return the name under which the user logged in, as a string.\n\
616 This is based on the effective uid, not the real uid.\n\
617 Also, if the environment variable LOGNAME or USER is set,\n\
618 that determines the value of this function.\n\n\
619 If optional argument UID is an integer, return the login name of the user\n\
620 with that uid, or nil if there is no such user.")
626 /* Set up the user name info if we didn't do it before.
627 (That can happen if Emacs is dumpable
628 but you decide to run `temacs -l loadup' and not dump. */
629 if (INTEGERP (Vuser_login_name
))
633 return Vuser_login_name
;
635 CHECK_NUMBER (uid
, 0);
636 pw
= (struct passwd
*) getpwuid (XINT (uid
));
637 return (pw
? build_string (pw
->pw_name
) : Qnil
);
640 DEFUN ("user-real-login-name", Fuser_real_login_name
, Suser_real_login_name
,
642 "Return the name of the user's real uid, as a string.\n\
643 This ignores the environment variables LOGNAME and USER, so it differs from\n\
644 `user-login-name' when running under `su'.")
647 /* Set up the user name info if we didn't do it before.
648 (That can happen if Emacs is dumpable
649 but you decide to run `temacs -l loadup' and not dump. */
650 if (INTEGERP (Vuser_login_name
))
652 return Vuser_real_login_name
;
655 DEFUN ("user-uid", Fuser_uid
, Suser_uid
, 0, 0, 0,
656 "Return the effective uid of Emacs, as an integer.")
659 return make_number (geteuid ());
662 DEFUN ("user-real-uid", Fuser_real_uid
, Suser_real_uid
, 0, 0, 0,
663 "Return the real uid of Emacs, as an integer.")
666 return make_number (getuid ());
669 DEFUN ("user-full-name", Fuser_full_name
, Suser_full_name
, 0, 1, 0,
670 "Return the full name of the user logged in, as a string.\n\
671 If optional argument UID is an integer, return the full name of the user\n\
672 with that uid, or \"unknown\" if there is no such user.\n\
673 If UID is a string, return the full name of the user with that login\n\
674 name, or \"unknown\" if no such user could be found.")
679 register unsigned char *p
, *q
;
680 extern char *index ();
684 return Vuser_full_name
;
685 else if (NUMBERP (uid
))
686 pw
= (struct passwd
*) getpwuid (XINT (uid
));
687 else if (STRINGP (uid
))
688 pw
= (struct passwd
*) getpwnam (XSTRING (uid
)->data
);
690 error ("Invalid UID specification");
695 p
= (unsigned char *) USER_FULL_NAME
;
696 /* Chop off everything after the first comma. */
697 q
= (unsigned char *) index (p
, ',');
698 full
= make_string (p
, q
? q
- p
: strlen (p
));
700 #ifdef AMPERSAND_FULL_NAME
701 p
= XSTRING (full
)->data
;
702 q
= (unsigned char *) index (p
, '&');
703 /* Substitute the login name for the &, upcasing the first character. */
706 register unsigned char *r
;
709 login
= Fuser_login_name (make_number (pw
->pw_uid
));
710 r
= (unsigned char *) alloca (strlen (p
) + XSTRING (login
)->size
+ 1);
713 strcat (r
, XSTRING (login
)->data
);
714 r
[q
- p
] = UPCASE (r
[q
- p
]);
716 full
= build_string (r
);
718 #endif /* AMPERSAND_FULL_NAME */
723 DEFUN ("system-name", Fsystem_name
, Ssystem_name
, 0, 0, 0,
724 "Return the name of the machine you are running on, as a string.")
730 /* For the benefit of callers who don't want to include lisp.h */
734 if (STRINGP (Vsystem_name
))
735 return (char *) XSTRING (Vsystem_name
)->data
;
740 DEFUN ("emacs-pid", Femacs_pid
, Semacs_pid
, 0, 0, 0,
741 "Return the process ID of Emacs, as an integer.")
744 return make_number (getpid ());
747 DEFUN ("current-time", Fcurrent_time
, Scurrent_time
, 0, 0, 0,
748 "Return the current time, as the number of seconds since 1970-01-01 00:00:00.\n\
749 The time is returned as a list of three integers. The first has the\n\
750 most significant 16 bits of the seconds, while the second has the\n\
751 least significant 16 bits. The third integer gives the microsecond\n\
754 The microsecond count is zero on systems that do not provide\n\
755 resolution finer than a second.")
759 Lisp_Object result
[3];
762 XSETINT (result
[0], (EMACS_SECS (t
) >> 16) & 0xffff);
763 XSETINT (result
[1], (EMACS_SECS (t
) >> 0) & 0xffff);
764 XSETINT (result
[2], EMACS_USECS (t
));
766 return Flist (3, result
);
771 lisp_time_argument (specified_time
, result
)
772 Lisp_Object specified_time
;
775 if (NILP (specified_time
))
776 return time (result
) != -1;
779 Lisp_Object high
, low
;
780 high
= Fcar (specified_time
);
781 CHECK_NUMBER (high
, 0);
782 low
= Fcdr (specified_time
);
785 CHECK_NUMBER (low
, 0);
786 *result
= (XINT (high
) << 16) + (XINT (low
) & 0xffff);
787 return *result
>> 16 == XINT (high
);
792 DEFUN ("format-time-string", Fformat_time_string, Sformat_time_string, 1, 3, 0,
793 "Use FORMAT-STRING to format the time TIME, or now if omitted.\n\
794 TIME is specified as (HIGH LOW . IGNORED) or (HIGH . LOW), as returned by\n\
795 `current-time' or `file-attributes'.\n\
796 The third, optional, argument UNIVERSAL, if non-nil, means describe TIME\n\
797 as Universal Time; nil means describe TIME in the local time zone.\n\
798 The value is a copy of FORMAT-STRING, but with certain constructs replaced\n\
799 by text that describes the specified date and time in TIME:\n\
801 %Y is the year, %y within the century, %C the century.\n\
802 %G is the year corresponding to the ISO week, %g within the century.\n\
803 %m is the numeric month.\n\
804 %b and %h are the locale's abbreviated month name, %B the full name.\n\
805 %d is the day of the month, zero-padded, %e is blank-padded.\n\
806 %u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.\n\
807 %a is the locale's abbreviated name of the day of week, %A the full name.\n\
808 %U is the week number starting on Sunday, %W starting on Monday,\n\
809 %V according to ISO 8601.\n\
810 %j is the day of the year.\n\
812 %H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H\n\
813 only blank-padded, %l is like %I blank-padded.\n\
814 %p is the locale's equivalent of either AM or PM.\n\
817 %Z is the time zone name, %z is the numeric form.\n\
818 %s is the number of seconds since 1970-01-01 00:00:00 +0000.\n\
820 %c is the locale's date and time format.\n\
821 %x is the locale's \"preferred\" date format.\n\
822 %D is like \"%m/%d/%y\".\n\
824 %R is like \"%H:%M\", %T is like \"%H:%M:%S\", %r is like \"%I:%M:%S %p\".\n\
825 %X is the locale's \"preferred\" time format.\n\
827 Finally, %n is a newline, %t is a tab, %% is a literal %.\n\
829 Certain flags and modifiers are available with some format controls.\n\
830 The flags are `_' and `-'. For certain characters X, %_X is like %X,\n\
831 but padded with blanks; %-X is like %X, but without padding.\n\
832 %NX (where N stands for an integer) is like %X,\n\
833 but takes up at least N (a number) positions.\n\
834 The modifiers are `E' and `O'. For certain characters X,\n\
835 %EX is a locale's alternative version of %X;\n\
836 %OX is like %X, but uses the locale's number symbols.\n\
838 For example, to produce full ISO 8601 format, use \"%Y-%m-%dT%T%z\".")
839 (format_string, time, universal)
842 DEFUN ("format-time-string", Fformat_time_string
, Sformat_time_string
, 1, 3, 0,
843 0 /* See immediately above */)
844 (format_string
, time
, universal
)
845 Lisp_Object format_string
, time
, universal
;
850 CHECK_STRING (format_string
, 1);
852 if (! lisp_time_argument (time
, &value
))
853 error ("Invalid time specification");
855 /* This is probably enough. */
856 size
= XSTRING (format_string
)->size_byte
* 6 + 50;
860 char *buf
= (char *) alloca (size
+ 1);
864 result
= emacs_strftime (buf
, size
, XSTRING (format_string
)->data
,
865 (NILP (universal
) ? localtime (&value
)
867 if ((result
> 0 && result
< size
) || (result
== 0 && buf
[0] == '\0'))
868 return build_string (buf
);
870 /* If buffer was too small, make it bigger and try again. */
871 result
= emacs_strftime (NULL
, 0x7fffffff, XSTRING (format_string
)->data
,
872 (NILP (universal
) ? localtime (&value
)
878 DEFUN ("decode-time", Fdecode_time
, Sdecode_time
, 0, 1, 0,
879 "Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST ZONE).\n\
880 The optional SPECIFIED-TIME should be a list of (HIGH LOW . IGNORED)\n\
881 or (HIGH . LOW), as from `current-time' and `file-attributes', or `nil'\n\
882 to use the current time. The list has the following nine members:\n\
883 SEC is an integer between 0 and 60; SEC is 60 for a leap second, which\n\
884 only some operating systems support. MINUTE is an integer between 0 and 59.\n\
885 HOUR is an integer between 0 and 23. DAY is an integer between 1 and 31.\n\
886 MONTH is an integer between 1 and 12. YEAR is an integer indicating the\n\
887 four-digit year. DOW is the day of week, an integer between 0 and 6, where\n\
888 0 is Sunday. DST is t if daylight savings time is effect, otherwise nil.\n\
889 ZONE is an integer indicating the number of seconds east of Greenwich.\n\
890 \(Note that Common Lisp has different meanings for DOW and ZONE.)")
892 Lisp_Object specified_time
;
896 struct tm
*decoded_time
;
897 Lisp_Object list_args
[9];
899 if (! lisp_time_argument (specified_time
, &time_spec
))
900 error ("Invalid time specification");
902 decoded_time
= localtime (&time_spec
);
903 XSETFASTINT (list_args
[0], decoded_time
->tm_sec
);
904 XSETFASTINT (list_args
[1], decoded_time
->tm_min
);
905 XSETFASTINT (list_args
[2], decoded_time
->tm_hour
);
906 XSETFASTINT (list_args
[3], decoded_time
->tm_mday
);
907 XSETFASTINT (list_args
[4], decoded_time
->tm_mon
+ 1);
908 XSETINT (list_args
[5], decoded_time
->tm_year
+ 1900);
909 XSETFASTINT (list_args
[6], decoded_time
->tm_wday
);
910 list_args
[7] = (decoded_time
->tm_isdst
)? Qt
: Qnil
;
912 /* Make a copy, in case gmtime modifies the struct. */
913 save_tm
= *decoded_time
;
914 decoded_time
= gmtime (&time_spec
);
915 if (decoded_time
== 0)
918 XSETINT (list_args
[8], tm_diff (&save_tm
, decoded_time
));
919 return Flist (9, list_args
);
922 DEFUN ("encode-time", Fencode_time
, Sencode_time
, 6, MANY
, 0,
923 "Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.\n\
924 This is the reverse operation of `decode-time', which see.\n\
925 ZONE defaults to the current time zone rule. This can\n\
926 be a string or t (as from `set-time-zone-rule'), or it can be a list\n\
927 \(as from `current-time-zone') or an integer (as from `decode-time')\n\
928 applied without consideration for daylight savings time.\n\
930 You can pass more than 7 arguments; then the first six arguments\n\
931 are used as SECOND through YEAR, and the *last* argument is used as ZONE.\n\
932 The intervening arguments are ignored.\n\
933 This feature lets (apply 'encode-time (decode-time ...)) work.\n\
935 Out-of-range values for SEC, MINUTE, HOUR, DAY, or MONTH are allowed;\n\
936 for example, a DAY of 0 means the day preceding the given month.\n\
937 Year numbers less than 100 are treated just like other year numbers.\n\
938 If you want them to stand for years in this century, you must do that yourself.")
941 register Lisp_Object
*args
;
945 Lisp_Object zone
= (nargs
> 6 ? args
[nargs
- 1] : Qnil
);
947 CHECK_NUMBER (args
[0], 0); /* second */
948 CHECK_NUMBER (args
[1], 1); /* minute */
949 CHECK_NUMBER (args
[2], 2); /* hour */
950 CHECK_NUMBER (args
[3], 3); /* day */
951 CHECK_NUMBER (args
[4], 4); /* month */
952 CHECK_NUMBER (args
[5], 5); /* year */
954 tm
.tm_sec
= XINT (args
[0]);
955 tm
.tm_min
= XINT (args
[1]);
956 tm
.tm_hour
= XINT (args
[2]);
957 tm
.tm_mday
= XINT (args
[3]);
958 tm
.tm_mon
= XINT (args
[4]) - 1;
959 tm
.tm_year
= XINT (args
[5]) - 1900;
970 char **oldenv
= environ
, **newenv
;
974 else if (STRINGP (zone
))
975 tzstring
= (char *) XSTRING (zone
)->data
;
976 else if (INTEGERP (zone
))
978 int abszone
= abs (XINT (zone
));
979 sprintf (tzbuf
, "XXX%s%d:%02d:%02d", "-" + (XINT (zone
) < 0),
980 abszone
/ (60*60), (abszone
/60) % 60, abszone
% 60);
984 error ("Invalid time zone specification");
986 /* Set TZ before calling mktime; merely adjusting mktime's returned
987 value doesn't suffice, since that would mishandle leap seconds. */
988 set_time_zone_rule (tzstring
);
992 /* Restore TZ to previous value. */
996 #ifdef LOCALTIME_CACHE
1001 if (time
== (time_t) -1)
1002 error ("Specified time is not representable");
1004 return make_time (time
);
1007 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
, 0, 1, 0,
1008 "Return the current time, as a human-readable string.\n\
1009 Programs can use this function to decode a time,\n\
1010 since the number of columns in each field is fixed.\n\
1011 The format is `Sun Sep 16 01:03:52 1973'.\n\
1012 However, see also the functions `decode-time' and `format-time-string'\n\
1013 which provide a much more powerful and general facility.\n\
1015 If an argument is given, it specifies a time to format\n\
1016 instead of the current time. The argument should have the form:\n\
1019 (HIGH LOW . IGNORED).\n\
1020 Thus, you can use times obtained from `current-time'\n\
1021 and from `file-attributes'.")
1023 Lisp_Object specified_time
;
1029 if (! lisp_time_argument (specified_time
, &value
))
1031 tem
= (char *) ctime (&value
);
1033 strncpy (buf
, tem
, 24);
1036 return build_string (buf
);
1039 #define TM_YEAR_BASE 1900
1041 /* Yield A - B, measured in seconds.
1042 This function is copied from the GNU C Library. */
1047 /* Compute intervening leap days correctly even if year is negative.
1048 Take care to avoid int overflow in leap day calculations,
1049 but it's OK to assume that A and B are close to each other. */
1050 int a4
= (a
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (a
->tm_year
& 3);
1051 int b4
= (b
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (b
->tm_year
& 3);
1052 int a100
= a4
/ 25 - (a4
% 25 < 0);
1053 int b100
= b4
/ 25 - (b4
% 25 < 0);
1054 int a400
= a100
>> 2;
1055 int b400
= b100
>> 2;
1056 int intervening_leap_days
= (a4
- b4
) - (a100
- b100
) + (a400
- b400
);
1057 int years
= a
->tm_year
- b
->tm_year
;
1058 int days
= (365 * years
+ intervening_leap_days
1059 + (a
->tm_yday
- b
->tm_yday
));
1060 return (60 * (60 * (24 * days
+ (a
->tm_hour
- b
->tm_hour
))
1061 + (a
->tm_min
- b
->tm_min
))
1062 + (a
->tm_sec
- b
->tm_sec
));
1065 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 1, 0,
1066 "Return the offset and name for the local time zone.\n\
1067 This returns a list of the form (OFFSET NAME).\n\
1068 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).\n\
1069 A negative value means west of Greenwich.\n\
1070 NAME is a string giving the name of the time zone.\n\
1071 If an argument is given, it specifies when the time zone offset is determined\n\
1072 instead of using the current time. The argument should have the form:\n\
1075 (HIGH LOW . IGNORED).\n\
1076 Thus, you can use times obtained from `current-time'\n\
1077 and from `file-attributes'.\n\
1079 Some operating systems cannot provide all this information to Emacs;\n\
1080 in this case, `current-time-zone' returns a list containing nil for\n\
1081 the data it can't find.")
1083 Lisp_Object specified_time
;
1088 if (lisp_time_argument (specified_time
, &value
)
1089 && (t
= gmtime (&value
)) != 0)
1095 gmt
= *t
; /* Make a copy, in case localtime modifies *t. */
1096 t
= localtime (&value
);
1097 offset
= tm_diff (t
, &gmt
);
1101 s
= (char *)t
->tm_zone
;
1102 #else /* not HAVE_TM_ZONE */
1104 if (t
->tm_isdst
== 0 || t
->tm_isdst
== 1)
1105 s
= tzname
[t
->tm_isdst
];
1107 #endif /* not HAVE_TM_ZONE */
1110 /* No local time zone name is available; use "+-NNNN" instead. */
1111 int am
= (offset
< 0 ? -offset
: offset
) / 60;
1112 sprintf (buf
, "%c%02d%02d", (offset
< 0 ? '-' : '+'), am
/60, am
%60);
1115 return Fcons (make_number (offset
), Fcons (build_string (s
), Qnil
));
1118 return Fmake_list (make_number (2), Qnil
);
1121 /* This holds the value of `environ' produced by the previous
1122 call to Fset_time_zone_rule, or 0 if Fset_time_zone_rule
1123 has never been called. */
1124 static char **environbuf
;
1126 DEFUN ("set-time-zone-rule", Fset_time_zone_rule
, Sset_time_zone_rule
, 1, 1, 0,
1127 "Set the local time zone using TZ, a string specifying a time zone rule.\n\
1128 If TZ is nil, use implementation-defined default time zone information.\n\
1129 If TZ is t, use Universal Time.")
1137 else if (EQ (tz
, Qt
))
1141 CHECK_STRING (tz
, 0);
1142 tzstring
= (char *) XSTRING (tz
)->data
;
1145 set_time_zone_rule (tzstring
);
1148 environbuf
= environ
;
1153 #ifdef LOCALTIME_CACHE
1155 /* These two values are known to load tz files in buggy implementations,
1156 i.e. Solaris 1 executables running under either Solaris 1 or Solaris 2.
1157 Their values shouldn't matter in non-buggy implementations.
1158 We don't use string literals for these strings,
1159 since if a string in the environment is in readonly
1160 storage, it runs afoul of bugs in SVR4 and Solaris 2.3.
1161 See Sun bugs 1113095 and 1114114, ``Timezone routines
1162 improperly modify environment''. */
1164 static char set_time_zone_rule_tz1
[] = "TZ=GMT+0";
1165 static char set_time_zone_rule_tz2
[] = "TZ=GMT+1";
1169 /* Set the local time zone rule to TZSTRING.
1170 This allocates memory into `environ', which it is the caller's
1171 responsibility to free. */
1173 set_time_zone_rule (tzstring
)
1177 char **from
, **to
, **newenv
;
1179 /* Make the ENVIRON vector longer with room for TZSTRING. */
1180 for (from
= environ
; *from
; from
++)
1182 envptrs
= from
- environ
+ 2;
1183 newenv
= to
= (char **) xmalloc (envptrs
* sizeof (char *)
1184 + (tzstring
? strlen (tzstring
) + 4 : 0));
1186 /* Add TZSTRING to the end of environ, as a value for TZ. */
1189 char *t
= (char *) (to
+ envptrs
);
1191 strcat (t
, tzstring
);
1195 /* Copy the old environ vector elements into NEWENV,
1196 but don't copy the TZ variable.
1197 So we have only one definition of TZ, which came from TZSTRING. */
1198 for (from
= environ
; *from
; from
++)
1199 if (strncmp (*from
, "TZ=", 3) != 0)
1205 /* If we do have a TZSTRING, NEWENV points to the vector slot where
1206 the TZ variable is stored. If we do not have a TZSTRING,
1207 TO points to the vector slot which has the terminating null. */
1209 #ifdef LOCALTIME_CACHE
1211 /* In SunOS 4.1.3_U1 and 4.1.4, if TZ has a value like
1212 "US/Pacific" that loads a tz file, then changes to a value like
1213 "XXX0" that does not load a tz file, and then changes back to
1214 its original value, the last change is (incorrectly) ignored.
1215 Also, if TZ changes twice in succession to values that do
1216 not load a tz file, tzset can dump core (see Sun bug#1225179).
1217 The following code works around these bugs. */
1221 /* Temporarily set TZ to a value that loads a tz file
1222 and that differs from tzstring. */
1224 *newenv
= (strcmp (tzstring
, set_time_zone_rule_tz1
+ 3) == 0
1225 ? set_time_zone_rule_tz2
: set_time_zone_rule_tz1
);
1231 /* The implied tzstring is unknown, so temporarily set TZ to
1232 two different values that each load a tz file. */
1233 *to
= set_time_zone_rule_tz1
;
1236 *to
= set_time_zone_rule_tz2
;
1241 /* Now TZ has the desired value, and tzset can be invoked safely. */
1248 /* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC
1249 (if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a
1250 type of object is Lisp_String). INHERIT is passed to
1251 INSERT_FROM_STRING_FUNC as the last argument. */
1254 general_insert_function (insert_func
, insert_from_string_func
,
1255 inherit
, nargs
, args
)
1256 void (*insert_func
) P_ ((unsigned char *, int));
1257 void (*insert_from_string_func
) P_ ((Lisp_Object
, int, int, int, int, int));
1259 register Lisp_Object
*args
;
1261 register int argnum
;
1262 register Lisp_Object val
;
1264 for (argnum
= 0; argnum
< nargs
; argnum
++)
1270 unsigned char workbuf
[4], *str
;
1273 if (!NILP (current_buffer
->enable_multibyte_characters
))
1274 len
= CHAR_STRING (XFASTINT (val
), workbuf
, str
);
1276 workbuf
[0] = XINT (val
), str
= workbuf
, len
= 1;
1277 (*insert_func
) (str
, len
);
1279 else if (STRINGP (val
))
1281 (*insert_from_string_func
) (val
, 0, 0,
1282 XSTRING (val
)->size
,
1283 XSTRING (val
)->size_byte
,
1288 val
= wrong_type_argument (Qchar_or_string_p
, val
);
1302 /* Callers passing one argument to Finsert need not gcpro the
1303 argument "array", since the only element of the array will
1304 not be used after calling insert or insert_from_string, so
1305 we don't care if it gets trashed. */
1307 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
1308 "Insert the arguments, either strings or characters, at point.\n\
1309 Point and before-insertion-markers move forward so that it ends up\n\
1310 after the inserted text.\n\
1311 Any other markers at the point of insertion remain before the text.")
1314 register Lisp_Object
*args
;
1316 general_insert_function (insert
, insert_from_string
, 0, nargs
, args
);
1320 DEFUN ("insert-and-inherit", Finsert_and_inherit
, Sinsert_and_inherit
,
1322 "Insert the arguments at point, inheriting properties from adjoining text.\n\
1323 Point and before-insertion-markers move forward so that it ends up\n\
1324 after the inserted text.\n\
1325 Any other markers at the point of insertion remain before the text.")
1328 register Lisp_Object
*args
;
1330 general_insert_function (insert_and_inherit
, insert_from_string
, 1,
1335 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
1336 "Insert strings or characters at point, relocating markers after the text.\n\
1337 Point and before-insertion-markers move forward so that it ends up\n\
1338 after the inserted text.\n\
1339 Any other markers at the point of insertion also end up after the text.")
1342 register Lisp_Object
*args
;
1344 general_insert_function (insert_before_markers
,
1345 insert_from_string_before_markers
, 0,
1350 DEFUN ("insert-before-markers-and-inherit", Finsert_and_inherit_before_markers
,
1351 Sinsert_and_inherit_before_markers
, 0, MANY
, 0,
1352 "Insert text at point, relocating markers and inheriting properties.\n\
1353 Point moves forward so that it ends up after the inserted text.\n\
1354 Any other markers at the point of insertion also end up after the text.")
1357 register Lisp_Object
*args
;
1359 general_insert_function (insert_before_markers_and_inherit
,
1360 insert_from_string_before_markers
, 1,
1365 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 2, 3, 0,
1366 "Insert COUNT (second arg) copies of CHARACTER (first arg).\n\
1367 Point and before-insertion-markers are affected as in the function `insert'.\n\
1368 Both arguments are required.\n\
1369 The optional third arg INHERIT, if non-nil, says to inherit text properties\n\
1370 from adjoining text, if those properties are sticky.")
1371 (character
, count
, inherit
)
1372 Lisp_Object character
, count
, inherit
;
1374 register unsigned char *string
;
1375 register int strlen
;
1378 unsigned char workbuf
[4], *str
;
1380 CHECK_NUMBER (character
, 0);
1381 CHECK_NUMBER (count
, 1);
1383 if (!NILP (current_buffer
->enable_multibyte_characters
))
1384 len
= CHAR_STRING (XFASTINT (character
), workbuf
, str
);
1386 workbuf
[0] = XFASTINT (character
), str
= workbuf
, len
= 1;
1387 n
= XINT (count
) * len
;
1390 strlen
= min (n
, 256 * len
);
1391 string
= (unsigned char *) alloca (strlen
);
1392 for (i
= 0; i
< strlen
; i
++)
1393 string
[i
] = str
[i
% len
];
1397 if (!NILP (inherit
))
1398 insert_and_inherit (string
, strlen
);
1400 insert (string
, strlen
);
1405 if (!NILP (inherit
))
1406 insert_and_inherit (string
, n
);
1414 /* Making strings from buffer contents. */
1416 /* Return a Lisp_String containing the text of the current buffer from
1417 START to END. If text properties are in use and the current buffer
1418 has properties in the range specified, the resulting string will also
1419 have them, if PROPS is nonzero.
1421 We don't want to use plain old make_string here, because it calls
1422 make_uninit_string, which can cause the buffer arena to be
1423 compacted. make_string has no way of knowing that the data has
1424 been moved, and thus copies the wrong data into the string. This
1425 doesn't effect most of the other users of make_string, so it should
1426 be left as is. But we should use this function when conjuring
1427 buffer substrings. */
1430 make_buffer_string (start
, end
, props
)
1434 Lisp_Object result
, tem
, tem1
;
1435 int start_byte
= CHAR_TO_BYTE (start
);
1436 int end_byte
= CHAR_TO_BYTE (end
);
1438 if (start
< GPT
&& GPT
< end
)
1441 result
= make_uninit_multibyte_string (end
- start
, end_byte
- start_byte
);
1442 bcopy (BYTE_POS_ADDR (start_byte
), XSTRING (result
)->data
,
1443 end_byte
- start_byte
);
1445 /* If desired, update and copy the text properties. */
1446 #ifdef USE_TEXT_PROPERTIES
1449 update_buffer_properties (start
, end
);
1451 tem
= Fnext_property_change (make_number (start
), Qnil
, make_number (end
));
1452 tem1
= Ftext_properties_at (make_number (start
), Qnil
);
1454 if (XINT (tem
) != end
|| !NILP (tem1
))
1455 copy_intervals_to_string (result
, current_buffer
, start
,
1463 /* Call Vbuffer_access_fontify_functions for the range START ... END
1464 in the current buffer, if necessary. */
1467 update_buffer_properties (start
, end
)
1470 #ifdef USE_TEXT_PROPERTIES
1471 /* If this buffer has some access functions,
1472 call them, specifying the range of the buffer being accessed. */
1473 if (!NILP (Vbuffer_access_fontify_functions
))
1475 Lisp_Object args
[3];
1478 args
[0] = Qbuffer_access_fontify_functions
;
1479 XSETINT (args
[1], start
);
1480 XSETINT (args
[2], end
);
1482 /* But don't call them if we can tell that the work
1483 has already been done. */
1484 if (!NILP (Vbuffer_access_fontified_property
))
1486 tem
= Ftext_property_any (args
[1], args
[2],
1487 Vbuffer_access_fontified_property
,
1490 Frun_hook_with_args (3, args
);
1493 Frun_hook_with_args (3, args
);
1498 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
1499 "Return the contents of part of the current buffer as a string.\n\
1500 The two arguments START and END are character positions;\n\
1501 they can be in either order.")
1503 Lisp_Object start
, end
;
1507 validate_region (&start
, &end
);
1511 return make_buffer_string (b
, e
, 1);
1514 DEFUN ("buffer-substring-no-properties", Fbuffer_substring_no_properties
,
1515 Sbuffer_substring_no_properties
, 2, 2, 0,
1516 "Return the characters of part of the buffer, without the text properties.\n\
1517 The two arguments START and END are character positions;\n\
1518 they can be in either order.")
1520 Lisp_Object start
, end
;
1524 validate_region (&start
, &end
);
1528 return make_buffer_string (b
, e
, 0);
1531 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
1532 "Return the contents of the current buffer as a string.\n\
1533 If narrowing is in effect, this function returns only the visible part\n\
1537 return make_buffer_string (BEGV
, ZV
, 1);
1540 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
1542 "Insert before point a substring of the contents of buffer BUFFER.\n\
1543 BUFFER may be a buffer or a buffer name.\n\
1544 Arguments START and END are character numbers specifying the substring.\n\
1545 They default to the beginning and the end of BUFFER.")
1547 Lisp_Object buf
, start
, end
;
1549 register int b
, e
, temp
;
1550 register struct buffer
*bp
, *obuf
;
1553 buffer
= Fget_buffer (buf
);
1556 bp
= XBUFFER (buffer
);
1557 if (NILP (bp
->name
))
1558 error ("Selecting deleted buffer");
1564 CHECK_NUMBER_COERCE_MARKER (start
, 0);
1571 CHECK_NUMBER_COERCE_MARKER (end
, 1);
1576 temp
= b
, b
= e
, e
= temp
;
1578 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
1579 args_out_of_range (start
, end
);
1581 obuf
= current_buffer
;
1582 set_buffer_internal_1 (bp
);
1583 update_buffer_properties (b
, e
);
1584 set_buffer_internal_1 (obuf
);
1586 insert_from_buffer (bp
, b
, e
- b
, 0);
1590 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
1592 "Compare two substrings of two buffers; return result as number.\n\
1593 the value is -N if first string is less after N-1 chars,\n\
1594 +N if first string is greater after N-1 chars, or 0 if strings match.\n\
1595 Each substring is represented as three arguments: BUFFER, START and END.\n\
1596 That makes six args in all, three for each substring.\n\n\
1597 The value of `case-fold-search' in the current buffer\n\
1598 determines whether case is significant or ignored.")
1599 (buffer1
, start1
, end1
, buffer2
, start2
, end2
)
1600 Lisp_Object buffer1
, start1
, end1
, buffer2
, start2
, end2
;
1602 register int begp1
, endp1
, begp2
, endp2
, temp
, len1
, len2
, length
, i
;
1603 register struct buffer
*bp1
, *bp2
;
1604 register Lisp_Object
*trt
1605 = (!NILP (current_buffer
->case_fold_search
)
1606 ? XCHAR_TABLE (current_buffer
->case_canon_table
)->contents
: 0);
1608 int beg1_byte
, beg2_byte
;
1610 /* Find the first buffer and its substring. */
1613 bp1
= current_buffer
;
1617 buf1
= Fget_buffer (buffer1
);
1620 bp1
= XBUFFER (buf1
);
1621 if (NILP (bp1
->name
))
1622 error ("Selecting deleted buffer");
1626 begp1
= BUF_BEGV (bp1
);
1629 CHECK_NUMBER_COERCE_MARKER (start1
, 1);
1630 begp1
= XINT (start1
);
1633 endp1
= BUF_ZV (bp1
);
1636 CHECK_NUMBER_COERCE_MARKER (end1
, 2);
1637 endp1
= XINT (end1
);
1641 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
1643 if (!(BUF_BEGV (bp1
) <= begp1
1645 && endp1
<= BUF_ZV (bp1
)))
1646 args_out_of_range (start1
, end1
);
1648 /* Likewise for second substring. */
1651 bp2
= current_buffer
;
1655 buf2
= Fget_buffer (buffer2
);
1658 bp2
= XBUFFER (buf2
);
1659 if (NILP (bp2
->name
))
1660 error ("Selecting deleted buffer");
1664 begp2
= BUF_BEGV (bp2
);
1667 CHECK_NUMBER_COERCE_MARKER (start2
, 4);
1668 begp2
= XINT (start2
);
1671 endp2
= BUF_ZV (bp2
);
1674 CHECK_NUMBER_COERCE_MARKER (end2
, 5);
1675 endp2
= XINT (end2
);
1679 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
1681 if (!(BUF_BEGV (bp2
) <= begp2
1683 && endp2
<= BUF_ZV (bp2
)))
1684 args_out_of_range (start2
, end2
);
1686 beg1_byte
= buf_charpos_to_bytepos (bp1
, begp1
);
1687 beg2_byte
= buf_charpos_to_bytepos (bp2
, begp2
);
1688 len1
= buf_charpos_to_bytepos (bp1
, endp1
) - begp1
;
1689 len2
= buf_charpos_to_bytepos (bp2
, endp2
) - begp2
;
1694 for (i
= 0; i
< length
; i
++)
1696 unsigned char *p1
= BUF_BYTE_ADDRESS (bp1
, beg1_byte
+ i
);
1698 int c2
= *BUF_BYTE_ADDRESS (bp2
, beg2_byte
+ i
);
1700 /* If a character begins here,
1701 count the previous character now. */
1703 && (NILP (current_buffer
->enable_multibyte_characters
)
1704 || CHAR_HEAD_P (*p1
)))
1709 c1
= XINT (trt
[c1
]);
1710 c2
= XINT (trt
[c2
]);
1713 return make_number (- 1 - chars
);
1715 return make_number (chars
+ 1);
1718 /* The strings match as far as they go.
1719 If one is shorter, that one is less. */
1721 return make_number (chars
+ 1);
1722 else if (length
< len2
)
1723 return make_number (- chars
- 1);
1725 /* Same length too => they are equal. */
1726 return make_number (0);
1730 subst_char_in_region_unwind (arg
)
1733 return current_buffer
->undo_list
= arg
;
1737 subst_char_in_region_unwind_1 (arg
)
1740 return current_buffer
->filename
= arg
;
1743 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
1744 Ssubst_char_in_region
, 4, 5, 0,
1745 "From START to END, replace FROMCHAR with TOCHAR each time it occurs.\n\
1746 If optional arg NOUNDO is non-nil, don't record this change for undo\n\
1747 and don't mark the buffer as really changed.\n\
1748 Both characters must have the same length of multi-byte form.")
1749 (start
, end
, fromchar
, tochar
, noundo
)
1750 Lisp_Object start
, end
, fromchar
, tochar
, noundo
;
1752 register int pos
, pos_byte
, stop
, i
, len
, end_byte
;
1754 unsigned char fromwork
[4], *fromstr
, towork
[4], *tostr
, *p
;
1755 int count
= specpdl_ptr
- specpdl
;
1757 validate_region (&start
, &end
);
1758 CHECK_NUMBER (fromchar
, 2);
1759 CHECK_NUMBER (tochar
, 3);
1761 if (! NILP (current_buffer
->enable_multibyte_characters
))
1763 len
= CHAR_STRING (XFASTINT (fromchar
), fromwork
, fromstr
);
1764 if (CHAR_STRING (XFASTINT (tochar
), towork
, tostr
) != len
)
1765 error ("Characters in subst-char-in-region have different byte-lengths");
1770 fromwork
[0] = XFASTINT (fromchar
), fromstr
= fromwork
;
1771 towork
[0] = XFASTINT (tochar
), tostr
= towork
;
1775 pos_byte
= CHAR_TO_BYTE (pos
);
1776 stop
= CHAR_TO_BYTE (XINT (end
));
1779 /* If we don't want undo, turn off putting stuff on the list.
1780 That's faster than getting rid of things,
1781 and it prevents even the entry for a first change.
1782 Also inhibit locking the file. */
1785 record_unwind_protect (subst_char_in_region_unwind
,
1786 current_buffer
->undo_list
);
1787 current_buffer
->undo_list
= Qt
;
1788 /* Don't do file-locking. */
1789 record_unwind_protect (subst_char_in_region_unwind_1
,
1790 current_buffer
->filename
);
1791 current_buffer
->filename
= Qnil
;
1794 if (pos_byte
< GPT_BYTE
)
1795 stop
= min (stop
, GPT_BYTE
);
1798 if (pos_byte
>= stop
)
1800 if (pos_byte
>= end_byte
) break;
1803 p
= BYTE_POS_ADDR (pos_byte
);
1804 if (p
[0] == fromstr
[0]
1806 || (p
[1] == fromstr
[1]
1807 && (len
== 2 || (p
[2] == fromstr
[2]
1808 && (len
== 3 || p
[3] == fromstr
[3]))))))
1812 modify_region (current_buffer
, XINT (start
), XINT (end
));
1814 if (! NILP (noundo
))
1816 if (MODIFF
- 1 == SAVE_MODIFF
)
1818 if (MODIFF
- 1 == current_buffer
->auto_save_modified
)
1819 current_buffer
->auto_save_modified
++;
1826 record_change (pos
, 1);
1827 for (i
= 0; i
< len
; i
++) *p
++ = tostr
[i
];
1831 INC_BOTH (pos
, pos_byte
);
1835 signal_after_change (XINT (start
),
1836 XINT (end
) - XINT (start
), XINT (end
) - XINT (start
));
1838 unbind_to (count
, Qnil
);
1842 DEFUN ("translate-region", Ftranslate_region
, Stranslate_region
, 3, 3, 0,
1843 "From START to END, translate characters according to TABLE.\n\
1844 TABLE is a string; the Nth character in it is the mapping\n\
1845 for the character with code N.\n\
1846 This function does not alter multibyte characters.\n\
1847 It returns the number of characters changed.")
1851 register Lisp_Object table
;
1853 register int pos_byte
, stop
; /* Limits of the region. */
1854 register unsigned char *tt
; /* Trans table. */
1855 register int nc
; /* New character. */
1856 int cnt
; /* Number of changes made. */
1857 int size
; /* Size of translate table. */
1860 validate_region (&start
, &end
);
1861 CHECK_STRING (table
, 2);
1863 size
= XSTRING (table
)->size_byte
;
1864 tt
= XSTRING (table
)->data
;
1866 pos_byte
= CHAR_TO_BYTE (XINT (start
));
1867 stop
= CHAR_TO_BYTE (XINT (end
));
1868 modify_region (current_buffer
, XINT (start
), XINT (end
));
1872 for (; pos_byte
< stop
; )
1874 register unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
1878 oc
= STRING_CHAR_AND_LENGTH (p
, stop
- pos_byte
, len
);
1879 if (oc
< size
&& len
== 1)
1884 record_change (pos
, 1);
1886 signal_after_change (pos
, 1, 1);
1894 return make_number (cnt
);
1897 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
1898 "Delete the text between point and mark.\n\
1899 When called from a program, expects two arguments,\n\
1900 positions (integers or markers) specifying the stretch to be deleted.")
1902 Lisp_Object start
, end
;
1904 validate_region (&start
, &end
);
1905 del_range (XINT (start
), XINT (end
));
1909 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
1910 "Remove restrictions (narrowing) from current buffer.\n\
1911 This allows the buffer's full text to be seen and edited.")
1914 if (BEG
!= BEGV
|| Z
!= ZV
)
1915 current_buffer
->clip_changed
= 1;
1917 BEGV_BYTE
= BEG_BYTE
;
1918 SET_BUF_ZV_BOTH (current_buffer
, Z
, Z_BYTE
);
1919 /* Changing the buffer bounds invalidates any recorded current column. */
1920 invalidate_current_column ();
1924 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
1925 "Restrict editing in this buffer to the current region.\n\
1926 The rest of the text becomes temporarily invisible and untouchable\n\
1927 but is not deleted; if you save the buffer in a file, the invisible\n\
1928 text is included in the file. \\[widen] makes all visible again.\n\
1929 See also `save-restriction'.\n\
1931 When calling from a program, pass two arguments; positions (integers\n\
1932 or markers) bounding the text that should remain visible.")
1934 register Lisp_Object start
, end
;
1936 CHECK_NUMBER_COERCE_MARKER (start
, 0);
1937 CHECK_NUMBER_COERCE_MARKER (end
, 1);
1939 if (XINT (start
) > XINT (end
))
1942 tem
= start
; start
= end
; end
= tem
;
1945 if (!(BEG
<= XINT (start
) && XINT (start
) <= XINT (end
) && XINT (end
) <= Z
))
1946 args_out_of_range (start
, end
);
1948 if (BEGV
!= XFASTINT (start
) || ZV
!= XFASTINT (end
))
1949 current_buffer
->clip_changed
= 1;
1951 SET_BUF_BEGV (current_buffer
, XFASTINT (start
));
1952 SET_BUF_ZV (current_buffer
, XFASTINT (end
));
1953 if (PT
< XFASTINT (start
))
1954 SET_PT (XFASTINT (start
));
1955 if (PT
> XFASTINT (end
))
1956 SET_PT (XFASTINT (end
));
1957 /* Changing the buffer bounds invalidates any recorded current column. */
1958 invalidate_current_column ();
1963 save_restriction_save ()
1965 register Lisp_Object bottom
, top
;
1966 /* Note: I tried using markers here, but it does not win
1967 because insertion at the end of the saved region
1968 does not advance mh and is considered "outside" the saved region. */
1969 XSETFASTINT (bottom
, BEGV
- BEG
);
1970 XSETFASTINT (top
, Z
- ZV
);
1972 return Fcons (Fcurrent_buffer (), Fcons (bottom
, top
));
1976 save_restriction_restore (data
)
1979 register struct buffer
*buf
;
1980 register int newhead
, newtail
;
1981 register Lisp_Object tem
;
1984 buf
= XBUFFER (XCONS (data
)->car
);
1986 data
= XCONS (data
)->cdr
;
1988 tem
= XCONS (data
)->car
;
1989 newhead
= XINT (tem
);
1990 tem
= XCONS (data
)->cdr
;
1991 newtail
= XINT (tem
);
1992 if (newhead
+ newtail
> BUF_Z (buf
) - BUF_BEG (buf
))
1998 obegv
= BUF_BEGV (buf
);
2001 SET_BUF_BEGV (buf
, BUF_BEG (buf
) + newhead
);
2002 SET_BUF_ZV (buf
, BUF_Z (buf
) - newtail
);
2004 if (obegv
!= BUF_BEGV (buf
) || ozv
!= BUF_ZV (buf
))
2005 current_buffer
->clip_changed
= 1;
2007 /* If point is outside the new visible range, move it inside. */
2008 SET_BUF_PT_BOTH (buf
,
2009 clip_to_bounds (BUF_BEGV (buf
), BUF_PT (buf
), BUF_ZV (buf
)),
2010 clip_to_bounds (BUF_BEGV_BYTE (buf
), BUF_PT_BYTE (buf
),
2011 BUF_ZV_BYTE (buf
)));
2016 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
2017 "Execute BODY, saving and restoring current buffer's restrictions.\n\
2018 The buffer's restrictions make parts of the beginning and end invisible.\n\
2019 \(They are set up with `narrow-to-region' and eliminated with `widen'.)\n\
2020 This special form, `save-restriction', saves the current buffer's restrictions\n\
2021 when it is entered, and restores them when it is exited.\n\
2022 So any `narrow-to-region' within BODY lasts only until the end of the form.\n\
2023 The old restrictions settings are restored\n\
2024 even in case of abnormal exit (throw or error).\n\
2026 The value returned is the value of the last form in BODY.\n\
2028 `save-restriction' can get confused if, within the BODY, you widen\n\
2029 and then make changes outside the area within the saved restrictions.\n\
2031 Note: if you are using both `save-excursion' and `save-restriction',\n\
2032 use `save-excursion' outermost:\n\
2033 (save-excursion (save-restriction ...))")
2037 register Lisp_Object val
;
2038 int count
= specpdl_ptr
- specpdl
;
2040 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
2041 val
= Fprogn (body
);
2042 return unbind_to (count
, val
);
2045 /* Buffer for the most recent text displayed by Fmessage. */
2046 static char *message_text
;
2048 /* Allocated length of that buffer. */
2049 static int message_length
;
2051 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
2052 "Print a one-line message at the bottom of the screen.\n\
2053 The first argument is a format control string, and the rest are data\n\
2054 to be formatted under control of the string. See `format' for details.\n\
2056 If the first argument is nil, clear any existing message; let the\n\
2057 minibuffer contents show.")
2069 register Lisp_Object val
;
2070 val
= Fformat (nargs
, args
);
2071 /* Copy the data so that it won't move when we GC. */
2074 message_text
= (char *)xmalloc (80);
2075 message_length
= 80;
2077 if (XSTRING (val
)->size
> message_length
)
2079 message_length
= XSTRING (val
)->size_byte
;
2080 message_text
= (char *)xrealloc (message_text
, message_length
);
2082 bcopy (XSTRING (val
)->data
, message_text
, XSTRING (val
)->size_byte
);
2083 message2 (message_text
, XSTRING (val
)->size_byte
,
2084 STRING_MULTIBYTE (val
));
2089 DEFUN ("message-box", Fmessage_box
, Smessage_box
, 1, MANY
, 0,
2090 "Display a message, in a dialog box if possible.\n\
2091 If a dialog box is not available, use the echo area.\n\
2092 The first argument is a format control string, and the rest are data\n\
2093 to be formatted under control of the string. See `format' for details.\n\
2095 If the first argument is nil, clear any existing message; let the\n\
2096 minibuffer contents show.")
2108 register Lisp_Object val
;
2109 val
= Fformat (nargs
, args
);
2112 Lisp_Object pane
, menu
, obj
;
2113 struct gcpro gcpro1
;
2114 pane
= Fcons (Fcons (build_string ("OK"), Qt
), Qnil
);
2116 menu
= Fcons (val
, pane
);
2117 obj
= Fx_popup_dialog (Qt
, menu
);
2121 #else /* not HAVE_MENUS */
2122 /* Copy the data so that it won't move when we GC. */
2125 message_text
= (char *)xmalloc (80);
2126 message_length
= 80;
2128 if (XSTRING (val
)->size_byte
> message_length
)
2130 message_length
= XSTRING (val
)->size_byte
;
2131 message_text
= (char *)xrealloc (message_text
, message_length
);
2133 bcopy (XSTRING (val
)->data
, message_text
, XSTRING (val
)->size_byte
);
2134 message2 (message_text
, XSTRING (val
)->size_byte
);
2136 #endif /* not HAVE_MENUS */
2140 extern Lisp_Object last_nonmenu_event
;
2143 DEFUN ("message-or-box", Fmessage_or_box
, Smessage_or_box
, 1, MANY
, 0,
2144 "Display a message in a dialog box or in the echo area.\n\
2145 If this command was invoked with the mouse, use a dialog box.\n\
2146 Otherwise, use the echo area.\n\
2147 The first argument is a format control string, and the rest are data\n\
2148 to be formatted under control of the string. See `format' for details.\n\
2150 If the first argument is nil, clear any existing message; let the\n\
2151 minibuffer contents show.")
2157 if (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2158 return Fmessage_box (nargs
, args
);
2160 return Fmessage (nargs
, args
);
2163 DEFUN ("current-message", Fcurrent_message
, Scurrent_message
, 0, 0, 0,
2164 "Return the string currently displayed in the echo area, or nil if none.")
2167 return (echo_area_glyphs
2168 ? make_string (echo_area_glyphs
, echo_area_glyphs_length
)
2172 /* Number of bytes that STRING will occupy when put into the result.
2173 MULTIBYTE is nonzero if the result should be multibyte. */
2175 #define CONVERTED_BYTE_SIZE(MULTIBYTE, STRING) \
2176 (((MULTIBYTE) && ! STRING_MULTIBYTE (STRING)) \
2177 ? count_size_as_multibyte (XSTRING (STRING)->data, \
2178 XSTRING (STRING)->size_byte) \
2179 : XSTRING (STRING)->size_byte)
2181 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
2182 "Format a string out of a control-string and arguments.\n\
2183 The first argument is a control string.\n\
2184 The other arguments are substituted into it to make the result, a string.\n\
2185 It may contain %-sequences meaning to substitute the next argument.\n\
2186 %s means print a string argument. Actually, prints any object, with `princ'.\n\
2187 %d means print as number in decimal (%o octal, %x hex).\n\
2188 %e means print a number in exponential notation.\n\
2189 %f means print a number in decimal-point notation.\n\
2190 %g means print a number in exponential notation\n\
2191 or decimal-point notation, whichever uses fewer characters.\n\
2192 %c means print a number as a single character.\n\
2193 %S means print any object as an s-expression (using prin1).\n\
2194 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.\n\
2195 Use %% to put a single % into the output.")
2198 register Lisp_Object
*args
;
2200 register int n
; /* The number of the next arg to substitute */
2201 register int total
; /* An estimate of the final length */
2203 register unsigned char *format
, *end
;
2205 /* Nonzero if the output should be a multibyte string,
2206 which is true if any of the inputs is one. */
2208 unsigned char *this_format
;
2212 extern char *index ();
2214 /* It should not be necessary to GCPRO ARGS, because
2215 the caller in the interpreter should take care of that. */
2217 /* Try to determine whether the result should be multibyte.
2218 This is not always right; sometimes the result needs to be multibyte
2219 because of an object that we will pass through prin1,
2220 and in that case, we won't know it here. */
2221 for (n
= 0; n
< nargs
; n
++)
2222 if (STRINGP (args
[n
]) && STRING_MULTIBYTE (args
[n
]))
2225 CHECK_STRING (args
[0], 0);
2227 /* If we start out planning a unibyte result,
2228 and later find it has to be multibyte, we jump back to retry. */
2231 format
= XSTRING (args
[0])->data
;
2232 end
= format
+ XSTRING (args
[0])->size_byte
;
2235 /* Make room in result for all the non-%-codes in the control string. */
2236 total
= 5 + CONVERTED_BYTE_SIZE (multibyte
, args
[0]);
2238 /* Add to TOTAL enough space to hold the converted arguments. */
2241 while (format
!= end
)
2242 if (*format
++ == '%')
2244 int minlen
, thissize
= 0;
2245 unsigned char *this_format_start
= format
- 1;
2247 /* Process a numeric arg and skip it. */
2248 minlen
= atoi (format
);
2252 while ((*format
>= '0' && *format
<= '9')
2253 || *format
== '-' || *format
== ' ' || *format
== '.')
2256 if (format
- this_format_start
+ 1 > longest_format
)
2257 longest_format
= format
- this_format_start
+ 1;
2261 else if (++n
>= nargs
)
2262 error ("Not enough arguments for format string");
2263 else if (*format
== 'S')
2265 /* For `S', prin1 the argument and then treat like a string. */
2266 register Lisp_Object tem
;
2267 tem
= Fprin1_to_string (args
[n
], Qnil
);
2268 if (STRING_MULTIBYTE (tem
) && ! multibyte
)
2276 else if (SYMBOLP (args
[n
]))
2278 XSETSTRING (args
[n
], XSYMBOL (args
[n
])->name
);
2279 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
2286 else if (STRINGP (args
[n
]))
2289 if (*format
!= 's' && *format
!= 'S')
2290 error ("format specifier doesn't match argument type");
2291 thissize
= CONVERTED_BYTE_SIZE (multibyte
, args
[n
]);
2293 /* Would get MPV otherwise, since Lisp_Int's `point' to low memory. */
2294 else if (INTEGERP (args
[n
]) && *format
!= 's')
2296 #ifdef LISP_FLOAT_TYPE
2297 /* The following loop assumes the Lisp type indicates
2298 the proper way to pass the argument.
2299 So make sure we have a flonum if the argument should
2301 if (*format
== 'e' || *format
== 'f' || *format
== 'g')
2302 args
[n
] = Ffloat (args
[n
]);
2306 #ifdef LISP_FLOAT_TYPE
2307 else if (FLOATP (args
[n
]) && *format
!= 's')
2309 if (! (*format
== 'e' || *format
== 'f' || *format
== 'g'))
2310 args
[n
] = Ftruncate (args
[n
], Qnil
);
2316 /* Anything but a string, convert to a string using princ. */
2317 register Lisp_Object tem
;
2318 tem
= Fprin1_to_string (args
[n
], Qt
);
2319 if (STRING_MULTIBYTE (tem
))
2328 if (thissize
< minlen
)
2331 total
+= thissize
+ 4;
2334 /* Now we can no longer jump to retry.
2335 TOTAL and LONGEST_FORMAT are known for certain. */
2337 this_format
= (unsigned char *) alloca (longest_format
+ 1);
2339 /* Allocate the space for the result.
2340 Note that TOTAL is an overestimate. */
2342 buf
= (unsigned char *) alloca (total
+ 1);
2344 buf
= (unsigned char *) xmalloc (total
+ 1);
2350 /* Scan the format and store result in BUF. */
2351 format
= XSTRING (args
[0])->data
;
2352 while (format
!= end
)
2357 unsigned char *this_format_start
= format
;
2361 /* Process a numeric arg and skip it. */
2362 minlen
= atoi (format
);
2366 while ((*format
>= '0' && *format
<= '9')
2367 || *format
== '-' || *format
== ' ' || *format
== '.')
2370 if (*format
++ == '%')
2379 if (STRINGP (args
[n
]))
2381 int padding
, nbytes
;
2383 nbytes
= copy_text (XSTRING (args
[n
])->data
, p
,
2384 XSTRING (args
[n
])->size_byte
,
2385 STRING_MULTIBYTE (args
[n
]), multibyte
);
2387 nchars
+= XSTRING (args
[n
])->size
;
2389 /* If spec requires it, pad on right with spaces. */
2390 padding
= minlen
- XSTRING (args
[n
])->size
;
2391 while (padding
-- > 0)
2397 else if (INTEGERP (args
[n
]) || FLOATP (args
[n
]))
2401 bcopy (this_format_start
, this_format
,
2402 format
- this_format_start
);
2403 this_format
[format
- this_format_start
] = 0;
2405 sprintf (p
, this_format
, XINT (args
[n
]));
2407 this_nchars
= strlen (p
);
2409 nchars
+= this_nchars
;
2412 else if (STRING_MULTIBYTE (args
[0]))
2414 /* Copy a whole multibyte character. */
2416 while (! CHAR_HEAD_P (*format
)) *p
++ = *format
++;
2421 /* Convert a single-byte character to multibyte. */
2422 int len
= copy_text (format
, p
, 1, 0, 1);
2429 *p
++ = *format
++, nchars
++;
2432 val
= make_multibyte_string (buf
, nchars
, p
- buf
);
2434 /* If we allocated BUF with malloc, free it too. */
2444 format1 (string1
, arg0
, arg1
, arg2
, arg3
, arg4
)
2445 EMACS_INT arg0
, arg1
, arg2
, arg3
, arg4
;
2459 doprnt (buf
, sizeof buf
, string1
, (char *)0, 5, args
);
2461 doprnt (buf
, sizeof buf
, string1
, (char *)0, 5, &string1
+ 1);
2463 return build_string (buf
);
2466 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
2467 "Return t if two characters match, optionally ignoring case.\n\
2468 Both arguments must be characters (i.e. integers).\n\
2469 Case is ignored if `case-fold-search' is non-nil in the current buffer.")
2471 register Lisp_Object c1
, c2
;
2474 CHECK_NUMBER (c1
, 0);
2475 CHECK_NUMBER (c2
, 1);
2477 if (XINT (c1
) == XINT (c2
))
2479 if (NILP (current_buffer
->case_fold_search
))
2482 /* Do these in separate statements,
2483 then compare the variables.
2484 because of the way DOWNCASE uses temp variables. */
2485 i1
= DOWNCASE (XFASTINT (c1
));
2486 i2
= DOWNCASE (XFASTINT (c2
));
2487 return (i1
== i2
? Qt
: Qnil
);
2490 /* Transpose the markers in two regions of the current buffer, and
2491 adjust the ones between them if necessary (i.e.: if the regions
2494 START1, END1 are the character positions of the first region.
2495 START1_BYTE, END1_BYTE are the byte positions.
2496 START2, END2 are the character positions of the second region.
2497 START2_BYTE, END2_BYTE are the byte positions.
2499 Traverses the entire marker list of the buffer to do so, adding an
2500 appropriate amount to some, subtracting from some, and leaving the
2501 rest untouched. Most of this is copied from adjust_markers in insdel.c.
2503 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
2506 transpose_markers (start1
, end1
, start2
, end2
,
2507 start1_byte
, end1_byte
, start2_byte
, end2_byte
)
2508 register int start1
, end1
, start2
, end2
;
2509 register int start1_byte
, end1_byte
, start2_byte
, end2_byte
;
2511 register int amt1
, amt1_byte
, amt2
, amt2_byte
, diff
, diff_byte
, mpos
;
2512 register Lisp_Object marker
;
2514 /* Update point as if it were a marker. */
2518 TEMP_SET_PT_BOTH (PT
+ (end2
- end1
),
2519 PT_BYTE
+ (end2_byte
- end1_byte
));
2520 else if (PT
< start2
)
2521 TEMP_SET_PT_BOTH (PT
+ (end2
- start2
) - (end1
- start1
),
2522 (PT_BYTE
+ (end2_byte
- start2_byte
)
2523 - (end1_byte
- start1_byte
)));
2525 TEMP_SET_PT_BOTH (PT
- (start2
- start1
),
2526 PT_BYTE
- (start2_byte
- start1_byte
));
2528 /* We used to adjust the endpoints here to account for the gap, but that
2529 isn't good enough. Even if we assume the caller has tried to move the
2530 gap out of our way, it might still be at start1 exactly, for example;
2531 and that places it `inside' the interval, for our purposes. The amount
2532 of adjustment is nontrivial if there's a `denormalized' marker whose
2533 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
2534 the dirty work to Fmarker_position, below. */
2536 /* The difference between the region's lengths */
2537 diff
= (end2
- start2
) - (end1
- start1
);
2538 diff_byte
= (end2_byte
- start2_byte
) - (end1_byte
- start1_byte
);
2540 /* For shifting each marker in a region by the length of the other
2541 region plus the distance between the regions. */
2542 amt1
= (end2
- start2
) + (start2
- end1
);
2543 amt2
= (end1
- start1
) + (start2
- end1
);
2544 amt1_byte
= (end2_byte
- start2_byte
) + (start2_byte
- end1_byte
);
2545 amt2_byte
= (end1_byte
- start1_byte
) + (start2_byte
- end1_byte
);
2547 for (marker
= BUF_MARKERS (current_buffer
); !NILP (marker
);
2548 marker
= XMARKER (marker
)->chain
)
2550 mpos
= marker_byte_position (marker
);
2551 if (mpos
>= start1_byte
&& mpos
< end2_byte
)
2553 if (mpos
< end1_byte
)
2555 else if (mpos
< start2_byte
)
2559 XMARKER (marker
)->bytepos
= mpos
;
2561 mpos
= XMARKER (marker
)->charpos
;
2562 if (mpos
>= start1
&& mpos
< end2
)
2566 else if (mpos
< start2
)
2571 XMARKER (marker
)->charpos
= mpos
;
2575 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
2576 "Transpose region START1 to END1 with START2 to END2.\n\
2577 The regions may not be overlapping, because the size of the buffer is\n\
2578 never changed in a transposition.\n\
2580 Optional fifth arg LEAVE_MARKERS, if non-nil, means don't update\n\
2581 any markers that happen to be located in the regions.\n\
2583 Transposing beyond buffer boundaries is an error.")
2584 (startr1
, endr1
, startr2
, endr2
, leave_markers
)
2585 Lisp_Object startr1
, endr1
, startr2
, endr2
, leave_markers
;
2587 register int start1
, end1
, start2
, end2
;
2588 int start1_byte
, start2_byte
, len1_byte
, len2_byte
;
2589 int gap
, len1
, len_mid
, len2
;
2590 unsigned char *start1_addr
, *start2_addr
, *temp
;
2592 #ifdef USE_TEXT_PROPERTIES
2593 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
;
2594 cur_intv
= BUF_INTERVALS (current_buffer
);
2595 #endif /* USE_TEXT_PROPERTIES */
2597 validate_region (&startr1
, &endr1
);
2598 validate_region (&startr2
, &endr2
);
2600 start1
= XFASTINT (startr1
);
2601 end1
= XFASTINT (endr1
);
2602 start2
= XFASTINT (startr2
);
2603 end2
= XFASTINT (endr2
);
2606 /* Swap the regions if they're reversed. */
2609 register int glumph
= start1
;
2617 len1
= end1
- start1
;
2618 len2
= end2
- start2
;
2621 error ("Transposed regions not properly ordered");
2622 else if (start1
== end1
|| start2
== end2
)
2623 error ("Transposed region may not be of length 0");
2625 /* The possibilities are:
2626 1. Adjacent (contiguous) regions, or separate but equal regions
2627 (no, really equal, in this case!), or
2628 2. Separate regions of unequal size.
2630 The worst case is usually No. 2. It means that (aside from
2631 potential need for getting the gap out of the way), there also
2632 needs to be a shifting of the text between the two regions. So
2633 if they are spread far apart, we are that much slower... sigh. */
2635 /* It must be pointed out that the really studly thing to do would
2636 be not to move the gap at all, but to leave it in place and work
2637 around it if necessary. This would be extremely efficient,
2638 especially considering that people are likely to do
2639 transpositions near where they are working interactively, which
2640 is exactly where the gap would be found. However, such code
2641 would be much harder to write and to read. So, if you are
2642 reading this comment and are feeling squirrely, by all means have
2643 a go! I just didn't feel like doing it, so I will simply move
2644 the gap the minimum distance to get it out of the way, and then
2645 deal with an unbroken array. */
2647 /* Make sure the gap won't interfere, by moving it out of the text
2648 we will operate on. */
2649 if (start1
< gap
&& gap
< end2
)
2651 if (gap
- start1
< end2
- gap
)
2657 start1_byte
= CHAR_TO_BYTE (start1
);
2658 start2_byte
= CHAR_TO_BYTE (start2
);
2659 len1_byte
= CHAR_TO_BYTE (end1
) - start1_byte
;
2660 len2_byte
= CHAR_TO_BYTE (end2
) - start2_byte
;
2662 /* Hmmm... how about checking to see if the gap is large
2663 enough to use as the temporary storage? That would avoid an
2664 allocation... interesting. Later, don't fool with it now. */
2666 /* Working without memmove, for portability (sigh), so must be
2667 careful of overlapping subsections of the array... */
2669 if (end1
== start2
) /* adjacent regions */
2671 modify_region (current_buffer
, start1
, end2
);
2672 record_change (start1
, len1
+ len2
);
2674 #ifdef USE_TEXT_PROPERTIES
2675 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
2676 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
2677 Fset_text_properties (make_number (start1
), make_number (end2
),
2679 #endif /* USE_TEXT_PROPERTIES */
2681 /* First region smaller than second. */
2682 if (len1_byte
< len2_byte
)
2684 /* We use alloca only if it is small,
2685 because we want to avoid stack overflow. */
2686 if (len2_byte
> 20000)
2687 temp
= (unsigned char *) xmalloc (len2_byte
);
2689 temp
= (unsigned char *) alloca (len2_byte
);
2691 /* Don't precompute these addresses. We have to compute them
2692 at the last minute, because the relocating allocator might
2693 have moved the buffer around during the xmalloc. */
2694 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1_byte
);
2695 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2_byte
);
2697 bcopy (start2_addr
, temp
, len2_byte
);
2698 bcopy (start1_addr
, start1_addr
+ len2_byte
, len1_byte
);
2699 bcopy (temp
, start1_addr
, len2_byte
);
2700 if (len2_byte
> 20000)
2704 /* First region not smaller than second. */
2706 if (len1_byte
> 20000)
2707 temp
= (unsigned char *) xmalloc (len1_byte
);
2709 temp
= (unsigned char *) alloca (len1_byte
);
2710 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1_byte
);
2711 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2_byte
);
2712 bcopy (start1_addr
, temp
, len1_byte
);
2713 bcopy (start2_addr
, start1_addr
, len2_byte
);
2714 bcopy (temp
, start1_addr
+ len2_byte
, len1_byte
);
2715 if (len1_byte
> 20000)
2718 #ifdef USE_TEXT_PROPERTIES
2719 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
2720 len1
, current_buffer
, 0);
2721 graft_intervals_into_buffer (tmp_interval2
, start1
,
2722 len2
, current_buffer
, 0);
2723 #endif /* USE_TEXT_PROPERTIES */
2725 /* Non-adjacent regions, because end1 != start2, bleagh... */
2728 len_mid
= start2_byte
- (start1_byte
+ len1_byte
);
2730 if (len1_byte
== len2_byte
)
2731 /* Regions are same size, though, how nice. */
2733 modify_region (current_buffer
, start1
, end1
);
2734 modify_region (current_buffer
, start2
, end2
);
2735 record_change (start1
, len1
);
2736 record_change (start2
, len2
);
2737 #ifdef USE_TEXT_PROPERTIES
2738 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
2739 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
2740 Fset_text_properties (make_number (start1
), make_number (end1
),
2742 Fset_text_properties (make_number (start2
), make_number (end2
),
2744 #endif /* USE_TEXT_PROPERTIES */
2746 if (len1_byte
> 20000)
2747 temp
= (unsigned char *) xmalloc (len1_byte
);
2749 temp
= (unsigned char *) alloca (len1_byte
);
2750 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1_byte
);
2751 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2_byte
);
2752 bcopy (start1_addr
, temp
, len1_byte
);
2753 bcopy (start2_addr
, start1_addr
, len2_byte
);
2754 bcopy (temp
, start2_addr
, len1_byte
);
2755 if (len1_byte
> 20000)
2757 #ifdef USE_TEXT_PROPERTIES
2758 graft_intervals_into_buffer (tmp_interval1
, start2
,
2759 len1
, current_buffer
, 0);
2760 graft_intervals_into_buffer (tmp_interval2
, start1
,
2761 len2
, current_buffer
, 0);
2762 #endif /* USE_TEXT_PROPERTIES */
2765 else if (len1_byte
< len2_byte
) /* Second region larger than first */
2766 /* Non-adjacent & unequal size, area between must also be shifted. */
2768 modify_region (current_buffer
, start1
, end2
);
2769 record_change (start1
, (end2
- start1
));
2770 #ifdef USE_TEXT_PROPERTIES
2771 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
2772 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
2773 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
2774 Fset_text_properties (make_number (start1
), make_number (end2
),
2776 #endif /* USE_TEXT_PROPERTIES */
2778 /* holds region 2 */
2779 if (len2_byte
> 20000)
2780 temp
= (unsigned char *) xmalloc (len2_byte
);
2782 temp
= (unsigned char *) alloca (len2_byte
);
2783 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1_byte
);
2784 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2_byte
);
2785 bcopy (start2_addr
, temp
, len2_byte
);
2786 bcopy (start1_addr
, start1_addr
+ len_mid
+ len2_byte
, len1_byte
);
2787 safe_bcopy (start1_addr
+ len1_byte
, start1_addr
+ len2_byte
, len_mid
);
2788 bcopy (temp
, start1_addr
, len2_byte
);
2789 if (len2_byte
> 20000)
2791 #ifdef USE_TEXT_PROPERTIES
2792 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
2793 len1
, current_buffer
, 0);
2794 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
2795 len_mid
, current_buffer
, 0);
2796 graft_intervals_into_buffer (tmp_interval2
, start1
,
2797 len2
, current_buffer
, 0);
2798 #endif /* USE_TEXT_PROPERTIES */
2801 /* Second region smaller than first. */
2803 record_change (start1
, (end2
- start1
));
2804 modify_region (current_buffer
, start1
, end2
);
2806 #ifdef USE_TEXT_PROPERTIES
2807 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
2808 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
2809 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
2810 Fset_text_properties (make_number (start1
), make_number (end2
),
2812 #endif /* USE_TEXT_PROPERTIES */
2814 /* holds region 1 */
2815 if (len1_byte
> 20000)
2816 temp
= (unsigned char *) xmalloc (len1_byte
);
2818 temp
= (unsigned char *) alloca (len1_byte
);
2819 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1_byte
);
2820 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2_byte
);
2821 bcopy (start1_addr
, temp
, len1_byte
);
2822 bcopy (start2_addr
, start1_addr
, len2_byte
);
2823 bcopy (start1_addr
+ len1_byte
, start1_addr
+ len2_byte
, len_mid
);
2824 bcopy (temp
, start1_addr
+ len2_byte
+ len_mid
, len1_byte
);
2825 if (len1_byte
> 20000)
2827 #ifdef USE_TEXT_PROPERTIES
2828 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
2829 len1
, current_buffer
, 0);
2830 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
2831 len_mid
, current_buffer
, 0);
2832 graft_intervals_into_buffer (tmp_interval2
, start1
,
2833 len2
, current_buffer
, 0);
2834 #endif /* USE_TEXT_PROPERTIES */
2838 /* When doing multiple transpositions, it might be nice
2839 to optimize this. Perhaps the markers in any one buffer
2840 should be organized in some sorted data tree. */
2841 if (NILP (leave_markers
))
2843 transpose_markers (start1
, end1
, start2
, end2
,
2844 start1_byte
, start1_byte
+ len1_byte
,
2845 start2_byte
, start2_byte
+ len2_byte
);
2846 fix_overlays_in_range (start1
, end2
);
2858 Qbuffer_access_fontify_functions
2859 = intern ("buffer-access-fontify-functions");
2860 staticpro (&Qbuffer_access_fontify_functions
);
2862 DEFVAR_LISP ("buffer-access-fontify-functions",
2863 &Vbuffer_access_fontify_functions
,
2864 "List of functions called by `buffer-substring' to fontify if necessary.\n\
2865 Each function is called with two arguments which specify the range\n\
2866 of the buffer being accessed.");
2867 Vbuffer_access_fontify_functions
= Qnil
;
2871 extern Lisp_Object Vprin1_to_string_buffer
;
2872 obuf
= Fcurrent_buffer ();
2873 /* Do this here, because init_buffer_once is too early--it won't work. */
2874 Fset_buffer (Vprin1_to_string_buffer
);
2875 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
2876 Fset (Fmake_local_variable (intern ("buffer-access-fontify-functions")),
2881 DEFVAR_LISP ("buffer-access-fontified-property",
2882 &Vbuffer_access_fontified_property
,
2883 "Property which (if non-nil) indicates text has been fontified.\n\
2884 `buffer-substring' need not call the `buffer-access-fontify-functions'\n\
2885 functions if all the text being accessed has this property.");
2886 Vbuffer_access_fontified_property
= Qnil
;
2888 DEFVAR_LISP ("system-name", &Vsystem_name
,
2889 "The name of the machine Emacs is running on.");
2891 DEFVAR_LISP ("user-full-name", &Vuser_full_name
,
2892 "The full name of the user logged in.");
2894 DEFVAR_LISP ("user-login-name", &Vuser_login_name
,
2895 "The user's name, taken from environment variables if possible.");
2897 DEFVAR_LISP ("user-real-login-name", &Vuser_real_login_name
,
2898 "The user's name, based upon the real uid only.");
2900 defsubr (&Schar_equal
);
2901 defsubr (&Sgoto_char
);
2902 defsubr (&Sstring_to_char
);
2903 defsubr (&Schar_to_string
);
2904 defsubr (&Sbuffer_substring
);
2905 defsubr (&Sbuffer_substring_no_properties
);
2906 defsubr (&Sbuffer_string
);
2908 defsubr (&Spoint_marker
);
2909 defsubr (&Smark_marker
);
2911 defsubr (&Sregion_beginning
);
2912 defsubr (&Sregion_end
);
2914 defsubr (&Sline_beginning_position
);
2915 defsubr (&Sline_end_position
);
2917 /* defsubr (&Smark); */
2918 /* defsubr (&Sset_mark); */
2919 defsubr (&Ssave_excursion
);
2920 defsubr (&Ssave_current_buffer
);
2922 defsubr (&Sbufsize
);
2923 defsubr (&Spoint_max
);
2924 defsubr (&Spoint_min
);
2925 defsubr (&Spoint_min_marker
);
2926 defsubr (&Spoint_max_marker
);
2927 defsubr (&Sposition_bytes
);
2933 defsubr (&Sfollowing_char
);
2934 defsubr (&Sprevious_char
);
2935 defsubr (&Schar_after
);
2936 defsubr (&Schar_before
);
2938 defsubr (&Sinsert_before_markers
);
2939 defsubr (&Sinsert_and_inherit
);
2940 defsubr (&Sinsert_and_inherit_before_markers
);
2941 defsubr (&Sinsert_char
);
2943 defsubr (&Suser_login_name
);
2944 defsubr (&Suser_real_login_name
);
2945 defsubr (&Suser_uid
);
2946 defsubr (&Suser_real_uid
);
2947 defsubr (&Suser_full_name
);
2948 defsubr (&Semacs_pid
);
2949 defsubr (&Scurrent_time
);
2950 defsubr (&Sformat_time_string
);
2951 defsubr (&Sdecode_time
);
2952 defsubr (&Sencode_time
);
2953 defsubr (&Scurrent_time_string
);
2954 defsubr (&Scurrent_time_zone
);
2955 defsubr (&Sset_time_zone_rule
);
2956 defsubr (&Ssystem_name
);
2957 defsubr (&Smessage
);
2958 defsubr (&Smessage_box
);
2959 defsubr (&Smessage_or_box
);
2960 defsubr (&Scurrent_message
);
2963 defsubr (&Sinsert_buffer_substring
);
2964 defsubr (&Scompare_buffer_substrings
);
2965 defsubr (&Ssubst_char_in_region
);
2966 defsubr (&Stranslate_region
);
2967 defsubr (&Sdelete_region
);
2969 defsubr (&Snarrow_to_region
);
2970 defsubr (&Ssave_restriction
);
2971 defsubr (&Stranspose_regions
);