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.")
461 Lisp_Object position
;
463 CHECK_NUMBER_COERCE_MARKER (position
, 1);
464 return make_number (CHAR_TO_BYTE (XINT (position
)));
467 DEFUN ("following-char", Ffollowing_char
, Sfollowing_char
, 0, 0, 0,
468 "Return the character following point, as a number.\n\
469 At the end of the buffer or accessible region, return 0.\n\
470 If `enable-multibyte-characters' is nil or point is not\n\
471 at character boundary, multibyte form is ignored,\n\
472 and only one byte following point is returned as a character.")
477 XSETFASTINT (temp
, 0);
479 XSETFASTINT (temp
, FETCH_CHAR (PT_BYTE
));
483 DEFUN ("preceding-char", Fprevious_char
, Sprevious_char
, 0, 0, 0,
484 "Return the character preceding point, as a number.\n\
485 At the beginning of the buffer or accessible region, return 0.\n\
486 If `enable-multibyte-characters' is nil or point is not\n\
487 at character boundary, multi-byte form is ignored,\n\
488 and only one byte preceding point is returned as a character.")
493 XSETFASTINT (temp
, 0);
494 else if (!NILP (current_buffer
->enable_multibyte_characters
))
498 XSETFASTINT (temp
, FETCH_CHAR (pos
));
501 XSETFASTINT (temp
, FETCH_BYTE (PT_BYTE
- 1));
505 DEFUN ("bobp", Fbobp
, Sbobp
, 0, 0, 0,
506 "Return t if point is at the beginning of the buffer.\n\
507 If the buffer is narrowed, this means the beginning of the narrowed part.")
515 DEFUN ("eobp", Feobp
, Seobp
, 0, 0, 0,
516 "Return t if point is at the end of the buffer.\n\
517 If the buffer is narrowed, this means the end of the narrowed part.")
525 DEFUN ("bolp", Fbolp
, Sbolp
, 0, 0, 0,
526 "Return t if point is at the beginning of a line.")
529 if (PT
== BEGV
|| FETCH_BYTE (PT_BYTE
- 1) == '\n')
534 DEFUN ("eolp", Feolp
, Seolp
, 0, 0, 0,
535 "Return t if point is at the end of a line.\n\
536 `End of a line' includes point being at the end of the buffer.")
539 if (PT
== ZV
|| FETCH_BYTE (PT_BYTE
) == '\n')
544 DEFUN ("char-after", Fchar_after
, Schar_after
, 0, 1, 0,
545 "Return character in current buffer at position POS.\n\
546 POS is an integer or a buffer pointer.\n\
547 If POS is out of range, the value is nil.\n\
548 If `enable-multibyte-characters' is nil or POS is not at character boundary,\n\
549 multi-byte form is ignored, and only one byte at POS\n\
550 is returned as a character.")
554 register int pos_byte
;
555 register Lisp_Object val
;
558 return make_number (FETCH_CHAR (PT_BYTE
));
561 pos_byte
= marker_byte_position (pos
);
564 CHECK_NUMBER_COERCE_MARKER (pos
, 0);
566 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
569 if (pos_byte
< BEGV_BYTE
|| pos_byte
>= ZV_BYTE
)
572 return make_number (FETCH_CHAR (pos_byte
));
575 DEFUN ("char-before", Fchar_before
, Schar_before
, 0, 1, 0,
576 "Return character in current buffer preceding position POS.\n\
577 POS is an integer or a buffer pointer.\n\
578 If POS is out of range, the value is nil.\n\
579 If `enable-multibyte-characters' is nil or POS is not at character boundary,\n\
580 multi-byte form is ignored, and only one byte preceding POS\n\
581 is returned as a character.")
585 register Lisp_Object val
;
586 register int pos_byte
;
590 else if (MARKERP (pos
))
591 pos_byte
= marker_byte_position (pos
);
592 else if (pos
<= BEGV
|| pos
> ZV
)
596 CHECK_NUMBER_COERCE_MARKER (pos
, 0);
598 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
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
];
1829 INC_BOTH (pos
, pos_byte
);
1833 signal_after_change (XINT (start
),
1834 XINT (end
) - XINT (start
), XINT (end
) - XINT (start
));
1836 unbind_to (count
, Qnil
);
1840 DEFUN ("translate-region", Ftranslate_region
, Stranslate_region
, 3, 3, 0,
1841 "From START to END, translate characters according to TABLE.\n\
1842 TABLE is a string; the Nth character in it is the mapping\n\
1843 for the character with code N.\n\
1844 This function does not alter multibyte characters.\n\
1845 It returns the number of characters changed.")
1849 register Lisp_Object table
;
1851 register int pos_byte
, stop
; /* Limits of the region. */
1852 register unsigned char *tt
; /* Trans table. */
1853 register int nc
; /* New character. */
1854 int cnt
; /* Number of changes made. */
1855 int size
; /* Size of translate table. */
1858 validate_region (&start
, &end
);
1859 CHECK_STRING (table
, 2);
1861 size
= XSTRING (table
)->size_byte
;
1862 tt
= XSTRING (table
)->data
;
1864 pos_byte
= CHAR_TO_BYTE (XINT (start
));
1865 stop
= CHAR_TO_BYTE (XINT (end
));
1866 modify_region (current_buffer
, XINT (start
), XINT (end
));
1870 for (; pos_byte
< stop
; )
1872 register unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
1876 oc
= STRING_CHAR_AND_LENGTH (p
, stop
- pos_byte
, len
);
1877 if (oc
< size
&& len
== 1)
1882 record_change (pos
, 1);
1884 signal_after_change (pos
, 1, 1);
1892 return make_number (cnt
);
1895 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
1896 "Delete the text between point and mark.\n\
1897 When called from a program, expects two arguments,\n\
1898 positions (integers or markers) specifying the stretch to be deleted.")
1900 Lisp_Object start
, end
;
1902 validate_region (&start
, &end
);
1903 del_range (XINT (start
), XINT (end
));
1907 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
1908 "Remove restrictions (narrowing) from current buffer.\n\
1909 This allows the buffer's full text to be seen and edited.")
1912 if (BEG
!= BEGV
|| Z
!= ZV
)
1913 current_buffer
->clip_changed
= 1;
1915 BEGV_BYTE
= BEG_BYTE
;
1916 SET_BUF_ZV_BOTH (current_buffer
, Z
, Z_BYTE
);
1917 /* Changing the buffer bounds invalidates any recorded current column. */
1918 invalidate_current_column ();
1922 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
1923 "Restrict editing in this buffer to the current region.\n\
1924 The rest of the text becomes temporarily invisible and untouchable\n\
1925 but is not deleted; if you save the buffer in a file, the invisible\n\
1926 text is included in the file. \\[widen] makes all visible again.\n\
1927 See also `save-restriction'.\n\
1929 When calling from a program, pass two arguments; positions (integers\n\
1930 or markers) bounding the text that should remain visible.")
1932 register Lisp_Object start
, end
;
1934 CHECK_NUMBER_COERCE_MARKER (start
, 0);
1935 CHECK_NUMBER_COERCE_MARKER (end
, 1);
1937 if (XINT (start
) > XINT (end
))
1940 tem
= start
; start
= end
; end
= tem
;
1943 if (!(BEG
<= XINT (start
) && XINT (start
) <= XINT (end
) && XINT (end
) <= Z
))
1944 args_out_of_range (start
, end
);
1946 if (BEGV
!= XFASTINT (start
) || ZV
!= XFASTINT (end
))
1947 current_buffer
->clip_changed
= 1;
1949 SET_BUF_BEGV (current_buffer
, XFASTINT (start
));
1950 SET_BUF_ZV (current_buffer
, XFASTINT (end
));
1951 if (PT
< XFASTINT (start
))
1952 SET_PT (XFASTINT (start
));
1953 if (PT
> XFASTINT (end
))
1954 SET_PT (XFASTINT (end
));
1955 /* Changing the buffer bounds invalidates any recorded current column. */
1956 invalidate_current_column ();
1961 save_restriction_save ()
1963 register Lisp_Object bottom
, top
;
1964 /* Note: I tried using markers here, but it does not win
1965 because insertion at the end of the saved region
1966 does not advance mh and is considered "outside" the saved region. */
1967 XSETFASTINT (bottom
, BEGV
- BEG
);
1968 XSETFASTINT (top
, Z
- ZV
);
1970 return Fcons (Fcurrent_buffer (), Fcons (bottom
, top
));
1974 save_restriction_restore (data
)
1977 register struct buffer
*buf
;
1978 register int newhead
, newtail
;
1979 register Lisp_Object tem
;
1982 buf
= XBUFFER (XCONS (data
)->car
);
1984 data
= XCONS (data
)->cdr
;
1986 tem
= XCONS (data
)->car
;
1987 newhead
= XINT (tem
);
1988 tem
= XCONS (data
)->cdr
;
1989 newtail
= XINT (tem
);
1990 if (newhead
+ newtail
> BUF_Z (buf
) - BUF_BEG (buf
))
1996 obegv
= BUF_BEGV (buf
);
1999 SET_BUF_BEGV (buf
, BUF_BEG (buf
) + newhead
);
2000 SET_BUF_ZV (buf
, BUF_Z (buf
) - newtail
);
2002 if (obegv
!= BUF_BEGV (buf
) || ozv
!= BUF_ZV (buf
))
2003 current_buffer
->clip_changed
= 1;
2005 /* If point is outside the new visible range, move it inside. */
2006 SET_BUF_PT_BOTH (buf
,
2007 clip_to_bounds (BUF_BEGV (buf
), BUF_PT (buf
), BUF_ZV (buf
)),
2008 clip_to_bounds (BUF_BEGV_BYTE (buf
), BUF_PT_BYTE (buf
),
2009 BUF_ZV_BYTE (buf
)));
2014 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
2015 "Execute BODY, saving and restoring current buffer's restrictions.\n\
2016 The buffer's restrictions make parts of the beginning and end invisible.\n\
2017 \(They are set up with `narrow-to-region' and eliminated with `widen'.)\n\
2018 This special form, `save-restriction', saves the current buffer's restrictions\n\
2019 when it is entered, and restores them when it is exited.\n\
2020 So any `narrow-to-region' within BODY lasts only until the end of the form.\n\
2021 The old restrictions settings are restored\n\
2022 even in case of abnormal exit (throw or error).\n\
2024 The value returned is the value of the last form in BODY.\n\
2026 `save-restriction' can get confused if, within the BODY, you widen\n\
2027 and then make changes outside the area within the saved restrictions.\n\
2029 Note: if you are using both `save-excursion' and `save-restriction',\n\
2030 use `save-excursion' outermost:\n\
2031 (save-excursion (save-restriction ...))")
2035 register Lisp_Object val
;
2036 int count
= specpdl_ptr
- specpdl
;
2038 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
2039 val
= Fprogn (body
);
2040 return unbind_to (count
, val
);
2043 /* Buffer for the most recent text displayed by Fmessage. */
2044 static char *message_text
;
2046 /* Allocated length of that buffer. */
2047 static int message_length
;
2049 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
2050 "Print a one-line message at the bottom of the screen.\n\
2051 The first argument is a format control string, and the rest are data\n\
2052 to be formatted under control of the string. See `format' for details.\n\
2054 If the first argument is nil, clear any existing message; let the\n\
2055 minibuffer contents show.")
2067 register Lisp_Object val
;
2068 val
= Fformat (nargs
, args
);
2069 /* Copy the data so that it won't move when we GC. */
2072 message_text
= (char *)xmalloc (80);
2073 message_length
= 80;
2075 if (XSTRING (val
)->size_byte
> message_length
)
2077 message_length
= XSTRING (val
)->size_byte
;
2078 message_text
= (char *)xrealloc (message_text
, message_length
);
2080 bcopy (XSTRING (val
)->data
, message_text
, XSTRING (val
)->size_byte
);
2081 message2 (message_text
, XSTRING (val
)->size_byte
,
2082 STRING_MULTIBYTE (val
));
2087 DEFUN ("message-box", Fmessage_box
, Smessage_box
, 1, MANY
, 0,
2088 "Display a message, in a dialog box if possible.\n\
2089 If a dialog box is not available, use the echo area.\n\
2090 The first argument is a format control string, and the rest are data\n\
2091 to be formatted under control of the string. See `format' for details.\n\
2093 If the first argument is nil, clear any existing message; let the\n\
2094 minibuffer contents show.")
2106 register Lisp_Object val
;
2107 val
= Fformat (nargs
, args
);
2110 Lisp_Object pane
, menu
, obj
;
2111 struct gcpro gcpro1
;
2112 pane
= Fcons (Fcons (build_string ("OK"), Qt
), Qnil
);
2114 menu
= Fcons (val
, pane
);
2115 obj
= Fx_popup_dialog (Qt
, menu
);
2119 #else /* not HAVE_MENUS */
2120 /* Copy the data so that it won't move when we GC. */
2123 message_text
= (char *)xmalloc (80);
2124 message_length
= 80;
2126 if (XSTRING (val
)->size_byte
> message_length
)
2128 message_length
= XSTRING (val
)->size_byte
;
2129 message_text
= (char *)xrealloc (message_text
, message_length
);
2131 bcopy (XSTRING (val
)->data
, message_text
, XSTRING (val
)->size_byte
);
2132 message2 (message_text
, XSTRING (val
)->size_byte
);
2134 #endif /* not HAVE_MENUS */
2138 extern Lisp_Object last_nonmenu_event
;
2141 DEFUN ("message-or-box", Fmessage_or_box
, Smessage_or_box
, 1, MANY
, 0,
2142 "Display a message in a dialog box or in the echo area.\n\
2143 If this command was invoked with the mouse, use a dialog box.\n\
2144 Otherwise, use the echo area.\n\
2145 The first argument is a format control string, and the rest are data\n\
2146 to be formatted under control of the string. See `format' for details.\n\
2148 If the first argument is nil, clear any existing message; let the\n\
2149 minibuffer contents show.")
2155 if (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2156 return Fmessage_box (nargs
, args
);
2158 return Fmessage (nargs
, args
);
2161 DEFUN ("current-message", Fcurrent_message
, Scurrent_message
, 0, 0, 0,
2162 "Return the string currently displayed in the echo area, or nil if none.")
2165 return (echo_area_glyphs
2166 ? make_string (echo_area_glyphs
, echo_area_glyphs_length
)
2170 /* Number of bytes that STRING will occupy when put into the result.
2171 MULTIBYTE is nonzero if the result should be multibyte. */
2173 #define CONVERTED_BYTE_SIZE(MULTIBYTE, STRING) \
2174 (((MULTIBYTE) && ! STRING_MULTIBYTE (STRING)) \
2175 ? count_size_as_multibyte (XSTRING (STRING)->data, \
2176 XSTRING (STRING)->size_byte) \
2177 : XSTRING (STRING)->size_byte)
2179 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
2180 "Format a string out of a control-string and arguments.\n\
2181 The first argument is a control string.\n\
2182 The other arguments are substituted into it to make the result, a string.\n\
2183 It may contain %-sequences meaning to substitute the next argument.\n\
2184 %s means print a string argument. Actually, prints any object, with `princ'.\n\
2185 %d means print as number in decimal (%o octal, %x hex).\n\
2186 %e means print a number in exponential notation.\n\
2187 %f means print a number in decimal-point notation.\n\
2188 %g means print a number in exponential notation\n\
2189 or decimal-point notation, whichever uses fewer characters.\n\
2190 %c means print a number as a single character.\n\
2191 %S means print any object as an s-expression (using prin1).\n\
2192 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.\n\
2193 Use %% to put a single % into the output.")
2196 register Lisp_Object
*args
;
2198 register int n
; /* The number of the next arg to substitute */
2199 register int total
; /* An estimate of the final length */
2201 register unsigned char *format
, *end
;
2203 /* Nonzero if the output should be a multibyte string,
2204 which is true if any of the inputs is one. */
2206 unsigned char *this_format
;
2210 extern char *index ();
2212 /* It should not be necessary to GCPRO ARGS, because
2213 the caller in the interpreter should take care of that. */
2215 /* Try to determine whether the result should be multibyte.
2216 This is not always right; sometimes the result needs to be multibyte
2217 because of an object that we will pass through prin1,
2218 and in that case, we won't know it here. */
2219 for (n
= 0; n
< nargs
; n
++)
2220 if (STRINGP (args
[n
]) && STRING_MULTIBYTE (args
[n
]))
2223 CHECK_STRING (args
[0], 0);
2225 /* If we start out planning a unibyte result,
2226 and later find it has to be multibyte, we jump back to retry. */
2229 format
= XSTRING (args
[0])->data
;
2230 end
= format
+ XSTRING (args
[0])->size_byte
;
2233 /* Make room in result for all the non-%-codes in the control string. */
2234 total
= 5 + CONVERTED_BYTE_SIZE (multibyte
, args
[0]);
2236 /* Add to TOTAL enough space to hold the converted arguments. */
2239 while (format
!= end
)
2240 if (*format
++ == '%')
2242 int minlen
, thissize
= 0;
2243 unsigned char *this_format_start
= format
- 1;
2245 /* Process a numeric arg and skip it. */
2246 minlen
= atoi (format
);
2250 while ((*format
>= '0' && *format
<= '9')
2251 || *format
== '-' || *format
== ' ' || *format
== '.')
2254 if (format
- this_format_start
+ 1 > longest_format
)
2255 longest_format
= format
- this_format_start
+ 1;
2259 else if (++n
>= nargs
)
2260 error ("Not enough arguments for format string");
2261 else if (*format
== 'S')
2263 /* For `S', prin1 the argument and then treat like a string. */
2264 register Lisp_Object tem
;
2265 tem
= Fprin1_to_string (args
[n
], Qnil
);
2266 if (STRING_MULTIBYTE (tem
) && ! multibyte
)
2274 else if (SYMBOLP (args
[n
]))
2276 XSETSTRING (args
[n
], XSYMBOL (args
[n
])->name
);
2277 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
2284 else if (STRINGP (args
[n
]))
2287 if (*format
!= 's' && *format
!= 'S')
2288 error ("format specifier doesn't match argument type");
2289 thissize
= CONVERTED_BYTE_SIZE (multibyte
, args
[n
]);
2291 /* Would get MPV otherwise, since Lisp_Int's `point' to low memory. */
2292 else if (INTEGERP (args
[n
]) && *format
!= 's')
2294 #ifdef LISP_FLOAT_TYPE
2295 /* The following loop assumes the Lisp type indicates
2296 the proper way to pass the argument.
2297 So make sure we have a flonum if the argument should
2299 if (*format
== 'e' || *format
== 'f' || *format
== 'g')
2300 args
[n
] = Ffloat (args
[n
]);
2303 if (*format
== 'c' && ! SINGLE_BYTE_CHAR_P (XINT (args
[n
])))
2310 args
[n
] = Fchar_to_string (args
[n
]);
2311 thissize
= XSTRING (args
[n
])->size_byte
;
2314 #ifdef LISP_FLOAT_TYPE
2315 else if (FLOATP (args
[n
]) && *format
!= 's')
2317 if (! (*format
== 'e' || *format
== 'f' || *format
== 'g'))
2318 args
[n
] = Ftruncate (args
[n
], Qnil
);
2324 /* Anything but a string, convert to a string using princ. */
2325 register Lisp_Object tem
;
2326 tem
= Fprin1_to_string (args
[n
], Qt
);
2327 if (STRING_MULTIBYTE (tem
) & ! multibyte
)
2336 if (thissize
< minlen
)
2339 total
+= thissize
+ 4;
2342 /* Now we can no longer jump to retry.
2343 TOTAL and LONGEST_FORMAT are known for certain. */
2345 this_format
= (unsigned char *) alloca (longest_format
+ 1);
2347 /* Allocate the space for the result.
2348 Note that TOTAL is an overestimate. */
2350 buf
= (unsigned char *) alloca (total
+ 1);
2352 buf
= (unsigned char *) xmalloc (total
+ 1);
2358 /* Scan the format and store result in BUF. */
2359 format
= XSTRING (args
[0])->data
;
2360 while (format
!= end
)
2365 unsigned char *this_format_start
= format
;
2369 /* Process a numeric arg and skip it. */
2370 minlen
= atoi (format
);
2374 while ((*format
>= '0' && *format
<= '9')
2375 || *format
== '-' || *format
== ' ' || *format
== '.')
2378 if (*format
++ == '%')
2387 if (STRINGP (args
[n
]))
2389 int padding
, nbytes
, width
;
2391 nbytes
= copy_text (XSTRING (args
[n
])->data
, p
,
2392 XSTRING (args
[n
])->size_byte
,
2393 STRING_MULTIBYTE (args
[n
]), multibyte
);
2394 width
= strwidth (p
, nbytes
);
2396 nchars
+= XSTRING (args
[n
])->size
;
2398 /* If spec requires it, pad on right with spaces. */
2399 padding
= minlen
- width
;
2400 while (padding
-- > 0)
2406 else if (INTEGERP (args
[n
]) || FLOATP (args
[n
]))
2410 bcopy (this_format_start
, this_format
,
2411 format
- this_format_start
);
2412 this_format
[format
- this_format_start
] = 0;
2414 sprintf (p
, this_format
, XINT (args
[n
]));
2416 this_nchars
= strlen (p
);
2418 nchars
+= this_nchars
;
2421 else if (STRING_MULTIBYTE (args
[0]))
2423 /* Copy a whole multibyte character. */
2425 while (! CHAR_HEAD_P (*format
)) *p
++ = *format
++;
2430 /* Convert a single-byte character to multibyte. */
2431 int len
= copy_text (format
, p
, 1, 0, 1);
2438 *p
++ = *format
++, nchars
++;
2441 val
= make_multibyte_string (buf
, nchars
, p
- buf
);
2443 /* If we allocated BUF with malloc, free it too. */
2453 format1 (string1
, arg0
, arg1
, arg2
, arg3
, arg4
)
2454 EMACS_INT arg0
, arg1
, arg2
, arg3
, arg4
;
2468 doprnt (buf
, sizeof buf
, string1
, (char *)0, 5, (char **) args
);
2470 doprnt (buf
, sizeof buf
, string1
, (char *)0, 5, &string1
+ 1);
2472 return build_string (buf
);
2475 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
2476 "Return t if two characters match, optionally ignoring case.\n\
2477 Both arguments must be characters (i.e. integers).\n\
2478 Case is ignored if `case-fold-search' is non-nil in the current buffer.")
2480 register Lisp_Object c1
, c2
;
2483 CHECK_NUMBER (c1
, 0);
2484 CHECK_NUMBER (c2
, 1);
2486 if (XINT (c1
) == XINT (c2
))
2488 if (NILP (current_buffer
->case_fold_search
))
2491 /* Do these in separate statements,
2492 then compare the variables.
2493 because of the way DOWNCASE uses temp variables. */
2494 i1
= DOWNCASE (XFASTINT (c1
));
2495 i2
= DOWNCASE (XFASTINT (c2
));
2496 return (i1
== i2
? Qt
: Qnil
);
2499 /* Transpose the markers in two regions of the current buffer, and
2500 adjust the ones between them if necessary (i.e.: if the regions
2503 START1, END1 are the character positions of the first region.
2504 START1_BYTE, END1_BYTE are the byte positions.
2505 START2, END2 are the character positions of the second region.
2506 START2_BYTE, END2_BYTE are the byte positions.
2508 Traverses the entire marker list of the buffer to do so, adding an
2509 appropriate amount to some, subtracting from some, and leaving the
2510 rest untouched. Most of this is copied from adjust_markers in insdel.c.
2512 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
2515 transpose_markers (start1
, end1
, start2
, end2
,
2516 start1_byte
, end1_byte
, start2_byte
, end2_byte
)
2517 register int start1
, end1
, start2
, end2
;
2518 register int start1_byte
, end1_byte
, start2_byte
, end2_byte
;
2520 register int amt1
, amt1_byte
, amt2
, amt2_byte
, diff
, diff_byte
, mpos
;
2521 register Lisp_Object marker
;
2523 /* Update point as if it were a marker. */
2527 TEMP_SET_PT_BOTH (PT
+ (end2
- end1
),
2528 PT_BYTE
+ (end2_byte
- end1_byte
));
2529 else if (PT
< start2
)
2530 TEMP_SET_PT_BOTH (PT
+ (end2
- start2
) - (end1
- start1
),
2531 (PT_BYTE
+ (end2_byte
- start2_byte
)
2532 - (end1_byte
- start1_byte
)));
2534 TEMP_SET_PT_BOTH (PT
- (start2
- start1
),
2535 PT_BYTE
- (start2_byte
- start1_byte
));
2537 /* We used to adjust the endpoints here to account for the gap, but that
2538 isn't good enough. Even if we assume the caller has tried to move the
2539 gap out of our way, it might still be at start1 exactly, for example;
2540 and that places it `inside' the interval, for our purposes. The amount
2541 of adjustment is nontrivial if there's a `denormalized' marker whose
2542 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
2543 the dirty work to Fmarker_position, below. */
2545 /* The difference between the region's lengths */
2546 diff
= (end2
- start2
) - (end1
- start1
);
2547 diff_byte
= (end2_byte
- start2_byte
) - (end1_byte
- start1_byte
);
2549 /* For shifting each marker in a region by the length of the other
2550 region plus the distance between the regions. */
2551 amt1
= (end2
- start2
) + (start2
- end1
);
2552 amt2
= (end1
- start1
) + (start2
- end1
);
2553 amt1_byte
= (end2_byte
- start2_byte
) + (start2_byte
- end1_byte
);
2554 amt2_byte
= (end1_byte
- start1_byte
) + (start2_byte
- end1_byte
);
2556 for (marker
= BUF_MARKERS (current_buffer
); !NILP (marker
);
2557 marker
= XMARKER (marker
)->chain
)
2559 mpos
= marker_byte_position (marker
);
2560 if (mpos
>= start1_byte
&& mpos
< end2_byte
)
2562 if (mpos
< end1_byte
)
2564 else if (mpos
< start2_byte
)
2568 XMARKER (marker
)->bytepos
= mpos
;
2570 mpos
= XMARKER (marker
)->charpos
;
2571 if (mpos
>= start1
&& mpos
< end2
)
2575 else if (mpos
< start2
)
2580 XMARKER (marker
)->charpos
= mpos
;
2584 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
2585 "Transpose region START1 to END1 with START2 to END2.\n\
2586 The regions may not be overlapping, because the size of the buffer is\n\
2587 never changed in a transposition.\n\
2589 Optional fifth arg LEAVE_MARKERS, if non-nil, means don't update\n\
2590 any markers that happen to be located in the regions.\n\
2592 Transposing beyond buffer boundaries is an error.")
2593 (startr1
, endr1
, startr2
, endr2
, leave_markers
)
2594 Lisp_Object startr1
, endr1
, startr2
, endr2
, leave_markers
;
2596 register int start1
, end1
, start2
, end2
;
2597 int start1_byte
, start2_byte
, len1_byte
, len2_byte
;
2598 int gap
, len1
, len_mid
, len2
;
2599 unsigned char *start1_addr
, *start2_addr
, *temp
;
2601 #ifdef USE_TEXT_PROPERTIES
2602 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
;
2603 cur_intv
= BUF_INTERVALS (current_buffer
);
2604 #endif /* USE_TEXT_PROPERTIES */
2606 validate_region (&startr1
, &endr1
);
2607 validate_region (&startr2
, &endr2
);
2609 start1
= XFASTINT (startr1
);
2610 end1
= XFASTINT (endr1
);
2611 start2
= XFASTINT (startr2
);
2612 end2
= XFASTINT (endr2
);
2615 /* Swap the regions if they're reversed. */
2618 register int glumph
= start1
;
2626 len1
= end1
- start1
;
2627 len2
= end2
- start2
;
2630 error ("Transposed regions not properly ordered");
2631 else if (start1
== end1
|| start2
== end2
)
2632 error ("Transposed region may not be of length 0");
2634 /* The possibilities are:
2635 1. Adjacent (contiguous) regions, or separate but equal regions
2636 (no, really equal, in this case!), or
2637 2. Separate regions of unequal size.
2639 The worst case is usually No. 2. It means that (aside from
2640 potential need for getting the gap out of the way), there also
2641 needs to be a shifting of the text between the two regions. So
2642 if they are spread far apart, we are that much slower... sigh. */
2644 /* It must be pointed out that the really studly thing to do would
2645 be not to move the gap at all, but to leave it in place and work
2646 around it if necessary. This would be extremely efficient,
2647 especially considering that people are likely to do
2648 transpositions near where they are working interactively, which
2649 is exactly where the gap would be found. However, such code
2650 would be much harder to write and to read. So, if you are
2651 reading this comment and are feeling squirrely, by all means have
2652 a go! I just didn't feel like doing it, so I will simply move
2653 the gap the minimum distance to get it out of the way, and then
2654 deal with an unbroken array. */
2656 /* Make sure the gap won't interfere, by moving it out of the text
2657 we will operate on. */
2658 if (start1
< gap
&& gap
< end2
)
2660 if (gap
- start1
< end2
- gap
)
2666 start1_byte
= CHAR_TO_BYTE (start1
);
2667 start2_byte
= CHAR_TO_BYTE (start2
);
2668 len1_byte
= CHAR_TO_BYTE (end1
) - start1_byte
;
2669 len2_byte
= CHAR_TO_BYTE (end2
) - start2_byte
;
2671 /* Hmmm... how about checking to see if the gap is large
2672 enough to use as the temporary storage? That would avoid an
2673 allocation... interesting. Later, don't fool with it now. */
2675 /* Working without memmove, for portability (sigh), so must be
2676 careful of overlapping subsections of the array... */
2678 if (end1
== start2
) /* adjacent regions */
2680 modify_region (current_buffer
, start1
, end2
);
2681 record_change (start1
, len1
+ len2
);
2683 #ifdef USE_TEXT_PROPERTIES
2684 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
2685 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
2686 Fset_text_properties (make_number (start1
), make_number (end2
),
2688 #endif /* USE_TEXT_PROPERTIES */
2690 /* First region smaller than second. */
2691 if (len1_byte
< len2_byte
)
2693 /* We use alloca only if it is small,
2694 because we want to avoid stack overflow. */
2695 if (len2_byte
> 20000)
2696 temp
= (unsigned char *) xmalloc (len2_byte
);
2698 temp
= (unsigned char *) alloca (len2_byte
);
2700 /* Don't precompute these addresses. We have to compute them
2701 at the last minute, because the relocating allocator might
2702 have moved the buffer around during the xmalloc. */
2703 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1_byte
);
2704 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2_byte
);
2706 bcopy (start2_addr
, temp
, len2_byte
);
2707 bcopy (start1_addr
, start1_addr
+ len2_byte
, len1_byte
);
2708 bcopy (temp
, start1_addr
, len2_byte
);
2709 if (len2_byte
> 20000)
2713 /* First region not smaller than second. */
2715 if (len1_byte
> 20000)
2716 temp
= (unsigned char *) xmalloc (len1_byte
);
2718 temp
= (unsigned char *) alloca (len1_byte
);
2719 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1_byte
);
2720 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2_byte
);
2721 bcopy (start1_addr
, temp
, len1_byte
);
2722 bcopy (start2_addr
, start1_addr
, len2_byte
);
2723 bcopy (temp
, start1_addr
+ len2_byte
, len1_byte
);
2724 if (len1_byte
> 20000)
2727 #ifdef USE_TEXT_PROPERTIES
2728 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
2729 len1
, current_buffer
, 0);
2730 graft_intervals_into_buffer (tmp_interval2
, start1
,
2731 len2
, current_buffer
, 0);
2732 #endif /* USE_TEXT_PROPERTIES */
2734 /* Non-adjacent regions, because end1 != start2, bleagh... */
2737 len_mid
= start2_byte
- (start1_byte
+ len1_byte
);
2739 if (len1_byte
== len2_byte
)
2740 /* Regions are same size, though, how nice. */
2742 modify_region (current_buffer
, start1
, end1
);
2743 modify_region (current_buffer
, start2
, end2
);
2744 record_change (start1
, len1
);
2745 record_change (start2
, len2
);
2746 #ifdef USE_TEXT_PROPERTIES
2747 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
2748 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
2749 Fset_text_properties (make_number (start1
), make_number (end1
),
2751 Fset_text_properties (make_number (start2
), make_number (end2
),
2753 #endif /* USE_TEXT_PROPERTIES */
2755 if (len1_byte
> 20000)
2756 temp
= (unsigned char *) xmalloc (len1_byte
);
2758 temp
= (unsigned char *) alloca (len1_byte
);
2759 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1_byte
);
2760 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2_byte
);
2761 bcopy (start1_addr
, temp
, len1_byte
);
2762 bcopy (start2_addr
, start1_addr
, len2_byte
);
2763 bcopy (temp
, start2_addr
, len1_byte
);
2764 if (len1_byte
> 20000)
2766 #ifdef USE_TEXT_PROPERTIES
2767 graft_intervals_into_buffer (tmp_interval1
, start2
,
2768 len1
, current_buffer
, 0);
2769 graft_intervals_into_buffer (tmp_interval2
, start1
,
2770 len2
, current_buffer
, 0);
2771 #endif /* USE_TEXT_PROPERTIES */
2774 else if (len1_byte
< len2_byte
) /* Second region larger than first */
2775 /* Non-adjacent & unequal size, area between must also be shifted. */
2777 modify_region (current_buffer
, start1
, end2
);
2778 record_change (start1
, (end2
- start1
));
2779 #ifdef USE_TEXT_PROPERTIES
2780 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
2781 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
2782 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
2783 Fset_text_properties (make_number (start1
), make_number (end2
),
2785 #endif /* USE_TEXT_PROPERTIES */
2787 /* holds region 2 */
2788 if (len2_byte
> 20000)
2789 temp
= (unsigned char *) xmalloc (len2_byte
);
2791 temp
= (unsigned char *) alloca (len2_byte
);
2792 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1_byte
);
2793 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2_byte
);
2794 bcopy (start2_addr
, temp
, len2_byte
);
2795 bcopy (start1_addr
, start1_addr
+ len_mid
+ len2_byte
, len1_byte
);
2796 safe_bcopy (start1_addr
+ len1_byte
, start1_addr
+ len2_byte
, len_mid
);
2797 bcopy (temp
, start1_addr
, len2_byte
);
2798 if (len2_byte
> 20000)
2800 #ifdef USE_TEXT_PROPERTIES
2801 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
2802 len1
, current_buffer
, 0);
2803 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
2804 len_mid
, current_buffer
, 0);
2805 graft_intervals_into_buffer (tmp_interval2
, start1
,
2806 len2
, current_buffer
, 0);
2807 #endif /* USE_TEXT_PROPERTIES */
2810 /* Second region smaller than first. */
2812 record_change (start1
, (end2
- start1
));
2813 modify_region (current_buffer
, start1
, end2
);
2815 #ifdef USE_TEXT_PROPERTIES
2816 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
2817 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
2818 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
2819 Fset_text_properties (make_number (start1
), make_number (end2
),
2821 #endif /* USE_TEXT_PROPERTIES */
2823 /* holds region 1 */
2824 if (len1_byte
> 20000)
2825 temp
= (unsigned char *) xmalloc (len1_byte
);
2827 temp
= (unsigned char *) alloca (len1_byte
);
2828 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1_byte
);
2829 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2_byte
);
2830 bcopy (start1_addr
, temp
, len1_byte
);
2831 bcopy (start2_addr
, start1_addr
, len2_byte
);
2832 bcopy (start1_addr
+ len1_byte
, start1_addr
+ len2_byte
, len_mid
);
2833 bcopy (temp
, start1_addr
+ len2_byte
+ len_mid
, len1_byte
);
2834 if (len1_byte
> 20000)
2836 #ifdef USE_TEXT_PROPERTIES
2837 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
2838 len1
, current_buffer
, 0);
2839 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
2840 len_mid
, current_buffer
, 0);
2841 graft_intervals_into_buffer (tmp_interval2
, start1
,
2842 len2
, current_buffer
, 0);
2843 #endif /* USE_TEXT_PROPERTIES */
2847 /* When doing multiple transpositions, it might be nice
2848 to optimize this. Perhaps the markers in any one buffer
2849 should be organized in some sorted data tree. */
2850 if (NILP (leave_markers
))
2852 transpose_markers (start1
, end1
, start2
, end2
,
2853 start1_byte
, start1_byte
+ len1_byte
,
2854 start2_byte
, start2_byte
+ len2_byte
);
2855 fix_overlays_in_range (start1
, end2
);
2867 Qbuffer_access_fontify_functions
2868 = intern ("buffer-access-fontify-functions");
2869 staticpro (&Qbuffer_access_fontify_functions
);
2871 DEFVAR_LISP ("buffer-access-fontify-functions",
2872 &Vbuffer_access_fontify_functions
,
2873 "List of functions called by `buffer-substring' to fontify if necessary.\n\
2874 Each function is called with two arguments which specify the range\n\
2875 of the buffer being accessed.");
2876 Vbuffer_access_fontify_functions
= Qnil
;
2880 extern Lisp_Object Vprin1_to_string_buffer
;
2881 obuf
= Fcurrent_buffer ();
2882 /* Do this here, because init_buffer_once is too early--it won't work. */
2883 Fset_buffer (Vprin1_to_string_buffer
);
2884 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
2885 Fset (Fmake_local_variable (intern ("buffer-access-fontify-functions")),
2890 DEFVAR_LISP ("buffer-access-fontified-property",
2891 &Vbuffer_access_fontified_property
,
2892 "Property which (if non-nil) indicates text has been fontified.\n\
2893 `buffer-substring' need not call the `buffer-access-fontify-functions'\n\
2894 functions if all the text being accessed has this property.");
2895 Vbuffer_access_fontified_property
= Qnil
;
2897 DEFVAR_LISP ("system-name", &Vsystem_name
,
2898 "The name of the machine Emacs is running on.");
2900 DEFVAR_LISP ("user-full-name", &Vuser_full_name
,
2901 "The full name of the user logged in.");
2903 DEFVAR_LISP ("user-login-name", &Vuser_login_name
,
2904 "The user's name, taken from environment variables if possible.");
2906 DEFVAR_LISP ("user-real-login-name", &Vuser_real_login_name
,
2907 "The user's name, based upon the real uid only.");
2909 defsubr (&Schar_equal
);
2910 defsubr (&Sgoto_char
);
2911 defsubr (&Sstring_to_char
);
2912 defsubr (&Schar_to_string
);
2913 defsubr (&Sbuffer_substring
);
2914 defsubr (&Sbuffer_substring_no_properties
);
2915 defsubr (&Sbuffer_string
);
2917 defsubr (&Spoint_marker
);
2918 defsubr (&Smark_marker
);
2920 defsubr (&Sregion_beginning
);
2921 defsubr (&Sregion_end
);
2923 defsubr (&Sline_beginning_position
);
2924 defsubr (&Sline_end_position
);
2926 /* defsubr (&Smark); */
2927 /* defsubr (&Sset_mark); */
2928 defsubr (&Ssave_excursion
);
2929 defsubr (&Ssave_current_buffer
);
2931 defsubr (&Sbufsize
);
2932 defsubr (&Spoint_max
);
2933 defsubr (&Spoint_min
);
2934 defsubr (&Spoint_min_marker
);
2935 defsubr (&Spoint_max_marker
);
2936 defsubr (&Sposition_bytes
);
2942 defsubr (&Sfollowing_char
);
2943 defsubr (&Sprevious_char
);
2944 defsubr (&Schar_after
);
2945 defsubr (&Schar_before
);
2947 defsubr (&Sinsert_before_markers
);
2948 defsubr (&Sinsert_and_inherit
);
2949 defsubr (&Sinsert_and_inherit_before_markers
);
2950 defsubr (&Sinsert_char
);
2952 defsubr (&Suser_login_name
);
2953 defsubr (&Suser_real_login_name
);
2954 defsubr (&Suser_uid
);
2955 defsubr (&Suser_real_uid
);
2956 defsubr (&Suser_full_name
);
2957 defsubr (&Semacs_pid
);
2958 defsubr (&Scurrent_time
);
2959 defsubr (&Sformat_time_string
);
2960 defsubr (&Sdecode_time
);
2961 defsubr (&Sencode_time
);
2962 defsubr (&Scurrent_time_string
);
2963 defsubr (&Scurrent_time_zone
);
2964 defsubr (&Sset_time_zone_rule
);
2965 defsubr (&Ssystem_name
);
2966 defsubr (&Smessage
);
2967 defsubr (&Smessage_box
);
2968 defsubr (&Smessage_or_box
);
2969 defsubr (&Scurrent_message
);
2972 defsubr (&Sinsert_buffer_substring
);
2973 defsubr (&Scompare_buffer_substrings
);
2974 defsubr (&Ssubst_char_in_region
);
2975 defsubr (&Stranslate_region
);
2976 defsubr (&Sdelete_region
);
2978 defsubr (&Snarrow_to_region
);
2979 defsubr (&Ssave_restriction
);
2980 defsubr (&Stranspose_regions
);