1 /* Lisp functions pertaining to editing.
2 Copyright (C) 1985, 1986, 1987, 1989, 1993, 1994, 1995, 1996,
3 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
4 2005, 2006 Free Software Foundation, Inc.
6 This file is part of GNU Emacs.
8 GNU Emacs is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 2, or (at your option)
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs; see the file COPYING. If not, write to
20 the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
21 Boston, MA 02110-1301, USA. */
25 #include <sys/types.h>
36 #ifdef HAVE_SYS_UTSNAME_H
37 #include <sys/utsname.h>
42 /* systime.h includes <sys/time.h> which, on some systems, is required
43 for <sys/resource.h>; thus systime.h must be included before
47 #if defined HAVE_SYS_RESOURCE_H
48 #include <sys/resource.h>
53 #include "intervals.h"
62 #define MAX_10_EXP DBL_MAX_10_EXP
64 #define MAX_10_EXP 310
72 extern char **environ
;
75 #define TM_YEAR_BASE 1900
77 extern size_t emacs_strftimeu
P_ ((char *, size_t, const char *,
78 const struct tm
*, int));
79 static int tm_diff
P_ ((struct tm
*, struct tm
*));
80 static void find_field
P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
, int *, Lisp_Object
, int *));
81 static void update_buffer_properties
P_ ((int, int));
82 static Lisp_Object region_limit
P_ ((int));
83 int lisp_time_argument
P_ ((Lisp_Object
, time_t *, int *));
84 static size_t emacs_memftimeu
P_ ((char *, size_t, const char *,
85 size_t, const struct tm
*, int));
86 static void general_insert_function
P_ ((void (*) (const unsigned char *, int),
87 void (*) (Lisp_Object
, int, int, int,
89 int, int, Lisp_Object
*));
90 static Lisp_Object subst_char_in_region_unwind
P_ ((Lisp_Object
));
91 static Lisp_Object subst_char_in_region_unwind_1
P_ ((Lisp_Object
));
92 static void transpose_markers
P_ ((int, int, int, int, int, int, int, int));
95 extern char *index
P_ ((const char *, int));
98 Lisp_Object Vbuffer_access_fontify_functions
;
99 Lisp_Object Qbuffer_access_fontify_functions
;
100 Lisp_Object Vbuffer_access_fontified_property
;
102 Lisp_Object Fuser_full_name
P_ ((Lisp_Object
));
104 /* Non-nil means don't stop at field boundary in text motion commands. */
106 Lisp_Object Vinhibit_field_text_motion
;
108 /* Some static data, and a function to initialize it for each run */
110 Lisp_Object Vsystem_name
;
111 Lisp_Object Vuser_real_login_name
; /* login name of current user ID */
112 Lisp_Object Vuser_full_name
; /* full name of current user */
113 Lisp_Object Vuser_login_name
; /* user name from LOGNAME or USER */
114 Lisp_Object Voperating_system_release
; /* Operating System Release */
116 /* Symbol for the text property used to mark fields. */
120 /* A special value for Qfield properties. */
122 Lisp_Object Qboundary
;
129 register unsigned char *p
;
130 struct passwd
*pw
; /* password entry for the current user */
133 /* Set up system_name even when dumping. */
137 /* Don't bother with this on initial start when just dumping out */
140 #endif /* not CANNOT_DUMP */
142 pw
= (struct passwd
*) getpwuid (getuid ());
144 /* We let the real user name default to "root" because that's quite
145 accurate on MSDOG and because it lets Emacs find the init file.
146 (The DVX libraries override the Djgpp libraries here.) */
147 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "root");
149 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "unknown");
152 /* Get the effective user name, by consulting environment variables,
153 or the effective uid if those are unset. */
154 user_name
= (char *) getenv ("LOGNAME");
157 user_name
= (char *) getenv ("USERNAME"); /* it's USERNAME on NT */
158 #else /* WINDOWSNT */
159 user_name
= (char *) getenv ("USER");
160 #endif /* WINDOWSNT */
163 pw
= (struct passwd
*) getpwuid (geteuid ());
164 user_name
= (char *) (pw
? pw
->pw_name
: "unknown");
166 Vuser_login_name
= build_string (user_name
);
168 /* If the user name claimed in the environment vars differs from
169 the real uid, use the claimed name to find the full name. */
170 tem
= Fstring_equal (Vuser_login_name
, Vuser_real_login_name
);
171 Vuser_full_name
= Fuser_full_name (NILP (tem
)? make_number (geteuid())
174 p
= (unsigned char *) getenv ("NAME");
176 Vuser_full_name
= build_string (p
);
177 else if (NILP (Vuser_full_name
))
178 Vuser_full_name
= build_string ("unknown");
180 #ifdef HAVE_SYS_UTSNAME_H
184 Voperating_system_release
= build_string (uts
.release
);
187 Voperating_system_release
= Qnil
;
191 DEFUN ("char-to-string", Fchar_to_string
, Schar_to_string
, 1, 1, 0,
192 doc
: /* Convert arg CHAR to a string containing that character.
193 usage: (char-to-string CHAR) */)
195 Lisp_Object character
;
198 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
200 CHECK_NUMBER (character
);
202 len
= (SINGLE_BYTE_CHAR_P (XFASTINT (character
))
203 ? (*str
= (unsigned char)(XFASTINT (character
)), 1)
204 : char_to_string (XFASTINT (character
), str
));
205 return make_string_from_bytes (str
, 1, len
);
208 DEFUN ("string-to-char", Fstring_to_char
, Sstring_to_char
, 1, 1, 0,
209 doc
: /* Convert arg STRING to a character, the first character of that string.
210 A multibyte character is handled correctly. */)
212 register Lisp_Object string
;
214 register Lisp_Object val
;
215 CHECK_STRING (string
);
218 if (STRING_MULTIBYTE (string
))
219 XSETFASTINT (val
, STRING_CHAR (SDATA (string
), SBYTES (string
)));
221 XSETFASTINT (val
, SREF (string
, 0));
224 XSETFASTINT (val
, 0);
229 buildmark (charpos
, bytepos
)
230 int charpos
, bytepos
;
232 register Lisp_Object mark
;
233 mark
= Fmake_marker ();
234 set_marker_both (mark
, Qnil
, charpos
, bytepos
);
238 DEFUN ("point", Fpoint
, Spoint
, 0, 0, 0,
239 doc
: /* Return value of point, as an integer.
240 Beginning of buffer is position (point-min). */)
244 XSETFASTINT (temp
, PT
);
248 DEFUN ("point-marker", Fpoint_marker
, Spoint_marker
, 0, 0, 0,
249 doc
: /* Return value of point, as a marker object. */)
252 return buildmark (PT
, PT_BYTE
);
256 clip_to_bounds (lower
, num
, upper
)
257 int lower
, num
, upper
;
261 else if (num
> upper
)
267 DEFUN ("goto-char", Fgoto_char
, Sgoto_char
, 1, 1, "NGoto char: ",
268 doc
: /* Set point to POSITION, a number or marker.
269 Beginning of buffer is position (point-min), end is (point-max). */)
271 register Lisp_Object position
;
275 if (MARKERP (position
)
276 && current_buffer
== XMARKER (position
)->buffer
)
278 pos
= marker_position (position
);
280 SET_PT_BOTH (BEGV
, BEGV_BYTE
);
282 SET_PT_BOTH (ZV
, ZV_BYTE
);
284 SET_PT_BOTH (pos
, marker_byte_position (position
));
289 CHECK_NUMBER_COERCE_MARKER (position
);
291 pos
= clip_to_bounds (BEGV
, XINT (position
), ZV
);
297 /* Return the start or end position of the region.
298 BEGINNINGP non-zero means return the start.
299 If there is no region active, signal an error. */
302 region_limit (beginningp
)
305 extern Lisp_Object Vmark_even_if_inactive
; /* Defined in callint.c. */
308 if (!NILP (Vtransient_mark_mode
)
309 && NILP (Vmark_even_if_inactive
)
310 && NILP (current_buffer
->mark_active
))
311 Fsignal (Qmark_inactive
, Qnil
);
313 m
= Fmarker_position (current_buffer
->mark
);
315 error ("The mark is not set now, so there is no region");
317 if ((PT
< XFASTINT (m
)) == (beginningp
!= 0))
318 m
= make_number (PT
);
322 DEFUN ("region-beginning", Fregion_beginning
, Sregion_beginning
, 0, 0, 0,
323 doc
: /* Return position of beginning of region, as an integer. */)
326 return region_limit (1);
329 DEFUN ("region-end", Fregion_end
, Sregion_end
, 0, 0, 0,
330 doc
: /* Return position of end of region, as an integer. */)
333 return region_limit (0);
336 DEFUN ("mark-marker", Fmark_marker
, Smark_marker
, 0, 0, 0,
337 doc
: /* Return this buffer's mark, as a marker object.
338 Watch out! Moving this marker changes the mark position.
339 If you set the marker not to point anywhere, the buffer will have no mark. */)
342 return current_buffer
->mark
;
346 /* Find all the overlays in the current buffer that touch position POS.
347 Return the number found, and store them in a vector in VEC
351 overlays_around (pos
, vec
, len
)
356 Lisp_Object overlay
, start
, end
;
357 struct Lisp_Overlay
*tail
;
358 int startpos
, endpos
;
361 for (tail
= current_buffer
->overlays_before
; tail
; tail
= tail
->next
)
363 XSETMISC (overlay
, tail
);
365 end
= OVERLAY_END (overlay
);
366 endpos
= OVERLAY_POSITION (end
);
369 start
= OVERLAY_START (overlay
);
370 startpos
= OVERLAY_POSITION (start
);
375 /* Keep counting overlays even if we can't return them all. */
380 for (tail
= current_buffer
->overlays_after
; tail
; tail
= tail
->next
)
382 XSETMISC (overlay
, tail
);
384 start
= OVERLAY_START (overlay
);
385 startpos
= OVERLAY_POSITION (start
);
388 end
= OVERLAY_END (overlay
);
389 endpos
= OVERLAY_POSITION (end
);
401 /* Return the value of property PROP, in OBJECT at POSITION.
402 It's the value of PROP that a char inserted at POSITION would get.
403 OBJECT is optional and defaults to the current buffer.
404 If OBJECT is a buffer, then overlay properties are considered as well as
406 If OBJECT is a window, then that window's buffer is used, but
407 window-specific overlays are considered only if they are associated
410 get_pos_property (position
, prop
, object
)
411 Lisp_Object position
, object
;
412 register Lisp_Object prop
;
414 CHECK_NUMBER_COERCE_MARKER (position
);
417 XSETBUFFER (object
, current_buffer
);
418 else if (WINDOWP (object
))
419 object
= XWINDOW (object
)->buffer
;
421 if (!BUFFERP (object
))
422 /* pos-property only makes sense in buffers right now, since strings
423 have no overlays and no notion of insertion for which stickiness
425 return Fget_text_property (position
, prop
, object
);
428 int posn
= XINT (position
);
430 Lisp_Object
*overlay_vec
, tem
;
431 struct buffer
*obuf
= current_buffer
;
433 set_buffer_temp (XBUFFER (object
));
435 /* First try with room for 40 overlays. */
437 overlay_vec
= (Lisp_Object
*) alloca (noverlays
* sizeof (Lisp_Object
));
438 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
440 /* If there are more than 40,
441 make enough space for all, and try again. */
444 overlay_vec
= (Lisp_Object
*) alloca (noverlays
* sizeof (Lisp_Object
));
445 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
447 noverlays
= sort_overlays (overlay_vec
, noverlays
, NULL
);
449 set_buffer_temp (obuf
);
451 /* Now check the overlays in order of decreasing priority. */
452 while (--noverlays
>= 0)
454 Lisp_Object ol
= overlay_vec
[noverlays
];
455 tem
= Foverlay_get (ol
, prop
);
458 /* Check the overlay is indeed active at point. */
459 Lisp_Object start
= OVERLAY_START (ol
), finish
= OVERLAY_END (ol
);
460 if ((OVERLAY_POSITION (start
) == posn
461 && XMARKER (start
)->insertion_type
== 1)
462 || (OVERLAY_POSITION (finish
) == posn
463 && XMARKER (finish
)->insertion_type
== 0))
464 ; /* The overlay will not cover a char inserted at point. */
472 { /* Now check the text-properties. */
473 int stickiness
= text_property_stickiness (prop
, position
, object
);
475 return Fget_text_property (position
, prop
, object
);
476 else if (stickiness
< 0
477 && XINT (position
) > BUF_BEGV (XBUFFER (object
)))
478 return Fget_text_property (make_number (XINT (position
) - 1),
486 /* Find the field surrounding POS in *BEG and *END. If POS is nil,
487 the value of point is used instead. If BEG or END null,
488 means don't store the beginning or end of the field.
490 BEG_LIMIT and END_LIMIT serve to limit the ranged of the returned
491 results; they do not effect boundary behavior.
493 If MERGE_AT_BOUNDARY is nonzero, then if POS is at the very first
494 position of a field, then the beginning of the previous field is
495 returned instead of the beginning of POS's field (since the end of a
496 field is actually also the beginning of the next input field, this
497 behavior is sometimes useful). Additionally in the MERGE_AT_BOUNDARY
498 true case, if two fields are separated by a field with the special
499 value `boundary', and POS lies within it, then the two separated
500 fields are considered to be adjacent, and POS between them, when
501 finding the beginning and ending of the "merged" field.
503 Either BEG or END may be 0, in which case the corresponding value
507 find_field (pos
, merge_at_boundary
, beg_limit
, beg
, end_limit
, end
)
509 Lisp_Object merge_at_boundary
;
510 Lisp_Object beg_limit
, end_limit
;
513 /* Fields right before and after the point. */
514 Lisp_Object before_field
, after_field
;
515 /* 1 if POS counts as the start of a field. */
516 int at_field_start
= 0;
517 /* 1 if POS counts as the end of a field. */
518 int at_field_end
= 0;
521 XSETFASTINT (pos
, PT
);
523 CHECK_NUMBER_COERCE_MARKER (pos
);
526 = get_char_property_and_overlay (pos
, Qfield
, Qnil
, NULL
);
528 = (XFASTINT (pos
) > BEGV
529 ? get_char_property_and_overlay (make_number (XINT (pos
) - 1),
531 /* Using nil here would be a more obvious choice, but it would
532 fail when the buffer starts with a non-sticky field. */
535 /* See if we need to handle the case where MERGE_AT_BOUNDARY is nil
536 and POS is at beginning of a field, which can also be interpreted
537 as the end of the previous field. Note that the case where if
538 MERGE_AT_BOUNDARY is non-nil (see function comment) is actually the
539 more natural one; then we avoid treating the beginning of a field
541 if (NILP (merge_at_boundary
))
543 Lisp_Object field
= get_pos_property (pos
, Qfield
, Qnil
);
544 if (!EQ (field
, after_field
))
546 if (!EQ (field
, before_field
))
548 if (NILP (field
) && at_field_start
&& at_field_end
)
549 /* If an inserted char would have a nil field while the surrounding
550 text is non-nil, we're probably not looking at a
551 zero-length field, but instead at a non-nil field that's
552 not intended for editing (such as comint's prompts). */
553 at_field_end
= at_field_start
= 0;
556 /* Note about special `boundary' fields:
558 Consider the case where the point (`.') is between the fields `x' and `y':
562 In this situation, if merge_at_boundary is true, we consider the
563 `x' and `y' fields as forming one big merged field, and so the end
564 of the field is the end of `y'.
566 However, if `x' and `y' are separated by a special `boundary' field
567 (a field with a `field' char-property of 'boundary), then we ignore
568 this special field when merging adjacent fields. Here's the same
569 situation, but with a `boundary' field between the `x' and `y' fields:
573 Here, if point is at the end of `x', the beginning of `y', or
574 anywhere in-between (within the `boundary' field), we merge all
575 three fields and consider the beginning as being the beginning of
576 the `x' field, and the end as being the end of the `y' field. */
581 /* POS is at the edge of a field, and we should consider it as
582 the beginning of the following field. */
583 *beg
= XFASTINT (pos
);
585 /* Find the previous field boundary. */
588 if (!NILP (merge_at_boundary
) && EQ (before_field
, Qboundary
))
589 /* Skip a `boundary' field. */
590 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
593 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
595 *beg
= NILP (p
) ? BEGV
: XFASTINT (p
);
602 /* POS is at the edge of a field, and we should consider it as
603 the end of the previous field. */
604 *end
= XFASTINT (pos
);
606 /* Find the next field boundary. */
608 if (!NILP (merge_at_boundary
) && EQ (after_field
, Qboundary
))
609 /* Skip a `boundary' field. */
610 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
613 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
615 *end
= NILP (pos
) ? ZV
: XFASTINT (pos
);
621 DEFUN ("delete-field", Fdelete_field
, Sdelete_field
, 0, 1, 0,
622 doc
: /* Delete the field surrounding POS.
623 A field is a region of text with the same `field' property.
624 If POS is nil, the value of point is used for POS. */)
629 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
631 del_range (beg
, end
);
635 DEFUN ("field-string", Ffield_string
, Sfield_string
, 0, 1, 0,
636 doc
: /* Return the contents of the field surrounding POS as a string.
637 A field is a region of text with the same `field' property.
638 If POS is nil, the value of point is used for POS. */)
643 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
644 return make_buffer_string (beg
, end
, 1);
647 DEFUN ("field-string-no-properties", Ffield_string_no_properties
, Sfield_string_no_properties
, 0, 1, 0,
648 doc
: /* Return the contents of the field around POS, without text-properties.
649 A field is a region of text with the same `field' property.
650 If POS is nil, the value of point is used for POS. */)
655 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
656 return make_buffer_string (beg
, end
, 0);
659 DEFUN ("field-beginning", Ffield_beginning
, Sfield_beginning
, 0, 3, 0,
660 doc
: /* Return the beginning of the field surrounding POS.
661 A field is a region of text with the same `field' property.
662 If POS is nil, the value of point is used for POS.
663 If ESCAPE-FROM-EDGE is non-nil and POS is at the beginning of its
664 field, then the beginning of the *previous* field is returned.
665 If LIMIT is non-nil, it is a buffer position; if the beginning of the field
666 is before LIMIT, then LIMIT will be returned instead. */)
667 (pos
, escape_from_edge
, limit
)
668 Lisp_Object pos
, escape_from_edge
, limit
;
671 find_field (pos
, escape_from_edge
, limit
, &beg
, Qnil
, 0);
672 return make_number (beg
);
675 DEFUN ("field-end", Ffield_end
, Sfield_end
, 0, 3, 0,
676 doc
: /* Return the end of the field surrounding POS.
677 A field is a region of text with the same `field' property.
678 If POS is nil, the value of point is used for POS.
679 If ESCAPE-FROM-EDGE is non-nil and POS is at the end of its field,
680 then the end of the *following* field is returned.
681 If LIMIT is non-nil, it is a buffer position; if the end of the field
682 is after LIMIT, then LIMIT will be returned instead. */)
683 (pos
, escape_from_edge
, limit
)
684 Lisp_Object pos
, escape_from_edge
, limit
;
687 find_field (pos
, escape_from_edge
, Qnil
, 0, limit
, &end
);
688 return make_number (end
);
691 DEFUN ("constrain-to-field", Fconstrain_to_field
, Sconstrain_to_field
, 2, 5, 0,
692 doc
: /* Return the position closest to NEW-POS that is in the same field as OLD-POS.
694 A field is a region of text with the same `field' property.
695 If NEW-POS is nil, then the current point is used instead, and set to the
696 constrained position if that is different.
698 If OLD-POS is at the boundary of two fields, then the allowable
699 positions for NEW-POS depends on the value of the optional argument
700 ESCAPE-FROM-EDGE: If ESCAPE-FROM-EDGE is nil, then NEW-POS is
701 constrained to the field that has the same `field' char-property
702 as any new characters inserted at OLD-POS, whereas if ESCAPE-FROM-EDGE
703 is non-nil, NEW-POS is constrained to the union of the two adjacent
704 fields. Additionally, if two fields are separated by another field with
705 the special value `boundary', then any point within this special field is
706 also considered to be `on the boundary'.
708 If the optional argument ONLY-IN-LINE is non-nil and constraining
709 NEW-POS would move it to a different line, NEW-POS is returned
710 unconstrained. This useful for commands that move by line, like
711 \\[next-line] or \\[beginning-of-line], which should generally respect field boundaries
712 only in the case where they can still move to the right line.
714 If the optional argument INHIBIT-CAPTURE-PROPERTY is non-nil, and OLD-POS has
715 a non-nil property of that name, then any field boundaries are ignored.
717 Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */)
718 (new_pos
, old_pos
, escape_from_edge
, only_in_line
, inhibit_capture_property
)
719 Lisp_Object new_pos
, old_pos
;
720 Lisp_Object escape_from_edge
, only_in_line
, inhibit_capture_property
;
722 /* If non-zero, then the original point, before re-positioning. */
725 Lisp_Object prev_old
, prev_new
;
728 /* Use the current point, and afterwards, set it. */
731 XSETFASTINT (new_pos
, PT
);
734 CHECK_NUMBER_COERCE_MARKER (new_pos
);
735 CHECK_NUMBER_COERCE_MARKER (old_pos
);
737 fwd
= (XFASTINT (new_pos
) > XFASTINT (old_pos
));
739 prev_old
= make_number (XFASTINT (old_pos
) - 1);
740 prev_new
= make_number (XFASTINT (new_pos
) - 1);
742 if (NILP (Vinhibit_field_text_motion
)
743 && !EQ (new_pos
, old_pos
)
744 && (!NILP (Fget_char_property (new_pos
, Qfield
, Qnil
))
745 || !NILP (Fget_char_property (old_pos
, Qfield
, Qnil
))
746 /* To recognize field boundaries, we must also look at the
747 previous positions; we could use `get_pos_property'
748 instead, but in itself that would fail inside non-sticky
749 fields (like comint prompts). */
750 || (XFASTINT (new_pos
) > BEGV
751 && !NILP (Fget_char_property (prev_new
, Qfield
, Qnil
)))
752 || (XFASTINT (old_pos
) > BEGV
753 && !NILP (Fget_char_property (prev_old
, Qfield
, Qnil
))))
754 && (NILP (inhibit_capture_property
)
755 /* Field boundaries are again a problem; but now we must
756 decide the case exactly, so we need to call
757 `get_pos_property' as well. */
758 || (NILP (get_pos_property (old_pos
, inhibit_capture_property
, Qnil
))
759 && (XFASTINT (old_pos
) <= BEGV
760 || NILP (Fget_char_property (old_pos
, inhibit_capture_property
, Qnil
))
761 || NILP (Fget_char_property (prev_old
, inhibit_capture_property
, Qnil
))))))
762 /* It is possible that NEW_POS is not within the same field as
763 OLD_POS; try to move NEW_POS so that it is. */
766 Lisp_Object field_bound
;
769 field_bound
= Ffield_end (old_pos
, escape_from_edge
, new_pos
);
771 field_bound
= Ffield_beginning (old_pos
, escape_from_edge
, new_pos
);
773 if (/* See if ESCAPE_FROM_EDGE caused FIELD_BOUND to jump to the
774 other side of NEW_POS, which would mean that NEW_POS is
775 already acceptable, and it's not necessary to constrain it
777 ((XFASTINT (field_bound
) < XFASTINT (new_pos
)) ? fwd
: !fwd
)
778 /* NEW_POS should be constrained, but only if either
779 ONLY_IN_LINE is nil (in which case any constraint is OK),
780 or NEW_POS and FIELD_BOUND are on the same line (in which
781 case the constraint is OK even if ONLY_IN_LINE is non-nil). */
782 && (NILP (only_in_line
)
783 /* This is the ONLY_IN_LINE case, check that NEW_POS and
784 FIELD_BOUND are on the same line by seeing whether
785 there's an intervening newline or not. */
786 || (scan_buffer ('\n',
787 XFASTINT (new_pos
), XFASTINT (field_bound
),
788 fwd
? -1 : 1, &shortage
, 1),
790 /* Constrain NEW_POS to FIELD_BOUND. */
791 new_pos
= field_bound
;
793 if (orig_point
&& XFASTINT (new_pos
) != orig_point
)
794 /* The NEW_POS argument was originally nil, so automatically set PT. */
795 SET_PT (XFASTINT (new_pos
));
802 DEFUN ("line-beginning-position",
803 Fline_beginning_position
, Sline_beginning_position
, 0, 1, 0,
804 doc
: /* Return the character position of the first character on the current line.
805 With argument N not nil or 1, move forward N - 1 lines first.
806 If scan reaches end of buffer, return that position.
808 This function constrains the returned position to the current field
809 unless that would be on a different line than the original,
810 unconstrained result. If N is nil or 1, and a front-sticky field
811 starts at point, the scan stops as soon as it starts. To ignore field
812 boundaries bind `inhibit-field-text-motion' to t.
814 This function does not move point. */)
818 int orig
, orig_byte
, end
;
827 Fforward_line (make_number (XINT (n
) - 1));
830 SET_PT_BOTH (orig
, orig_byte
);
832 /* Return END constrained to the current input field. */
833 return Fconstrain_to_field (make_number (end
), make_number (orig
),
834 XINT (n
) != 1 ? Qt
: Qnil
,
838 DEFUN ("line-end-position", Fline_end_position
, Sline_end_position
, 0, 1, 0,
839 doc
: /* Return the character position of the last character on the current line.
840 With argument N not nil or 1, move forward N - 1 lines first.
841 If scan reaches end of buffer, return that position.
843 This function constrains the returned position to the current field
844 unless that would be on a different line than the original,
845 unconstrained result. If N is nil or 1, and a rear-sticky field ends
846 at point, the scan stops as soon as it starts. To ignore field
847 boundaries bind `inhibit-field-text-motion' to t.
849 This function does not move point. */)
861 end_pos
= find_before_next_newline (orig
, 0, XINT (n
) - (XINT (n
) <= 0));
863 /* Return END_POS constrained to the current input field. */
864 return Fconstrain_to_field (make_number (end_pos
), make_number (orig
),
870 save_excursion_save ()
872 int visible
= (XBUFFER (XWINDOW (selected_window
)->buffer
)
875 return Fcons (Fpoint_marker (),
876 Fcons (Fcopy_marker (current_buffer
->mark
, Qnil
),
877 Fcons (visible
? Qt
: Qnil
,
878 Fcons (current_buffer
->mark_active
,
883 save_excursion_restore (info
)
886 Lisp_Object tem
, tem1
, omark
, nmark
;
887 struct gcpro gcpro1
, gcpro2
, gcpro3
;
890 tem
= Fmarker_buffer (XCAR (info
));
891 /* If buffer being returned to is now deleted, avoid error */
892 /* Otherwise could get error here while unwinding to top level
894 /* In that case, Fmarker_buffer returns nil now. */
898 omark
= nmark
= Qnil
;
899 GCPRO3 (info
, omark
, nmark
);
906 unchain_marker (XMARKER (tem
));
911 omark
= Fmarker_position (current_buffer
->mark
);
912 Fset_marker (current_buffer
->mark
, tem
, Fcurrent_buffer ());
913 nmark
= Fmarker_position (tem
);
914 unchain_marker (XMARKER (tem
));
918 visible_p
= !NILP (XCAR (info
));
920 #if 0 /* We used to make the current buffer visible in the selected window
921 if that was true previously. That avoids some anomalies.
922 But it creates others, and it wasn't documented, and it is simpler
923 and cleaner never to alter the window/buffer connections. */
926 && current_buffer
!= XBUFFER (XWINDOW (selected_window
)->buffer
))
927 Fswitch_to_buffer (Fcurrent_buffer (), Qnil
);
933 tem1
= current_buffer
->mark_active
;
934 current_buffer
->mark_active
= tem
;
936 if (!NILP (Vrun_hooks
))
938 /* If mark is active now, and either was not active
939 or was at a different place, run the activate hook. */
940 if (! NILP (current_buffer
->mark_active
))
942 if (! EQ (omark
, nmark
))
943 call1 (Vrun_hooks
, intern ("activate-mark-hook"));
945 /* If mark has ceased to be active, run deactivate hook. */
946 else if (! NILP (tem1
))
947 call1 (Vrun_hooks
, intern ("deactivate-mark-hook"));
950 /* If buffer was visible in a window, and a different window was
951 selected, and the old selected window is still showing this
952 buffer, restore point in that window. */
955 && !EQ (tem
, selected_window
)
956 && (tem1
= XWINDOW (tem
)->buffer
,
957 (/* Window is live... */
959 /* ...and it shows the current buffer. */
960 && XBUFFER (tem1
) == current_buffer
)))
961 Fset_window_point (tem
, make_number (PT
));
967 DEFUN ("save-excursion", Fsave_excursion
, Ssave_excursion
, 0, UNEVALLED
, 0,
968 doc
: /* Save point, mark, and current buffer; execute BODY; restore those things.
969 Executes BODY just like `progn'.
970 The values of point, mark and the current buffer are restored
971 even in case of abnormal exit (throw or error).
972 The state of activation of the mark is also restored.
974 This construct does not save `deactivate-mark', and therefore
975 functions that change the buffer will still cause deactivation
976 of the mark at the end of the command. To prevent that, bind
977 `deactivate-mark' with `let'.
979 usage: (save-excursion &rest BODY) */)
983 register Lisp_Object val
;
984 int count
= SPECPDL_INDEX ();
986 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
989 return unbind_to (count
, val
);
992 DEFUN ("save-current-buffer", Fsave_current_buffer
, Ssave_current_buffer
, 0, UNEVALLED
, 0,
993 doc
: /* Save the current buffer; execute BODY; restore the current buffer.
994 Executes BODY just like `progn'.
995 usage: (save-current-buffer &rest BODY) */)
1000 int count
= SPECPDL_INDEX ();
1002 record_unwind_protect (set_buffer_if_live
, Fcurrent_buffer ());
1004 val
= Fprogn (args
);
1005 return unbind_to (count
, val
);
1008 DEFUN ("buffer-size", Fbufsize
, Sbufsize
, 0, 1, 0,
1009 doc
: /* Return the number of characters in the current buffer.
1010 If BUFFER, return the number of characters in that buffer instead. */)
1015 return make_number (Z
- BEG
);
1018 CHECK_BUFFER (buffer
);
1019 return make_number (BUF_Z (XBUFFER (buffer
))
1020 - BUF_BEG (XBUFFER (buffer
)));
1024 DEFUN ("point-min", Fpoint_min
, Spoint_min
, 0, 0, 0,
1025 doc
: /* Return the minimum permissible value of point in the current buffer.
1026 This is 1, unless narrowing (a buffer restriction) is in effect. */)
1030 XSETFASTINT (temp
, BEGV
);
1034 DEFUN ("point-min-marker", Fpoint_min_marker
, Spoint_min_marker
, 0, 0, 0,
1035 doc
: /* Return a marker to the minimum permissible value of point in this buffer.
1036 This is the beginning, unless narrowing (a buffer restriction) is in effect. */)
1039 return buildmark (BEGV
, BEGV_BYTE
);
1042 DEFUN ("point-max", Fpoint_max
, Spoint_max
, 0, 0, 0,
1043 doc
: /* Return the maximum permissible value of point in the current buffer.
1044 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1045 is in effect, in which case it is less. */)
1049 XSETFASTINT (temp
, ZV
);
1053 DEFUN ("point-max-marker", Fpoint_max_marker
, Spoint_max_marker
, 0, 0, 0,
1054 doc
: /* Return a marker to the maximum permissible value of point in this buffer.
1055 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1056 is in effect, in which case it is less. */)
1059 return buildmark (ZV
, ZV_BYTE
);
1062 DEFUN ("gap-position", Fgap_position
, Sgap_position
, 0, 0, 0,
1063 doc
: /* Return the position of the gap, in the current buffer.
1064 See also `gap-size'. */)
1068 XSETFASTINT (temp
, GPT
);
1072 DEFUN ("gap-size", Fgap_size
, Sgap_size
, 0, 0, 0,
1073 doc
: /* Return the size of the current buffer's gap.
1074 See also `gap-position'. */)
1078 XSETFASTINT (temp
, GAP_SIZE
);
1082 DEFUN ("position-bytes", Fposition_bytes
, Sposition_bytes
, 1, 1, 0,
1083 doc
: /* Return the byte position for character position POSITION.
1084 If POSITION is out of range, the value is nil. */)
1086 Lisp_Object position
;
1088 CHECK_NUMBER_COERCE_MARKER (position
);
1089 if (XINT (position
) < BEG
|| XINT (position
) > Z
)
1091 return make_number (CHAR_TO_BYTE (XINT (position
)));
1094 DEFUN ("byte-to-position", Fbyte_to_position
, Sbyte_to_position
, 1, 1, 0,
1095 doc
: /* Return the character position for byte position BYTEPOS.
1096 If BYTEPOS is out of range, the value is nil. */)
1098 Lisp_Object bytepos
;
1100 CHECK_NUMBER (bytepos
);
1101 if (XINT (bytepos
) < BEG_BYTE
|| XINT (bytepos
) > Z_BYTE
)
1103 return make_number (BYTE_TO_CHAR (XINT (bytepos
)));
1106 DEFUN ("following-char", Ffollowing_char
, Sfollowing_char
, 0, 0, 0,
1107 doc
: /* Return the character following point, as a number.
1108 At the end of the buffer or accessible region, return 0. */)
1113 XSETFASTINT (temp
, 0);
1115 XSETFASTINT (temp
, FETCH_CHAR (PT_BYTE
));
1119 DEFUN ("preceding-char", Fprevious_char
, Sprevious_char
, 0, 0, 0,
1120 doc
: /* Return the character preceding point, as a number.
1121 At the beginning of the buffer or accessible region, return 0. */)
1126 XSETFASTINT (temp
, 0);
1127 else if (!NILP (current_buffer
->enable_multibyte_characters
))
1131 XSETFASTINT (temp
, FETCH_CHAR (pos
));
1134 XSETFASTINT (temp
, FETCH_BYTE (PT_BYTE
- 1));
1138 DEFUN ("bobp", Fbobp
, Sbobp
, 0, 0, 0,
1139 doc
: /* Return t if point is at the beginning of the buffer.
1140 If the buffer is narrowed, this means the beginning of the narrowed part. */)
1148 DEFUN ("eobp", Feobp
, Seobp
, 0, 0, 0,
1149 doc
: /* Return t if point is at the end of the buffer.
1150 If the buffer is narrowed, this means the end of the narrowed part. */)
1158 DEFUN ("bolp", Fbolp
, Sbolp
, 0, 0, 0,
1159 doc
: /* Return t if point is at the beginning of a line. */)
1162 if (PT
== BEGV
|| FETCH_BYTE (PT_BYTE
- 1) == '\n')
1167 DEFUN ("eolp", Feolp
, Seolp
, 0, 0, 0,
1168 doc
: /* Return t if point is at the end of a line.
1169 `End of a line' includes point being at the end of the buffer. */)
1172 if (PT
== ZV
|| FETCH_BYTE (PT_BYTE
) == '\n')
1177 DEFUN ("char-after", Fchar_after
, Schar_after
, 0, 1, 0,
1178 doc
: /* Return character in current buffer at position POS.
1179 POS is an integer or a marker and defaults to point.
1180 If POS is out of range, the value is nil. */)
1184 register int pos_byte
;
1189 XSETFASTINT (pos
, PT
);
1194 pos_byte
= marker_byte_position (pos
);
1195 if (pos_byte
< BEGV_BYTE
|| pos_byte
>= ZV_BYTE
)
1200 CHECK_NUMBER_COERCE_MARKER (pos
);
1201 if (XINT (pos
) < BEGV
|| XINT (pos
) >= ZV
)
1204 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1207 return make_number (FETCH_CHAR (pos_byte
));
1210 DEFUN ("char-before", Fchar_before
, Schar_before
, 0, 1, 0,
1211 doc
: /* Return character in current buffer preceding position POS.
1212 POS is an integer or a marker and defaults to point.
1213 If POS is out of range, the value is nil. */)
1217 register Lisp_Object val
;
1218 register int pos_byte
;
1223 XSETFASTINT (pos
, PT
);
1228 pos_byte
= marker_byte_position (pos
);
1230 if (pos_byte
<= BEGV_BYTE
|| pos_byte
> ZV_BYTE
)
1235 CHECK_NUMBER_COERCE_MARKER (pos
);
1237 if (XINT (pos
) <= BEGV
|| XINT (pos
) > ZV
)
1240 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1243 if (!NILP (current_buffer
->enable_multibyte_characters
))
1246 XSETFASTINT (val
, FETCH_CHAR (pos_byte
));
1251 XSETFASTINT (val
, FETCH_BYTE (pos_byte
));
1256 DEFUN ("user-login-name", Fuser_login_name
, Suser_login_name
, 0, 1, 0,
1257 doc
: /* Return the name under which the user logged in, as a string.
1258 This is based on the effective uid, not the real uid.
1259 Also, if the environment variables LOGNAME or USER are set,
1260 that determines the value of this function.
1262 If optional argument UID is an integer, return the login name of the user
1263 with that uid, or nil if there is no such user. */)
1269 /* Set up the user name info if we didn't do it before.
1270 (That can happen if Emacs is dumpable
1271 but you decide to run `temacs -l loadup' and not dump. */
1272 if (INTEGERP (Vuser_login_name
))
1276 return Vuser_login_name
;
1279 pw
= (struct passwd
*) getpwuid (XINT (uid
));
1280 return (pw
? build_string (pw
->pw_name
) : Qnil
);
1283 DEFUN ("user-real-login-name", Fuser_real_login_name
, Suser_real_login_name
,
1285 doc
: /* Return the name of the user's real uid, as a string.
1286 This ignores the environment variables LOGNAME and USER, so it differs from
1287 `user-login-name' when running under `su'. */)
1290 /* Set up the user name info if we didn't do it before.
1291 (That can happen if Emacs is dumpable
1292 but you decide to run `temacs -l loadup' and not dump. */
1293 if (INTEGERP (Vuser_login_name
))
1295 return Vuser_real_login_name
;
1298 DEFUN ("user-uid", Fuser_uid
, Suser_uid
, 0, 0, 0,
1299 doc
: /* Return the effective uid of Emacs.
1300 Value is an integer or float, depending on the value. */)
1303 return make_fixnum_or_float (geteuid ());
1306 DEFUN ("user-real-uid", Fuser_real_uid
, Suser_real_uid
, 0, 0, 0,
1307 doc
: /* Return the real uid of Emacs.
1308 Value is an integer or float, depending on the value. */)
1311 return make_fixnum_or_float (getuid ());
1314 DEFUN ("user-full-name", Fuser_full_name
, Suser_full_name
, 0, 1, 0,
1315 doc
: /* Return the full name of the user logged in, as a string.
1316 If the full name corresponding to Emacs's userid is not known,
1319 If optional argument UID is an integer or float, return the full name
1320 of the user with that uid, or nil if there is no such user.
1321 If UID is a string, return the full name of the user with that login
1322 name, or nil if there is no such user. */)
1327 register unsigned char *p
, *q
;
1331 return Vuser_full_name
;
1332 else if (NUMBERP (uid
))
1333 pw
= (struct passwd
*) getpwuid ((uid_t
) XFLOATINT (uid
));
1334 else if (STRINGP (uid
))
1335 pw
= (struct passwd
*) getpwnam (SDATA (uid
));
1337 error ("Invalid UID specification");
1342 p
= (unsigned char *) USER_FULL_NAME
;
1343 /* Chop off everything after the first comma. */
1344 q
= (unsigned char *) index (p
, ',');
1345 full
= make_string (p
, q
? q
- p
: strlen (p
));
1347 #ifdef AMPERSAND_FULL_NAME
1349 q
= (unsigned char *) index (p
, '&');
1350 /* Substitute the login name for the &, upcasing the first character. */
1353 register unsigned char *r
;
1356 login
= Fuser_login_name (make_number (pw
->pw_uid
));
1357 r
= (unsigned char *) alloca (strlen (p
) + SCHARS (login
) + 1);
1358 bcopy (p
, r
, q
- p
);
1360 strcat (r
, SDATA (login
));
1361 r
[q
- p
] = UPCASE (r
[q
- p
]);
1363 full
= build_string (r
);
1365 #endif /* AMPERSAND_FULL_NAME */
1370 DEFUN ("system-name", Fsystem_name
, Ssystem_name
, 0, 0, 0,
1371 doc
: /* Return the name of the machine you are running on, as a string. */)
1374 return Vsystem_name
;
1377 /* For the benefit of callers who don't want to include lisp.h */
1382 if (STRINGP (Vsystem_name
))
1383 return (char *) SDATA (Vsystem_name
);
1389 get_operating_system_release()
1391 if (STRINGP (Voperating_system_release
))
1392 return (char *) SDATA (Voperating_system_release
);
1397 DEFUN ("emacs-pid", Femacs_pid
, Semacs_pid
, 0, 0, 0,
1398 doc
: /* Return the process ID of Emacs, as an integer. */)
1401 return make_number (getpid ());
1404 DEFUN ("current-time", Fcurrent_time
, Scurrent_time
, 0, 0, 0,
1405 doc
: /* Return the current time, as the number of seconds since 1970-01-01 00:00:00.
1406 The time is returned as a list of three integers. The first has the
1407 most significant 16 bits of the seconds, while the second has the
1408 least significant 16 bits. The third integer gives the microsecond
1411 The microsecond count is zero on systems that do not provide
1412 resolution finer than a second. */)
1416 Lisp_Object result
[3];
1419 XSETINT (result
[0], (EMACS_SECS (t
) >> 16) & 0xffff);
1420 XSETINT (result
[1], (EMACS_SECS (t
) >> 0) & 0xffff);
1421 XSETINT (result
[2], EMACS_USECS (t
));
1423 return Flist (3, result
);
1426 DEFUN ("get-internal-run-time", Fget_internal_run_time
, Sget_internal_run_time
,
1428 doc
: /* Return the current run time used by Emacs.
1429 The time is returned as a list of three integers. The first has the
1430 most significant 16 bits of the seconds, while the second has the
1431 least significant 16 bits. The third integer gives the microsecond
1434 On systems that can't determine the run time, get-internal-run-time
1435 does the same thing as current-time. The microsecond count is zero on
1436 systems that do not provide resolution finer than a second. */)
1439 #ifdef HAVE_GETRUSAGE
1440 struct rusage usage
;
1441 Lisp_Object result
[3];
1444 if (getrusage (RUSAGE_SELF
, &usage
) < 0)
1445 /* This shouldn't happen. What action is appropriate? */
1446 Fsignal (Qerror
, Qnil
);
1448 /* Sum up user time and system time. */
1449 secs
= usage
.ru_utime
.tv_sec
+ usage
.ru_stime
.tv_sec
;
1450 usecs
= usage
.ru_utime
.tv_usec
+ usage
.ru_stime
.tv_usec
;
1451 if (usecs
>= 1000000)
1457 XSETINT (result
[0], (secs
>> 16) & 0xffff);
1458 XSETINT (result
[1], (secs
>> 0) & 0xffff);
1459 XSETINT (result
[2], usecs
);
1461 return Flist (3, result
);
1463 return Fcurrent_time ();
1469 lisp_time_argument (specified_time
, result
, usec
)
1470 Lisp_Object specified_time
;
1474 if (NILP (specified_time
))
1481 *usec
= EMACS_USECS (t
);
1482 *result
= EMACS_SECS (t
);
1486 return time (result
) != -1;
1490 Lisp_Object high
, low
;
1491 high
= Fcar (specified_time
);
1492 CHECK_NUMBER (high
);
1493 low
= Fcdr (specified_time
);
1498 Lisp_Object usec_l
= Fcdr (low
);
1500 usec_l
= Fcar (usec_l
);
1505 CHECK_NUMBER (usec_l
);
1506 *usec
= XINT (usec_l
);
1514 *result
= (XINT (high
) << 16) + (XINT (low
) & 0xffff);
1515 return *result
>> 16 == XINT (high
);
1519 DEFUN ("float-time", Ffloat_time
, Sfloat_time
, 0, 1, 0,
1520 doc
: /* Return the current time, as a float number of seconds since the epoch.
1521 If SPECIFIED-TIME is given, it is the time to convert to float
1522 instead of the current time. The argument should have the form
1523 (HIGH LOW . IGNORED). Thus, you can use times obtained from
1524 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
1525 have the form (HIGH . LOW), but this is considered obsolete.
1527 WARNING: Since the result is floating point, it may not be exact.
1528 Do not use this function if precise time stamps are required. */)
1530 Lisp_Object specified_time
;
1535 if (! lisp_time_argument (specified_time
, &sec
, &usec
))
1536 error ("Invalid time specification");
1538 return make_float ((sec
* 1e6
+ usec
) / 1e6
);
1541 /* Write information into buffer S of size MAXSIZE, according to the
1542 FORMAT of length FORMAT_LEN, using time information taken from *TP.
1543 Default to Universal Time if UT is nonzero, local time otherwise.
1544 Return the number of bytes written, not including the terminating
1545 '\0'. If S is NULL, nothing will be written anywhere; so to
1546 determine how many bytes would be written, use NULL for S and
1547 ((size_t) -1) for MAXSIZE.
1549 This function behaves like emacs_strftimeu, except it allows null
1552 emacs_memftimeu (s
, maxsize
, format
, format_len
, tp
, ut
)
1557 const struct tm
*tp
;
1562 /* Loop through all the null-terminated strings in the format
1563 argument. Normally there's just one null-terminated string, but
1564 there can be arbitrarily many, concatenated together, if the
1565 format contains '\0' bytes. emacs_strftimeu stops at the first
1566 '\0' byte so we must invoke it separately for each such string. */
1575 result
= emacs_strftimeu (s
, maxsize
, format
, tp
, ut
);
1579 if (result
== 0 && s
[0] != '\0')
1584 maxsize
-= result
+ 1;
1586 len
= strlen (format
);
1587 if (len
== format_len
)
1591 format_len
-= len
+ 1;
1595 DEFUN ("format-time-string", Fformat_time_string
, Sformat_time_string
, 1, 3, 0,
1596 doc
: /* Use FORMAT-STRING to format the time TIME, or now if omitted.
1597 TIME is specified as (HIGH LOW . IGNORED), as returned by
1598 `current-time' or `file-attributes'. The obsolete form (HIGH . LOW)
1599 is also still accepted.
1600 The third, optional, argument UNIVERSAL, if non-nil, means describe TIME
1601 as Universal Time; nil means describe TIME in the local time zone.
1602 The value is a copy of FORMAT-STRING, but with certain constructs replaced
1603 by text that describes the specified date and time in TIME:
1605 %Y is the year, %y within the century, %C the century.
1606 %G is the year corresponding to the ISO week, %g within the century.
1607 %m is the numeric month.
1608 %b and %h are the locale's abbreviated month name, %B the full name.
1609 %d is the day of the month, zero-padded, %e is blank-padded.
1610 %u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.
1611 %a is the locale's abbreviated name of the day of week, %A the full name.
1612 %U is the week number starting on Sunday, %W starting on Monday,
1613 %V according to ISO 8601.
1614 %j is the day of the year.
1616 %H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H
1617 only blank-padded, %l is like %I blank-padded.
1618 %p is the locale's equivalent of either AM or PM.
1621 %Z is the time zone name, %z is the numeric form.
1622 %s is the number of seconds since 1970-01-01 00:00:00 +0000.
1624 %c is the locale's date and time format.
1625 %x is the locale's "preferred" date format.
1626 %D is like "%m/%d/%y".
1628 %R is like "%H:%M", %T is like "%H:%M:%S", %r is like "%I:%M:%S %p".
1629 %X is the locale's "preferred" time format.
1631 Finally, %n is a newline, %t is a tab, %% is a literal %.
1633 Certain flags and modifiers are available with some format controls.
1634 The flags are `_', `-', `^' and `#'. For certain characters X,
1635 %_X is like %X, but padded with blanks; %-X is like %X,
1636 but without padding. %^X is like %X, but with all textual
1637 characters up-cased; %#X is like %X, but with letter-case of
1638 all textual characters reversed.
1639 %NX (where N stands for an integer) is like %X,
1640 but takes up at least N (a number) positions.
1641 The modifiers are `E' and `O'. For certain characters X,
1642 %EX is a locale's alternative version of %X;
1643 %OX is like %X, but uses the locale's number symbols.
1645 For example, to produce full ISO 8601 format, use "%Y-%m-%dT%T%z". */)
1646 (format_string
, time
, universal
)
1647 Lisp_Object format_string
, time
, universal
;
1652 int ut
= ! NILP (universal
);
1654 CHECK_STRING (format_string
);
1656 if (! lisp_time_argument (time
, &value
, NULL
))
1657 error ("Invalid time specification");
1659 format_string
= code_convert_string_norecord (format_string
,
1660 Vlocale_coding_system
, 1);
1662 /* This is probably enough. */
1663 size
= SBYTES (format_string
) * 6 + 50;
1665 tm
= ut
? gmtime (&value
) : localtime (&value
);
1667 error ("Specified time is not representable");
1669 synchronize_system_time_locale ();
1673 char *buf
= (char *) alloca (size
+ 1);
1677 result
= emacs_memftimeu (buf
, size
, SDATA (format_string
),
1678 SBYTES (format_string
),
1680 if ((result
> 0 && result
< size
) || (result
== 0 && buf
[0] == '\0'))
1681 return code_convert_string_norecord (make_string (buf
, result
),
1682 Vlocale_coding_system
, 0);
1684 /* If buffer was too small, make it bigger and try again. */
1685 result
= emacs_memftimeu (NULL
, (size_t) -1,
1686 SDATA (format_string
),
1687 SBYTES (format_string
),
1693 DEFUN ("decode-time", Fdecode_time
, Sdecode_time
, 0, 1, 0,
1694 doc
: /* Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST ZONE).
1695 The optional SPECIFIED-TIME should be a list of (HIGH LOW . IGNORED),
1696 as from `current-time' and `file-attributes', or `nil' to use the
1697 current time. The obsolete form (HIGH . LOW) is also still accepted.
1698 The list has the following nine members: SEC is an integer between 0
1699 and 60; SEC is 60 for a leap second, which only some operating systems
1700 support. MINUTE is an integer between 0 and 59. HOUR is an integer
1701 between 0 and 23. DAY is an integer between 1 and 31. MONTH is an
1702 integer between 1 and 12. YEAR is an integer indicating the
1703 four-digit year. DOW is the day of week, an integer between 0 and 6,
1704 where 0 is Sunday. DST is t if daylight savings time is effect,
1705 otherwise nil. ZONE is an integer indicating the number of seconds
1706 east of Greenwich. (Note that Common Lisp has different meanings for
1709 Lisp_Object specified_time
;
1713 struct tm
*decoded_time
;
1714 Lisp_Object list_args
[9];
1716 if (! lisp_time_argument (specified_time
, &time_spec
, NULL
))
1717 error ("Invalid time specification");
1719 decoded_time
= localtime (&time_spec
);
1721 error ("Specified time is not representable");
1722 XSETFASTINT (list_args
[0], decoded_time
->tm_sec
);
1723 XSETFASTINT (list_args
[1], decoded_time
->tm_min
);
1724 XSETFASTINT (list_args
[2], decoded_time
->tm_hour
);
1725 XSETFASTINT (list_args
[3], decoded_time
->tm_mday
);
1726 XSETFASTINT (list_args
[4], decoded_time
->tm_mon
+ 1);
1727 XSETINT (list_args
[5], TM_YEAR_BASE
+ (EMACS_INT
) decoded_time
->tm_year
);
1728 XSETFASTINT (list_args
[6], decoded_time
->tm_wday
);
1729 list_args
[7] = (decoded_time
->tm_isdst
)? Qt
: Qnil
;
1731 /* Make a copy, in case gmtime modifies the struct. */
1732 save_tm
= *decoded_time
;
1733 decoded_time
= gmtime (&time_spec
);
1734 if (decoded_time
== 0)
1735 list_args
[8] = Qnil
;
1737 XSETINT (list_args
[8], tm_diff (&save_tm
, decoded_time
));
1738 return Flist (9, list_args
);
1741 DEFUN ("encode-time", Fencode_time
, Sencode_time
, 6, MANY
, 0,
1742 doc
: /* Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.
1743 This is the reverse operation of `decode-time', which see.
1744 ZONE defaults to the current time zone rule. This can
1745 be a string or t (as from `set-time-zone-rule'), or it can be a list
1746 \(as from `current-time-zone') or an integer (as from `decode-time')
1747 applied without consideration for daylight savings time.
1749 You can pass more than 7 arguments; then the first six arguments
1750 are used as SECOND through YEAR, and the *last* argument is used as ZONE.
1751 The intervening arguments are ignored.
1752 This feature lets (apply 'encode-time (decode-time ...)) work.
1754 Out-of-range values for SECOND, MINUTE, HOUR, DAY, or MONTH are allowed;
1755 for example, a DAY of 0 means the day preceding the given month.
1756 Year numbers less than 100 are treated just like other year numbers.
1757 If you want them to stand for years in this century, you must do that yourself.
1759 Years before 1970 are not guaranteed to work. On some systems,
1760 year values as low as 1901 do work.
1762 usage: (encode-time SECOND MINUTE HOUR DAY MONTH YEAR &optional ZONE) */)
1765 register Lisp_Object
*args
;
1769 Lisp_Object zone
= (nargs
> 6 ? args
[nargs
- 1] : Qnil
);
1771 CHECK_NUMBER (args
[0]); /* second */
1772 CHECK_NUMBER (args
[1]); /* minute */
1773 CHECK_NUMBER (args
[2]); /* hour */
1774 CHECK_NUMBER (args
[3]); /* day */
1775 CHECK_NUMBER (args
[4]); /* month */
1776 CHECK_NUMBER (args
[5]); /* year */
1778 tm
.tm_sec
= XINT (args
[0]);
1779 tm
.tm_min
= XINT (args
[1]);
1780 tm
.tm_hour
= XINT (args
[2]);
1781 tm
.tm_mday
= XINT (args
[3]);
1782 tm
.tm_mon
= XINT (args
[4]) - 1;
1783 tm
.tm_year
= XINT (args
[5]) - TM_YEAR_BASE
;
1789 time
= mktime (&tm
);
1794 char **oldenv
= environ
, **newenv
;
1798 else if (STRINGP (zone
))
1799 tzstring
= (char *) SDATA (zone
);
1800 else if (INTEGERP (zone
))
1802 int abszone
= abs (XINT (zone
));
1803 sprintf (tzbuf
, "XXX%s%d:%02d:%02d", "-" + (XINT (zone
) < 0),
1804 abszone
/ (60*60), (abszone
/60) % 60, abszone
% 60);
1808 error ("Invalid time zone specification");
1810 /* Set TZ before calling mktime; merely adjusting mktime's returned
1811 value doesn't suffice, since that would mishandle leap seconds. */
1812 set_time_zone_rule (tzstring
);
1814 time
= mktime (&tm
);
1816 /* Restore TZ to previous value. */
1820 #ifdef LOCALTIME_CACHE
1825 if (time
== (time_t) -1)
1826 error ("Specified time is not representable");
1828 return make_time (time
);
1831 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
, 0, 1, 0,
1832 doc
: /* Return the current time, as a human-readable string.
1833 Programs can use this function to decode a time,
1834 since the number of columns in each field is fixed.
1835 The format is `Sun Sep 16 01:03:52 1973'.
1836 However, see also the functions `decode-time' and `format-time-string'
1837 which provide a much more powerful and general facility.
1839 If SPECIFIED-TIME is given, it is a time to format instead of the
1840 current time. The argument should have the form (HIGH LOW . IGNORED).
1841 Thus, you can use times obtained from `current-time' and from
1842 `file-attributes'. SPECIFIED-TIME can also have the form (HIGH . LOW),
1843 but this is considered obsolete. */)
1845 Lisp_Object specified_time
;
1852 if (! lisp_time_argument (specified_time
, &value
, NULL
))
1853 error ("Invalid time specification");
1854 tm
= localtime (&value
);
1855 if (! (tm
&& -999 - TM_YEAR_BASE
<= tm
->tm_year
1856 && tm
->tm_year
<= 9999 - TM_YEAR_BASE
))
1857 error ("Specified time is not representable");
1860 strncpy (buf
, tem
, 24);
1863 return build_string (buf
);
1866 /* Yield A - B, measured in seconds.
1867 This function is copied from the GNU C Library. */
1872 /* Compute intervening leap days correctly even if year is negative.
1873 Take care to avoid int overflow in leap day calculations,
1874 but it's OK to assume that A and B are close to each other. */
1875 int a4
= (a
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (a
->tm_year
& 3);
1876 int b4
= (b
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (b
->tm_year
& 3);
1877 int a100
= a4
/ 25 - (a4
% 25 < 0);
1878 int b100
= b4
/ 25 - (b4
% 25 < 0);
1879 int a400
= a100
>> 2;
1880 int b400
= b100
>> 2;
1881 int intervening_leap_days
= (a4
- b4
) - (a100
- b100
) + (a400
- b400
);
1882 int years
= a
->tm_year
- b
->tm_year
;
1883 int days
= (365 * years
+ intervening_leap_days
1884 + (a
->tm_yday
- b
->tm_yday
));
1885 return (60 * (60 * (24 * days
+ (a
->tm_hour
- b
->tm_hour
))
1886 + (a
->tm_min
- b
->tm_min
))
1887 + (a
->tm_sec
- b
->tm_sec
));
1890 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 1, 0,
1891 doc
: /* Return the offset and name for the local time zone.
1892 This returns a list of the form (OFFSET NAME).
1893 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).
1894 A negative value means west of Greenwich.
1895 NAME is a string giving the name of the time zone.
1896 If SPECIFIED-TIME is given, the time zone offset is determined from it
1897 instead of using the current time. The argument should have the form
1898 (HIGH LOW . IGNORED). Thus, you can use times obtained from
1899 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
1900 have the form (HIGH . LOW), but this is considered obsolete.
1902 Some operating systems cannot provide all this information to Emacs;
1903 in this case, `current-time-zone' returns a list containing nil for
1904 the data it can't find. */)
1906 Lisp_Object specified_time
;
1912 if (lisp_time_argument (specified_time
, &value
, NULL
)
1913 && (t
= gmtime (&value
)) != 0
1914 && (gmt
= *t
, t
= localtime (&value
)) != 0)
1916 int offset
= tm_diff (t
, &gmt
);
1921 s
= (char *)t
->tm_zone
;
1922 #else /* not HAVE_TM_ZONE */
1924 if (t
->tm_isdst
== 0 || t
->tm_isdst
== 1)
1925 s
= tzname
[t
->tm_isdst
];
1927 #endif /* not HAVE_TM_ZONE */
1929 #if defined HAVE_TM_ZONE || defined HAVE_TZNAME
1932 /* On Japanese w32, we can get a Japanese string as time
1933 zone name. Don't accept that. */
1935 for (p
= s
; *p
&& (isalnum ((unsigned char)*p
) || *p
== ' '); ++p
)
1944 /* No local time zone name is available; use "+-NNNN" instead. */
1945 int am
= (offset
< 0 ? -offset
: offset
) / 60;
1946 sprintf (buf
, "%c%02d%02d", (offset
< 0 ? '-' : '+'), am
/60, am
%60);
1949 return Fcons (make_number (offset
), Fcons (build_string (s
), Qnil
));
1952 return Fmake_list (make_number (2), Qnil
);
1955 /* This holds the value of `environ' produced by the previous
1956 call to Fset_time_zone_rule, or 0 if Fset_time_zone_rule
1957 has never been called. */
1958 static char **environbuf
;
1960 DEFUN ("set-time-zone-rule", Fset_time_zone_rule
, Sset_time_zone_rule
, 1, 1, 0,
1961 doc
: /* Set the local time zone using TZ, a string specifying a time zone rule.
1962 If TZ is nil, use implementation-defined default time zone information.
1963 If TZ is t, use Universal Time. */)
1971 else if (EQ (tz
, Qt
))
1976 tzstring
= (char *) SDATA (tz
);
1979 set_time_zone_rule (tzstring
);
1982 environbuf
= environ
;
1987 #ifdef LOCALTIME_CACHE
1989 /* These two values are known to load tz files in buggy implementations,
1990 i.e. Solaris 1 executables running under either Solaris 1 or Solaris 2.
1991 Their values shouldn't matter in non-buggy implementations.
1992 We don't use string literals for these strings,
1993 since if a string in the environment is in readonly
1994 storage, it runs afoul of bugs in SVR4 and Solaris 2.3.
1995 See Sun bugs 1113095 and 1114114, ``Timezone routines
1996 improperly modify environment''. */
1998 static char set_time_zone_rule_tz1
[] = "TZ=GMT+0";
1999 static char set_time_zone_rule_tz2
[] = "TZ=GMT+1";
2003 /* Set the local time zone rule to TZSTRING.
2004 This allocates memory into `environ', which it is the caller's
2005 responsibility to free. */
2008 set_time_zone_rule (tzstring
)
2012 char **from
, **to
, **newenv
;
2014 /* Make the ENVIRON vector longer with room for TZSTRING. */
2015 for (from
= environ
; *from
; from
++)
2017 envptrs
= from
- environ
+ 2;
2018 newenv
= to
= (char **) xmalloc (envptrs
* sizeof (char *)
2019 + (tzstring
? strlen (tzstring
) + 4 : 0));
2021 /* Add TZSTRING to the end of environ, as a value for TZ. */
2024 char *t
= (char *) (to
+ envptrs
);
2026 strcat (t
, tzstring
);
2030 /* Copy the old environ vector elements into NEWENV,
2031 but don't copy the TZ variable.
2032 So we have only one definition of TZ, which came from TZSTRING. */
2033 for (from
= environ
; *from
; from
++)
2034 if (strncmp (*from
, "TZ=", 3) != 0)
2040 /* If we do have a TZSTRING, NEWENV points to the vector slot where
2041 the TZ variable is stored. If we do not have a TZSTRING,
2042 TO points to the vector slot which has the terminating null. */
2044 #ifdef LOCALTIME_CACHE
2046 /* In SunOS 4.1.3_U1 and 4.1.4, if TZ has a value like
2047 "US/Pacific" that loads a tz file, then changes to a value like
2048 "XXX0" that does not load a tz file, and then changes back to
2049 its original value, the last change is (incorrectly) ignored.
2050 Also, if TZ changes twice in succession to values that do
2051 not load a tz file, tzset can dump core (see Sun bug#1225179).
2052 The following code works around these bugs. */
2056 /* Temporarily set TZ to a value that loads a tz file
2057 and that differs from tzstring. */
2059 *newenv
= (strcmp (tzstring
, set_time_zone_rule_tz1
+ 3) == 0
2060 ? set_time_zone_rule_tz2
: set_time_zone_rule_tz1
);
2066 /* The implied tzstring is unknown, so temporarily set TZ to
2067 two different values that each load a tz file. */
2068 *to
= set_time_zone_rule_tz1
;
2071 *to
= set_time_zone_rule_tz2
;
2076 /* Now TZ has the desired value, and tzset can be invoked safely. */
2083 /* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC
2084 (if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a
2085 type of object is Lisp_String). INHERIT is passed to
2086 INSERT_FROM_STRING_FUNC as the last argument. */
2089 general_insert_function (insert_func
, insert_from_string_func
,
2090 inherit
, nargs
, args
)
2091 void (*insert_func
) P_ ((const unsigned char *, int));
2092 void (*insert_from_string_func
) P_ ((Lisp_Object
, int, int, int, int, int));
2094 register Lisp_Object
*args
;
2096 register int argnum
;
2097 register Lisp_Object val
;
2099 for (argnum
= 0; argnum
< nargs
; argnum
++)
2105 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2108 if (!NILP (current_buffer
->enable_multibyte_characters
))
2109 len
= CHAR_STRING (XFASTINT (val
), str
);
2112 str
[0] = (SINGLE_BYTE_CHAR_P (XINT (val
))
2114 : multibyte_char_to_unibyte (XINT (val
), Qnil
));
2117 (*insert_func
) (str
, len
);
2119 else if (STRINGP (val
))
2121 (*insert_from_string_func
) (val
, 0, 0,
2128 val
= wrong_type_argument (Qchar_or_string_p
, val
);
2142 /* Callers passing one argument to Finsert need not gcpro the
2143 argument "array", since the only element of the array will
2144 not be used after calling insert or insert_from_string, so
2145 we don't care if it gets trashed. */
2147 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
2148 doc
: /* Insert the arguments, either strings or characters, at point.
2149 Point and before-insertion markers move forward to end up
2150 after the inserted text.
2151 Any other markers at the point of insertion remain before the text.
2153 If the current buffer is multibyte, unibyte strings are converted
2154 to multibyte for insertion (see `string-make-multibyte').
2155 If the current buffer is unibyte, multibyte strings are converted
2156 to unibyte for insertion (see `string-make-unibyte').
2158 When operating on binary data, it may be necessary to preserve the
2159 original bytes of a unibyte string when inserting it into a multibyte
2160 buffer; to accomplish this, apply `string-as-multibyte' to the string
2161 and insert the result.
2163 usage: (insert &rest ARGS) */)
2166 register Lisp_Object
*args
;
2168 general_insert_function (insert
, insert_from_string
, 0, nargs
, args
);
2172 DEFUN ("insert-and-inherit", Finsert_and_inherit
, Sinsert_and_inherit
,
2174 doc
: /* Insert the arguments at point, inheriting properties from adjoining text.
2175 Point and before-insertion markers move forward to end up
2176 after the inserted text.
2177 Any other markers at the point of insertion remain before the text.
2179 If the current buffer is multibyte, unibyte strings are converted
2180 to multibyte for insertion (see `unibyte-char-to-multibyte').
2181 If the current buffer is unibyte, multibyte strings are converted
2182 to unibyte for insertion.
2184 usage: (insert-and-inherit &rest ARGS) */)
2187 register Lisp_Object
*args
;
2189 general_insert_function (insert_and_inherit
, insert_from_string
, 1,
2194 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
2195 doc
: /* Insert strings or characters at point, relocating markers after the text.
2196 Point and markers move forward to end up after the inserted text.
2198 If the current buffer is multibyte, unibyte strings are converted
2199 to multibyte for insertion (see `unibyte-char-to-multibyte').
2200 If the current buffer is unibyte, multibyte strings are converted
2201 to unibyte for insertion.
2203 usage: (insert-before-markers &rest ARGS) */)
2206 register Lisp_Object
*args
;
2208 general_insert_function (insert_before_markers
,
2209 insert_from_string_before_markers
, 0,
2214 DEFUN ("insert-before-markers-and-inherit", Finsert_and_inherit_before_markers
,
2215 Sinsert_and_inherit_before_markers
, 0, MANY
, 0,
2216 doc
: /* Insert text at point, relocating markers and inheriting properties.
2217 Point and markers move forward to end up after the inserted text.
2219 If the current buffer is multibyte, unibyte strings are converted
2220 to multibyte for insertion (see `unibyte-char-to-multibyte').
2221 If the current buffer is unibyte, multibyte strings are converted
2222 to unibyte for insertion.
2224 usage: (insert-before-markers-and-inherit &rest ARGS) */)
2227 register Lisp_Object
*args
;
2229 general_insert_function (insert_before_markers_and_inherit
,
2230 insert_from_string_before_markers
, 1,
2235 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 2, 3, 0,
2236 doc
: /* Insert COUNT (second arg) copies of CHARACTER (first arg).
2237 Both arguments are required.
2238 Point, and before-insertion markers, are relocated as in the function `insert'.
2239 The optional third arg INHERIT, if non-nil, says to inherit text properties
2240 from adjoining text, if those properties are sticky. */)
2241 (character
, count
, inherit
)
2242 Lisp_Object character
, count
, inherit
;
2244 register unsigned char *string
;
2245 register int strlen
;
2248 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2250 CHECK_NUMBER (character
);
2251 CHECK_NUMBER (count
);
2253 if (!NILP (current_buffer
->enable_multibyte_characters
))
2254 len
= CHAR_STRING (XFASTINT (character
), str
);
2256 str
[0] = XFASTINT (character
), len
= 1;
2257 n
= XINT (count
) * len
;
2260 strlen
= min (n
, 256 * len
);
2261 string
= (unsigned char *) alloca (strlen
);
2262 for (i
= 0; i
< strlen
; i
++)
2263 string
[i
] = str
[i
% len
];
2267 if (!NILP (inherit
))
2268 insert_and_inherit (string
, strlen
);
2270 insert (string
, strlen
);
2275 if (!NILP (inherit
))
2276 insert_and_inherit (string
, n
);
2284 /* Making strings from buffer contents. */
2286 /* Return a Lisp_String containing the text of the current buffer from
2287 START to END. If text properties are in use and the current buffer
2288 has properties in the range specified, the resulting string will also
2289 have them, if PROPS is nonzero.
2291 We don't want to use plain old make_string here, because it calls
2292 make_uninit_string, which can cause the buffer arena to be
2293 compacted. make_string has no way of knowing that the data has
2294 been moved, and thus copies the wrong data into the string. This
2295 doesn't effect most of the other users of make_string, so it should
2296 be left as is. But we should use this function when conjuring
2297 buffer substrings. */
2300 make_buffer_string (start
, end
, props
)
2304 int start_byte
= CHAR_TO_BYTE (start
);
2305 int end_byte
= CHAR_TO_BYTE (end
);
2307 return make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
);
2310 /* Return a Lisp_String containing the text of the current buffer from
2311 START / START_BYTE to END / END_BYTE.
2313 If text properties are in use and the current buffer
2314 has properties in the range specified, the resulting string will also
2315 have them, if PROPS is nonzero.
2317 We don't want to use plain old make_string here, because it calls
2318 make_uninit_string, which can cause the buffer arena to be
2319 compacted. make_string has no way of knowing that the data has
2320 been moved, and thus copies the wrong data into the string. This
2321 doesn't effect most of the other users of make_string, so it should
2322 be left as is. But we should use this function when conjuring
2323 buffer substrings. */
2326 make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
)
2327 int start
, start_byte
, end
, end_byte
;
2330 Lisp_Object result
, tem
, tem1
;
2332 if (start
< GPT
&& GPT
< end
)
2335 if (! NILP (current_buffer
->enable_multibyte_characters
))
2336 result
= make_uninit_multibyte_string (end
- start
, end_byte
- start_byte
);
2338 result
= make_uninit_string (end
- start
);
2339 bcopy (BYTE_POS_ADDR (start_byte
), SDATA (result
),
2340 end_byte
- start_byte
);
2342 /* If desired, update and copy the text properties. */
2345 update_buffer_properties (start
, end
);
2347 tem
= Fnext_property_change (make_number (start
), Qnil
, make_number (end
));
2348 tem1
= Ftext_properties_at (make_number (start
), Qnil
);
2350 if (XINT (tem
) != end
|| !NILP (tem1
))
2351 copy_intervals_to_string (result
, current_buffer
, start
,
2358 /* Call Vbuffer_access_fontify_functions for the range START ... END
2359 in the current buffer, if necessary. */
2362 update_buffer_properties (start
, end
)
2365 /* If this buffer has some access functions,
2366 call them, specifying the range of the buffer being accessed. */
2367 if (!NILP (Vbuffer_access_fontify_functions
))
2369 Lisp_Object args
[3];
2372 args
[0] = Qbuffer_access_fontify_functions
;
2373 XSETINT (args
[1], start
);
2374 XSETINT (args
[2], end
);
2376 /* But don't call them if we can tell that the work
2377 has already been done. */
2378 if (!NILP (Vbuffer_access_fontified_property
))
2380 tem
= Ftext_property_any (args
[1], args
[2],
2381 Vbuffer_access_fontified_property
,
2384 Frun_hook_with_args (3, args
);
2387 Frun_hook_with_args (3, args
);
2391 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
2392 doc
: /* Return the contents of part of the current buffer as a string.
2393 The two arguments START and END are character positions;
2394 they can be in either order.
2395 The string returned is multibyte if the buffer is multibyte.
2397 This function copies the text properties of that part of the buffer
2398 into the result string; if you don't want the text properties,
2399 use `buffer-substring-no-properties' instead. */)
2401 Lisp_Object start
, end
;
2405 validate_region (&start
, &end
);
2409 return make_buffer_string (b
, e
, 1);
2412 DEFUN ("buffer-substring-no-properties", Fbuffer_substring_no_properties
,
2413 Sbuffer_substring_no_properties
, 2, 2, 0,
2414 doc
: /* Return the characters of part of the buffer, without the text properties.
2415 The two arguments START and END are character positions;
2416 they can be in either order. */)
2418 Lisp_Object start
, end
;
2422 validate_region (&start
, &end
);
2426 return make_buffer_string (b
, e
, 0);
2429 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
2430 doc
: /* Return the contents of the current buffer as a string.
2431 If narrowing is in effect, this function returns only the visible part
2435 return make_buffer_string (BEGV
, ZV
, 1);
2438 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
2440 doc
: /* Insert before point a substring of the contents of BUFFER.
2441 BUFFER may be a buffer or a buffer name.
2442 Arguments START and END are character positions specifying the substring.
2443 They default to the values of (point-min) and (point-max) in BUFFER. */)
2444 (buffer
, start
, end
)
2445 Lisp_Object buffer
, start
, end
;
2447 register int b
, e
, temp
;
2448 register struct buffer
*bp
, *obuf
;
2451 buf
= Fget_buffer (buffer
);
2455 if (NILP (bp
->name
))
2456 error ("Selecting deleted buffer");
2462 CHECK_NUMBER_COERCE_MARKER (start
);
2469 CHECK_NUMBER_COERCE_MARKER (end
);
2474 temp
= b
, b
= e
, e
= temp
;
2476 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
2477 args_out_of_range (start
, end
);
2479 obuf
= current_buffer
;
2480 set_buffer_internal_1 (bp
);
2481 update_buffer_properties (b
, e
);
2482 set_buffer_internal_1 (obuf
);
2484 insert_from_buffer (bp
, b
, e
- b
, 0);
2488 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
2490 doc
: /* Compare two substrings of two buffers; return result as number.
2491 the value is -N if first string is less after N-1 chars,
2492 +N if first string is greater after N-1 chars, or 0 if strings match.
2493 Each substring is represented as three arguments: BUFFER, START and END.
2494 That makes six args in all, three for each substring.
2496 The value of `case-fold-search' in the current buffer
2497 determines whether case is significant or ignored. */)
2498 (buffer1
, start1
, end1
, buffer2
, start2
, end2
)
2499 Lisp_Object buffer1
, start1
, end1
, buffer2
, start2
, end2
;
2501 register int begp1
, endp1
, begp2
, endp2
, temp
;
2502 register struct buffer
*bp1
, *bp2
;
2503 register Lisp_Object trt
2504 = (!NILP (current_buffer
->case_fold_search
)
2505 ? current_buffer
->case_canon_table
: Qnil
);
2507 int i1
, i2
, i1_byte
, i2_byte
;
2509 /* Find the first buffer and its substring. */
2512 bp1
= current_buffer
;
2516 buf1
= Fget_buffer (buffer1
);
2519 bp1
= XBUFFER (buf1
);
2520 if (NILP (bp1
->name
))
2521 error ("Selecting deleted buffer");
2525 begp1
= BUF_BEGV (bp1
);
2528 CHECK_NUMBER_COERCE_MARKER (start1
);
2529 begp1
= XINT (start1
);
2532 endp1
= BUF_ZV (bp1
);
2535 CHECK_NUMBER_COERCE_MARKER (end1
);
2536 endp1
= XINT (end1
);
2540 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
2542 if (!(BUF_BEGV (bp1
) <= begp1
2544 && endp1
<= BUF_ZV (bp1
)))
2545 args_out_of_range (start1
, end1
);
2547 /* Likewise for second substring. */
2550 bp2
= current_buffer
;
2554 buf2
= Fget_buffer (buffer2
);
2557 bp2
= XBUFFER (buf2
);
2558 if (NILP (bp2
->name
))
2559 error ("Selecting deleted buffer");
2563 begp2
= BUF_BEGV (bp2
);
2566 CHECK_NUMBER_COERCE_MARKER (start2
);
2567 begp2
= XINT (start2
);
2570 endp2
= BUF_ZV (bp2
);
2573 CHECK_NUMBER_COERCE_MARKER (end2
);
2574 endp2
= XINT (end2
);
2578 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
2580 if (!(BUF_BEGV (bp2
) <= begp2
2582 && endp2
<= BUF_ZV (bp2
)))
2583 args_out_of_range (start2
, end2
);
2587 i1_byte
= buf_charpos_to_bytepos (bp1
, i1
);
2588 i2_byte
= buf_charpos_to_bytepos (bp2
, i2
);
2590 while (i1
< endp1
&& i2
< endp2
)
2592 /* When we find a mismatch, we must compare the
2593 characters, not just the bytes. */
2598 if (! NILP (bp1
->enable_multibyte_characters
))
2600 c1
= BUF_FETCH_MULTIBYTE_CHAR (bp1
, i1_byte
);
2601 BUF_INC_POS (bp1
, i1_byte
);
2606 c1
= BUF_FETCH_BYTE (bp1
, i1
);
2607 c1
= unibyte_char_to_multibyte (c1
);
2611 if (! NILP (bp2
->enable_multibyte_characters
))
2613 c2
= BUF_FETCH_MULTIBYTE_CHAR (bp2
, i2_byte
);
2614 BUF_INC_POS (bp2
, i2_byte
);
2619 c2
= BUF_FETCH_BYTE (bp2
, i2
);
2620 c2
= unibyte_char_to_multibyte (c2
);
2626 c1
= CHAR_TABLE_TRANSLATE (trt
, c1
);
2627 c2
= CHAR_TABLE_TRANSLATE (trt
, c2
);
2630 return make_number (- 1 - chars
);
2632 return make_number (chars
+ 1);
2637 /* The strings match as far as they go.
2638 If one is shorter, that one is less. */
2639 if (chars
< endp1
- begp1
)
2640 return make_number (chars
+ 1);
2641 else if (chars
< endp2
- begp2
)
2642 return make_number (- chars
- 1);
2644 /* Same length too => they are equal. */
2645 return make_number (0);
2649 subst_char_in_region_unwind (arg
)
2652 return current_buffer
->undo_list
= arg
;
2656 subst_char_in_region_unwind_1 (arg
)
2659 return current_buffer
->filename
= arg
;
2662 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
2663 Ssubst_char_in_region
, 4, 5, 0,
2664 doc
: /* From START to END, replace FROMCHAR with TOCHAR each time it occurs.
2665 If optional arg NOUNDO is non-nil, don't record this change for undo
2666 and don't mark the buffer as really changed.
2667 Both characters must have the same length of multi-byte form. */)
2668 (start
, end
, fromchar
, tochar
, noundo
)
2669 Lisp_Object start
, end
, fromchar
, tochar
, noundo
;
2671 register int pos
, pos_byte
, stop
, i
, len
, end_byte
;
2673 unsigned char fromstr
[MAX_MULTIBYTE_LENGTH
], tostr
[MAX_MULTIBYTE_LENGTH
];
2675 int count
= SPECPDL_INDEX ();
2676 #define COMBINING_NO 0
2677 #define COMBINING_BEFORE 1
2678 #define COMBINING_AFTER 2
2679 #define COMBINING_BOTH (COMBINING_BEFORE | COMBINING_AFTER)
2680 int maybe_byte_combining
= COMBINING_NO
;
2681 int last_changed
= 0;
2682 int multibyte_p
= !NILP (current_buffer
->enable_multibyte_characters
);
2684 validate_region (&start
, &end
);
2685 CHECK_NUMBER (fromchar
);
2686 CHECK_NUMBER (tochar
);
2690 len
= CHAR_STRING (XFASTINT (fromchar
), fromstr
);
2691 if (CHAR_STRING (XFASTINT (tochar
), tostr
) != len
)
2692 error ("Characters in `subst-char-in-region' have different byte-lengths");
2693 if (!ASCII_BYTE_P (*tostr
))
2695 /* If *TOSTR is in the range 0x80..0x9F and TOCHAR is not a
2696 complete multibyte character, it may be combined with the
2697 after bytes. If it is in the range 0xA0..0xFF, it may be
2698 combined with the before and after bytes. */
2699 if (!CHAR_HEAD_P (*tostr
))
2700 maybe_byte_combining
= COMBINING_BOTH
;
2701 else if (BYTES_BY_CHAR_HEAD (*tostr
) > len
)
2702 maybe_byte_combining
= COMBINING_AFTER
;
2708 fromstr
[0] = XFASTINT (fromchar
);
2709 tostr
[0] = XFASTINT (tochar
);
2713 pos_byte
= CHAR_TO_BYTE (pos
);
2714 stop
= CHAR_TO_BYTE (XINT (end
));
2717 /* If we don't want undo, turn off putting stuff on the list.
2718 That's faster than getting rid of things,
2719 and it prevents even the entry for a first change.
2720 Also inhibit locking the file. */
2723 record_unwind_protect (subst_char_in_region_unwind
,
2724 current_buffer
->undo_list
);
2725 current_buffer
->undo_list
= Qt
;
2726 /* Don't do file-locking. */
2727 record_unwind_protect (subst_char_in_region_unwind_1
,
2728 current_buffer
->filename
);
2729 current_buffer
->filename
= Qnil
;
2732 if (pos_byte
< GPT_BYTE
)
2733 stop
= min (stop
, GPT_BYTE
);
2736 int pos_byte_next
= pos_byte
;
2738 if (pos_byte
>= stop
)
2740 if (pos_byte
>= end_byte
) break;
2743 p
= BYTE_POS_ADDR (pos_byte
);
2745 INC_POS (pos_byte_next
);
2748 if (pos_byte_next
- pos_byte
== len
2749 && p
[0] == fromstr
[0]
2751 || (p
[1] == fromstr
[1]
2752 && (len
== 2 || (p
[2] == fromstr
[2]
2753 && (len
== 3 || p
[3] == fromstr
[3]))))))
2758 modify_region (current_buffer
, changed
, XINT (end
));
2760 if (! NILP (noundo
))
2762 if (MODIFF
- 1 == SAVE_MODIFF
)
2764 if (MODIFF
- 1 == current_buffer
->auto_save_modified
)
2765 current_buffer
->auto_save_modified
++;
2769 /* Take care of the case where the new character
2770 combines with neighboring bytes. */
2771 if (maybe_byte_combining
2772 && (maybe_byte_combining
== COMBINING_AFTER
2773 ? (pos_byte_next
< Z_BYTE
2774 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2775 : ((pos_byte_next
< Z_BYTE
2776 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2777 || (pos_byte
> BEG_BYTE
2778 && ! ASCII_BYTE_P (FETCH_BYTE (pos_byte
- 1))))))
2780 Lisp_Object tem
, string
;
2782 struct gcpro gcpro1
;
2784 tem
= current_buffer
->undo_list
;
2787 /* Make a multibyte string containing this single character. */
2788 string
= make_multibyte_string (tostr
, 1, len
);
2789 /* replace_range is less efficient, because it moves the gap,
2790 but it handles combining correctly. */
2791 replace_range (pos
, pos
+ 1, string
,
2793 pos_byte_next
= CHAR_TO_BYTE (pos
);
2794 if (pos_byte_next
> pos_byte
)
2795 /* Before combining happened. We should not increment
2796 POS. So, to cancel the later increment of POS,
2800 INC_POS (pos_byte_next
);
2802 if (! NILP (noundo
))
2803 current_buffer
->undo_list
= tem
;
2810 record_change (pos
, 1);
2811 for (i
= 0; i
< len
; i
++) *p
++ = tostr
[i
];
2813 last_changed
= pos
+ 1;
2815 pos_byte
= pos_byte_next
;
2821 signal_after_change (changed
,
2822 last_changed
- changed
, last_changed
- changed
);
2823 update_compositions (changed
, last_changed
, CHECK_ALL
);
2826 unbind_to (count
, Qnil
);
2830 DEFUN ("translate-region-internal", Ftranslate_region_internal
,
2831 Stranslate_region_internal
, 3, 3, 0,
2832 doc
: /* Internal use only.
2833 From START to END, translate characters according to TABLE.
2834 TABLE is a string; the Nth character in it is the mapping
2835 for the character with code N.
2836 It returns the number of characters changed. */)
2840 register Lisp_Object table
;
2842 register unsigned char *tt
; /* Trans table. */
2843 register int nc
; /* New character. */
2844 int cnt
; /* Number of changes made. */
2845 int size
; /* Size of translate table. */
2846 int pos
, pos_byte
, end_pos
;
2847 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
2848 int string_multibyte
;
2850 validate_region (&start
, &end
);
2851 if (CHAR_TABLE_P (table
))
2858 CHECK_STRING (table
);
2860 if (! multibyte
&& (SCHARS (table
) < SBYTES (table
)))
2861 table
= string_make_unibyte (table
);
2862 string_multibyte
= SCHARS (table
) < SBYTES (table
);
2863 size
= SCHARS (table
);
2868 pos_byte
= CHAR_TO_BYTE (pos
);
2869 end_pos
= XINT (end
);
2870 modify_region (current_buffer
, pos
, XINT (end
));
2873 for (; pos
< end_pos
; )
2875 register unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
2876 unsigned char *str
, buf
[MAX_MULTIBYTE_LENGTH
];
2881 oc
= STRING_CHAR_AND_LENGTH (p
, MAX_MULTIBYTE_LENGTH
, len
);
2888 /* Reload as signal_after_change in last iteration may GC. */
2890 if (string_multibyte
)
2892 str
= tt
+ string_char_to_byte (table
, oc
);
2893 nc
= STRING_CHAR_AND_LENGTH (str
, MAX_MULTIBYTE_LENGTH
,
2899 if (! ASCII_BYTE_P (nc
) && multibyte
)
2901 str_len
= CHAR_STRING (nc
, buf
);
2917 val
= CHAR_TABLE_REF (table
, oc
);
2919 && (c
= XINT (val
), CHAR_VALID_P (c
, 0)))
2922 str_len
= CHAR_STRING (nc
, buf
);
2933 /* This is less efficient, because it moves the gap,
2934 but it should multibyte characters correctly. */
2935 string
= make_multibyte_string (str
, 1, str_len
);
2936 replace_range (pos
, pos
+ 1, string
, 1, 0, 1);
2941 record_change (pos
, 1);
2942 while (str_len
-- > 0)
2944 signal_after_change (pos
, 1, 1);
2945 update_compositions (pos
, pos
+ 1, CHECK_BORDER
);
2954 return make_number (cnt
);
2957 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
2958 doc
: /* Delete the text between point and mark.
2960 When called from a program, expects two arguments,
2961 positions (integers or markers) specifying the stretch to be deleted. */)
2963 Lisp_Object start
, end
;
2965 validate_region (&start
, &end
);
2966 del_range (XINT (start
), XINT (end
));
2970 DEFUN ("delete-and-extract-region", Fdelete_and_extract_region
,
2971 Sdelete_and_extract_region
, 2, 2, 0,
2972 doc
: /* Delete the text between START and END and return it. */)
2974 Lisp_Object start
, end
;
2976 validate_region (&start
, &end
);
2977 if (XINT (start
) == XINT (end
))
2978 return build_string ("");
2979 return del_range_1 (XINT (start
), XINT (end
), 1, 1);
2982 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
2983 doc
: /* Remove restrictions (narrowing) from current buffer.
2984 This allows the buffer's full text to be seen and edited. */)
2987 if (BEG
!= BEGV
|| Z
!= ZV
)
2988 current_buffer
->clip_changed
= 1;
2990 BEGV_BYTE
= BEG_BYTE
;
2991 SET_BUF_ZV_BOTH (current_buffer
, Z
, Z_BYTE
);
2992 /* Changing the buffer bounds invalidates any recorded current column. */
2993 invalidate_current_column ();
2997 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
2998 doc
: /* Restrict editing in this buffer to the current region.
2999 The rest of the text becomes temporarily invisible and untouchable
3000 but is not deleted; if you save the buffer in a file, the invisible
3001 text is included in the file. \\[widen] makes all visible again.
3002 See also `save-restriction'.
3004 When calling from a program, pass two arguments; positions (integers
3005 or markers) bounding the text that should remain visible. */)
3007 register Lisp_Object start
, end
;
3009 CHECK_NUMBER_COERCE_MARKER (start
);
3010 CHECK_NUMBER_COERCE_MARKER (end
);
3012 if (XINT (start
) > XINT (end
))
3015 tem
= start
; start
= end
; end
= tem
;
3018 if (!(BEG
<= XINT (start
) && XINT (start
) <= XINT (end
) && XINT (end
) <= Z
))
3019 args_out_of_range (start
, end
);
3021 if (BEGV
!= XFASTINT (start
) || ZV
!= XFASTINT (end
))
3022 current_buffer
->clip_changed
= 1;
3024 SET_BUF_BEGV (current_buffer
, XFASTINT (start
));
3025 SET_BUF_ZV (current_buffer
, XFASTINT (end
));
3026 if (PT
< XFASTINT (start
))
3027 SET_PT (XFASTINT (start
));
3028 if (PT
> XFASTINT (end
))
3029 SET_PT (XFASTINT (end
));
3030 /* Changing the buffer bounds invalidates any recorded current column. */
3031 invalidate_current_column ();
3036 save_restriction_save ()
3038 if (BEGV
== BEG
&& ZV
== Z
)
3039 /* The common case that the buffer isn't narrowed.
3040 We return just the buffer object, which save_restriction_restore
3041 recognizes as meaning `no restriction'. */
3042 return Fcurrent_buffer ();
3044 /* We have to save a restriction, so return a pair of markers, one
3045 for the beginning and one for the end. */
3047 Lisp_Object beg
, end
;
3049 beg
= buildmark (BEGV
, BEGV_BYTE
);
3050 end
= buildmark (ZV
, ZV_BYTE
);
3052 /* END must move forward if text is inserted at its exact location. */
3053 XMARKER(end
)->insertion_type
= 1;
3055 return Fcons (beg
, end
);
3060 save_restriction_restore (data
)
3064 /* A pair of marks bounding a saved restriction. */
3066 struct Lisp_Marker
*beg
= XMARKER (XCAR (data
));
3067 struct Lisp_Marker
*end
= XMARKER (XCDR (data
));
3068 struct buffer
*buf
= beg
->buffer
; /* END should have the same buffer. */
3070 if (buf
/* Verify marker still points to a buffer. */
3071 && (beg
->charpos
!= BUF_BEGV (buf
) || end
->charpos
!= BUF_ZV (buf
)))
3072 /* The restriction has changed from the saved one, so restore
3073 the saved restriction. */
3075 int pt
= BUF_PT (buf
);
3077 SET_BUF_BEGV_BOTH (buf
, beg
->charpos
, beg
->bytepos
);
3078 SET_BUF_ZV_BOTH (buf
, end
->charpos
, end
->bytepos
);
3080 if (pt
< beg
->charpos
|| pt
> end
->charpos
)
3081 /* The point is outside the new visible range, move it inside. */
3082 SET_BUF_PT_BOTH (buf
,
3083 clip_to_bounds (beg
->charpos
, pt
, end
->charpos
),
3084 clip_to_bounds (beg
->bytepos
, BUF_PT_BYTE (buf
),
3087 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3091 /* A buffer, which means that there was no old restriction. */
3093 struct buffer
*buf
= XBUFFER (data
);
3095 if (buf
/* Verify marker still points to a buffer. */
3096 && (BUF_BEGV (buf
) != BUF_BEG (buf
) || BUF_ZV (buf
) != BUF_Z (buf
)))
3097 /* The buffer has been narrowed, get rid of the narrowing. */
3099 SET_BUF_BEGV_BOTH (buf
, BUF_BEG (buf
), BUF_BEG_BYTE (buf
));
3100 SET_BUF_ZV_BOTH (buf
, BUF_Z (buf
), BUF_Z_BYTE (buf
));
3102 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3109 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
3110 doc
: /* Execute BODY, saving and restoring current buffer's restrictions.
3111 The buffer's restrictions make parts of the beginning and end invisible.
3112 (They are set up with `narrow-to-region' and eliminated with `widen'.)
3113 This special form, `save-restriction', saves the current buffer's restrictions
3114 when it is entered, and restores them when it is exited.
3115 So any `narrow-to-region' within BODY lasts only until the end of the form.
3116 The old restrictions settings are restored
3117 even in case of abnormal exit (throw or error).
3119 The value returned is the value of the last form in BODY.
3121 Note: if you are using both `save-excursion' and `save-restriction',
3122 use `save-excursion' outermost:
3123 (save-excursion (save-restriction ...))
3125 usage: (save-restriction &rest BODY) */)
3129 register Lisp_Object val
;
3130 int count
= SPECPDL_INDEX ();
3132 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
3133 val
= Fprogn (body
);
3134 return unbind_to (count
, val
);
3137 /* Buffer for the most recent text displayed by Fmessage_box. */
3138 static char *message_text
;
3140 /* Allocated length of that buffer. */
3141 static int message_length
;
3143 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
3144 doc
: /* Print a one-line message at the bottom of the screen.
3145 The message also goes into the `*Messages*' buffer.
3146 \(In keyboard macros, that's all it does.)
3148 The first argument is a format control string, and the rest are data
3149 to be formatted under control of the string. See `format' for details.
3151 If the first argument is nil or the empty string, the function clears
3152 any existing message; this lets the minibuffer contents show. See
3153 also `current-message'.
3155 usage: (message FORMAT-STRING &rest ARGS) */)
3161 || (STRINGP (args
[0])
3162 && SBYTES (args
[0]) == 0))
3169 register Lisp_Object val
;
3170 val
= Fformat (nargs
, args
);
3171 message3 (val
, SBYTES (val
), STRING_MULTIBYTE (val
));
3176 DEFUN ("message-box", Fmessage_box
, Smessage_box
, 1, MANY
, 0,
3177 doc
: /* Display a message, in a dialog box if possible.
3178 If a dialog box is not available, use the echo area.
3179 The first argument is a format control string, and the rest are data
3180 to be formatted under control of the string. See `format' for details.
3182 If the first argument is nil or the empty string, clear any existing
3183 message; let the minibuffer contents show.
3185 usage: (message-box FORMAT-STRING &rest ARGS) */)
3197 register Lisp_Object val
;
3198 val
= Fformat (nargs
, args
);
3200 /* The MS-DOS frames support popup menus even though they are
3201 not FRAME_WINDOW_P. */
3202 if (FRAME_WINDOW_P (XFRAME (selected_frame
))
3203 || FRAME_MSDOS_P (XFRAME (selected_frame
)))
3205 Lisp_Object pane
, menu
, obj
;
3206 struct gcpro gcpro1
;
3207 pane
= Fcons (Fcons (build_string ("OK"), Qt
), Qnil
);
3209 menu
= Fcons (val
, pane
);
3210 obj
= Fx_popup_dialog (Qt
, menu
, Qt
);
3214 #endif /* HAVE_MENUS */
3215 /* Copy the data so that it won't move when we GC. */
3218 message_text
= (char *)xmalloc (80);
3219 message_length
= 80;
3221 if (SBYTES (val
) > message_length
)
3223 message_length
= SBYTES (val
);
3224 message_text
= (char *)xrealloc (message_text
, message_length
);
3226 bcopy (SDATA (val
), message_text
, SBYTES (val
));
3227 message2 (message_text
, SBYTES (val
),
3228 STRING_MULTIBYTE (val
));
3233 extern Lisp_Object last_nonmenu_event
;
3236 DEFUN ("message-or-box", Fmessage_or_box
, Smessage_or_box
, 1, MANY
, 0,
3237 doc
: /* Display a message in a dialog box or in the echo area.
3238 If this command was invoked with the mouse, use a dialog box if
3239 `use-dialog-box' is non-nil.
3240 Otherwise, use the echo area.
3241 The first argument is a format control string, and the rest are data
3242 to be formatted under control of the string. See `format' for details.
3244 If the first argument is nil or the empty string, clear any existing
3245 message; let the minibuffer contents show.
3247 usage: (message-or-box FORMAT-STRING &rest ARGS) */)
3253 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3255 return Fmessage_box (nargs
, args
);
3257 return Fmessage (nargs
, args
);
3260 DEFUN ("current-message", Fcurrent_message
, Scurrent_message
, 0, 0, 0,
3261 doc
: /* Return the string currently displayed in the echo area, or nil if none. */)
3264 return current_message ();
3268 DEFUN ("propertize", Fpropertize
, Spropertize
, 1, MANY
, 0,
3269 doc
: /* Return a copy of STRING with text properties added.
3270 First argument is the string to copy.
3271 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
3272 properties to add to the result.
3273 usage: (propertize STRING &rest PROPERTIES) */)
3278 Lisp_Object properties
, string
;
3279 struct gcpro gcpro1
, gcpro2
;
3282 /* Number of args must be odd. */
3283 if ((nargs
& 1) == 0 || nargs
< 1)
3284 error ("Wrong number of arguments");
3286 properties
= string
= Qnil
;
3287 GCPRO2 (properties
, string
);
3289 /* First argument must be a string. */
3290 CHECK_STRING (args
[0]);
3291 string
= Fcopy_sequence (args
[0]);
3293 for (i
= 1; i
< nargs
; i
+= 2)
3294 properties
= Fcons (args
[i
], Fcons (args
[i
+ 1], properties
));
3296 Fadd_text_properties (make_number (0),
3297 make_number (SCHARS (string
)),
3298 properties
, string
);
3299 RETURN_UNGCPRO (string
);
3303 /* Number of bytes that STRING will occupy when put into the result.
3304 MULTIBYTE is nonzero if the result should be multibyte. */
3306 #define CONVERTED_BYTE_SIZE(MULTIBYTE, STRING) \
3307 (((MULTIBYTE) && ! STRING_MULTIBYTE (STRING)) \
3308 ? count_size_as_multibyte (SDATA (STRING), SBYTES (STRING)) \
3311 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
3312 doc
: /* Format a string out of a format-string and arguments.
3313 The first argument is a format control string.
3314 The other arguments are substituted into it to make the result, a string.
3315 It may contain %-sequences meaning to substitute the next argument.
3316 %s means print a string argument. Actually, prints any object, with `princ'.
3317 %d means print as number in decimal (%o octal, %x hex).
3318 %X is like %x, but uses upper case.
3319 %e means print a number in exponential notation.
3320 %f means print a number in decimal-point notation.
3321 %g means print a number in exponential notation
3322 or decimal-point notation, whichever uses fewer characters.
3323 %c means print a number as a single character.
3324 %S means print any object as an s-expression (using `prin1').
3325 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.
3326 Use %% to put a single % into the output.
3328 The basic structure of a %-sequence is
3329 % <flags> <width> <precision> character
3330 where flags is [- #0]+, width is [0-9]+, and precision is .[0-9]+
3332 usage: (format STRING &rest OBJECTS) */)
3335 register Lisp_Object
*args
;
3337 register int n
; /* The number of the next arg to substitute */
3338 register int total
; /* An estimate of the final length */
3340 register unsigned char *format
, *end
, *format_start
;
3342 /* Nonzero if the output should be a multibyte string,
3343 which is true if any of the inputs is one. */
3345 /* When we make a multibyte string, we must pay attention to the
3346 byte combining problem, i.e., a byte may be combined with a
3347 multibyte charcter of the previous string. This flag tells if we
3348 must consider such a situation or not. */
3349 int maybe_combine_byte
;
3350 unsigned char *this_format
;
3351 /* Precision for each spec, or -1, a flag value meaning no precision
3352 was given in that spec. Element 0, corresonding to the format
3353 string itself, will not be used. Element NARGS, corresponding to
3354 no argument, *will* be assigned to in the case that a `%' and `.'
3355 occur after the final format specifier. */
3356 int *precision
= (int *) (alloca((nargs
+ 1) * sizeof (int)));
3359 int arg_intervals
= 0;
3362 /* discarded[I] is 1 if byte I of the format
3363 string was not copied into the output.
3364 It is 2 if byte I was not the first byte of its character. */
3365 char *discarded
= 0;
3367 /* Each element records, for one argument,
3368 the start and end bytepos in the output string,
3369 and whether the argument is a string with intervals.
3370 info[0] is unused. Unused elements have -1 for start. */
3373 int start
, end
, intervals
;
3376 /* It should not be necessary to GCPRO ARGS, because
3377 the caller in the interpreter should take care of that. */
3379 /* Try to determine whether the result should be multibyte.
3380 This is not always right; sometimes the result needs to be multibyte
3381 because of an object that we will pass through prin1,
3382 and in that case, we won't know it here. */
3383 for (n
= 0; n
< nargs
; n
++)
3385 if (STRINGP (args
[n
]) && STRING_MULTIBYTE (args
[n
]))
3387 /* Piggyback on this loop to initialize precision[N]. */
3390 precision
[nargs
] = -1;
3392 CHECK_STRING (args
[0]);
3393 /* We may have to change "%S" to "%s". */
3394 args
[0] = Fcopy_sequence (args
[0]);
3396 /* GC should never happen here, so abort if it does. */
3399 /* If we start out planning a unibyte result,
3400 then discover it has to be multibyte, we jump back to retry.
3401 That can only happen from the first large while loop below. */
3404 format
= SDATA (args
[0]);
3405 format_start
= format
;
3406 end
= format
+ SBYTES (args
[0]);
3409 /* Make room in result for all the non-%-codes in the control string. */
3410 total
= 5 + CONVERTED_BYTE_SIZE (multibyte
, args
[0]) + 1;
3412 /* Allocate the info and discarded tables. */
3414 int nbytes
= (nargs
+1) * sizeof *info
;
3417 info
= (struct info
*) alloca (nbytes
);
3418 bzero (info
, nbytes
);
3419 for (i
= 0; i
<= nargs
; i
++)
3422 SAFE_ALLOCA (discarded
, char *, SBYTES (args
[0]));
3423 bzero (discarded
, SBYTES (args
[0]));
3426 /* Add to TOTAL enough space to hold the converted arguments. */
3429 while (format
!= end
)
3430 if (*format
++ == '%')
3433 int actual_width
= 0;
3434 unsigned char *this_format_start
= format
- 1;
3435 int field_width
= 0;
3437 /* General format specifications look like
3439 '%' [flags] [field-width] [precision] format
3444 field-width ::= [0-9]+
3445 precision ::= '.' [0-9]*
3447 If a field-width is specified, it specifies to which width
3448 the output should be padded with blanks, iff the output
3449 string is shorter than field-width.
3451 If precision is specified, it specifies the number of
3452 digits to print after the '.' for floats, or the max.
3453 number of chars to print from a string. */
3455 while (format
!= end
3456 && (*format
== '-' || *format
== '0' || *format
== '#'
3457 || * format
== ' '))
3460 if (*format
>= '0' && *format
<= '9')
3462 for (field_width
= 0; *format
>= '0' && *format
<= '9'; ++format
)
3463 field_width
= 10 * field_width
+ *format
- '0';
3466 /* N is not incremented for another few lines below, so refer to
3467 element N+1 (which might be precision[NARGS]). */
3471 for (precision
[n
+1] = 0; *format
>= '0' && *format
<= '9'; ++format
)
3472 precision
[n
+1] = 10 * precision
[n
+1] + *format
- '0';
3475 if (format
- this_format_start
+ 1 > longest_format
)
3476 longest_format
= format
- this_format_start
+ 1;
3479 error ("Format string ends in middle of format specifier");
3482 else if (++n
>= nargs
)
3483 error ("Not enough arguments for format string");
3484 else if (*format
== 'S')
3486 /* For `S', prin1 the argument and then treat like a string. */
3487 register Lisp_Object tem
;
3488 tem
= Fprin1_to_string (args
[n
], Qnil
);
3489 if (STRING_MULTIBYTE (tem
) && ! multibyte
)
3495 /* If we restart the loop, we should not come here again
3496 because args[n] is now a string and calling
3497 Fprin1_to_string on it produces superflous double
3498 quotes. So, change "%S" to "%s" now. */
3502 else if (SYMBOLP (args
[n
]))
3504 args
[n
] = SYMBOL_NAME (args
[n
]);
3505 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
3512 else if (STRINGP (args
[n
]))
3515 if (*format
!= 's' && *format
!= 'S')
3516 error ("Format specifier doesn't match argument type");
3517 /* In the case (PRECISION[N] > 0), THISSIZE may not need
3518 to be as large as is calculated here. Easy check for
3519 the case PRECISION = 0. */
3520 thissize
= precision
[n
] ? CONVERTED_BYTE_SIZE (multibyte
, args
[n
]) : 0;
3521 actual_width
= lisp_string_width (args
[n
], -1, NULL
, NULL
);
3523 /* Would get MPV otherwise, since Lisp_Int's `point' to low memory. */
3524 else if (INTEGERP (args
[n
]) && *format
!= 's')
3526 /* The following loop assumes the Lisp type indicates
3527 the proper way to pass the argument.
3528 So make sure we have a flonum if the argument should
3530 if (*format
== 'e' || *format
== 'f' || *format
== 'g')
3531 args
[n
] = Ffloat (args
[n
]);
3533 if (*format
!= 'd' && *format
!= 'o' && *format
!= 'x'
3534 && *format
!= 'i' && *format
!= 'X' && *format
!= 'c')
3535 error ("Invalid format operation %%%c", *format
);
3540 if (! SINGLE_BYTE_CHAR_P (XINT (args
[n
]))
3541 /* Note: No one can remember why we have to treat
3542 the character 0 as a multibyte character here.
3543 But, until it causes a real problem, let's
3545 || XINT (args
[n
]) == 0)
3552 args
[n
] = Fchar_to_string (args
[n
]);
3553 thissize
= SBYTES (args
[n
]);
3555 else if (! ASCII_BYTE_P (XINT (args
[n
])) && multibyte
)
3558 = Fchar_to_string (Funibyte_char_to_multibyte (args
[n
]));
3559 thissize
= SBYTES (args
[n
]);
3563 else if (FLOATP (args
[n
]) && *format
!= 's')
3565 if (! (*format
== 'e' || *format
== 'f' || *format
== 'g'))
3567 if (*format
!= 'd' && *format
!= 'o' && *format
!= 'x'
3568 && *format
!= 'i' && *format
!= 'X' && *format
!= 'c')
3569 error ("Invalid format operation %%%c", *format
);
3570 args
[n
] = Ftruncate (args
[n
], Qnil
);
3573 /* Note that we're using sprintf to print floats,
3574 so we have to take into account what that function
3576 /* Filter out flag value of -1. */
3577 thissize
= (MAX_10_EXP
+ 100
3578 + (precision
[n
] > 0 ? precision
[n
] : 0));
3582 /* Anything but a string, convert to a string using princ. */
3583 register Lisp_Object tem
;
3584 tem
= Fprin1_to_string (args
[n
], Qt
);
3585 if (STRING_MULTIBYTE (tem
) && ! multibyte
)
3594 thissize
+= max (0, field_width
- actual_width
);
3595 total
+= thissize
+ 4;
3600 /* Now we can no longer jump to retry.
3601 TOTAL and LONGEST_FORMAT are known for certain. */
3603 this_format
= (unsigned char *) alloca (longest_format
+ 1);
3605 /* Allocate the space for the result.
3606 Note that TOTAL is an overestimate. */
3607 SAFE_ALLOCA (buf
, char *, total
);
3613 /* Scan the format and store result in BUF. */
3614 format
= SDATA (args
[0]);
3615 format_start
= format
;
3616 end
= format
+ SBYTES (args
[0]);
3617 maybe_combine_byte
= 0;
3618 while (format
!= end
)
3624 unsigned char *this_format_start
= format
;
3626 discarded
[format
- format_start
] = 1;
3629 while (index("-0# ", *format
))
3635 discarded
[format
- format_start
] = 1;
3639 minlen
= atoi (format
);
3641 while ((*format
>= '0' && *format
<= '9') || *format
== '.')
3643 discarded
[format
- format_start
] = 1;
3647 if (*format
++ == '%')
3656 discarded
[format
- format_start
- 1] = 1;
3657 info
[n
].start
= nchars
;
3659 if (STRINGP (args
[n
]))
3661 /* handle case (precision[n] >= 0) */
3664 int nbytes
, start
, end
;
3667 /* lisp_string_width ignores a precision of 0, but GNU
3668 libc functions print 0 characters when the precision
3669 is 0. Imitate libc behavior here. Changing
3670 lisp_string_width is the right thing, and will be
3671 done, but meanwhile we work with it. */
3673 if (precision
[n
] == 0)
3674 width
= nchars_string
= nbytes
= 0;
3675 else if (precision
[n
] > 0)
3676 width
= lisp_string_width (args
[n
], precision
[n
], &nchars_string
, &nbytes
);
3678 { /* no precision spec given for this argument */
3679 width
= lisp_string_width (args
[n
], -1, NULL
, NULL
);
3680 nbytes
= SBYTES (args
[n
]);
3681 nchars_string
= SCHARS (args
[n
]);
3684 /* If spec requires it, pad on right with spaces. */
3685 padding
= minlen
- width
;
3687 while (padding
-- > 0)
3693 info
[n
].start
= start
= nchars
;
3694 nchars
+= nchars_string
;
3699 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3700 && STRING_MULTIBYTE (args
[n
])
3701 && !CHAR_HEAD_P (SREF (args
[n
], 0)))
3702 maybe_combine_byte
= 1;
3704 p
+= copy_text (SDATA (args
[n
]), p
,
3706 STRING_MULTIBYTE (args
[n
]), multibyte
);
3708 info
[n
].end
= nchars
;
3711 while (padding
-- > 0)
3717 /* If this argument has text properties, record where
3718 in the result string it appears. */
3719 if (STRING_INTERVALS (args
[n
]))
3720 info
[n
].intervals
= arg_intervals
= 1;
3722 else if (INTEGERP (args
[n
]) || FLOATP (args
[n
]))
3726 bcopy (this_format_start
, this_format
,
3727 format
- this_format_start
);
3728 this_format
[format
- this_format_start
] = 0;
3730 if (INTEGERP (args
[n
]))
3731 sprintf (p
, this_format
, XINT (args
[n
]));
3733 sprintf (p
, this_format
, XFLOAT_DATA (args
[n
]));
3737 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3738 && !CHAR_HEAD_P (*((unsigned char *) p
)))
3739 maybe_combine_byte
= 1;
3740 this_nchars
= strlen (p
);
3742 p
+= str_to_multibyte (p
, buf
+ total
- 1 - p
, this_nchars
);
3745 nchars
+= this_nchars
;
3746 info
[n
].end
= nchars
;
3750 else if (STRING_MULTIBYTE (args
[0]))
3752 /* Copy a whole multibyte character. */
3755 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3756 && !CHAR_HEAD_P (*format
))
3757 maybe_combine_byte
= 1;
3759 while (! CHAR_HEAD_P (*format
))
3761 discarded
[format
- format_start
] = 2;
3768 /* Convert a single-byte character to multibyte. */
3769 int len
= copy_text (format
, p
, 1, 0, 1);
3776 *p
++ = *format
++, nchars
++;
3779 if (p
> buf
+ total
)
3782 if (maybe_combine_byte
)
3783 nchars
= multibyte_chars_in_text (buf
, p
- buf
);
3784 val
= make_specified_string (buf
, nchars
, p
- buf
, multibyte
);
3786 /* If we allocated BUF with malloc, free it too. */
3789 /* If the format string has text properties, or any of the string
3790 arguments has text properties, set up text properties of the
3793 if (STRING_INTERVALS (args
[0]) || arg_intervals
)
3795 Lisp_Object len
, new_len
, props
;
3796 struct gcpro gcpro1
;
3798 /* Add text properties from the format string. */
3799 len
= make_number (SCHARS (args
[0]));
3800 props
= text_property_list (args
[0], make_number (0), len
, Qnil
);
3805 int bytepos
= 0, position
= 0, translated
= 0, argn
= 1;
3808 /* Adjust the bounds of each text property
3809 to the proper start and end in the output string. */
3811 /* Put the positions in PROPS in increasing order, so that
3812 we can do (effectively) one scan through the position
3813 space of the format string. */
3814 props
= Fnreverse (props
);
3816 /* BYTEPOS is the byte position in the format string,
3817 POSITION is the untranslated char position in it,
3818 TRANSLATED is the translated char position in BUF,
3819 and ARGN is the number of the next arg we will come to. */
3820 for (list
= props
; CONSP (list
); list
= XCDR (list
))
3827 /* First adjust the property start position. */
3828 pos
= XINT (XCAR (item
));
3830 /* Advance BYTEPOS, POSITION, TRANSLATED and ARGN
3831 up to this position. */
3832 for (; position
< pos
; bytepos
++)
3834 if (! discarded
[bytepos
])
3835 position
++, translated
++;
3836 else if (discarded
[bytepos
] == 1)
3839 if (translated
== info
[argn
].start
)
3841 translated
+= info
[argn
].end
- info
[argn
].start
;
3847 XSETCAR (item
, make_number (translated
));
3849 /* Likewise adjust the property end position. */
3850 pos
= XINT (XCAR (XCDR (item
)));
3852 for (; bytepos
< pos
; bytepos
++)
3854 if (! discarded
[bytepos
])
3855 position
++, translated
++;
3856 else if (discarded
[bytepos
] == 1)
3859 if (translated
== info
[argn
].start
)
3861 translated
+= info
[argn
].end
- info
[argn
].start
;
3867 XSETCAR (XCDR (item
), make_number (translated
));
3870 add_text_properties_from_list (val
, props
, make_number (0));
3873 /* Add text properties from arguments. */
3875 for (n
= 1; n
< nargs
; ++n
)
3876 if (info
[n
].intervals
)
3878 len
= make_number (SCHARS (args
[n
]));
3879 new_len
= make_number (info
[n
].end
- info
[n
].start
);
3880 props
= text_property_list (args
[n
], make_number (0), len
, Qnil
);
3881 extend_property_ranges (props
, len
, new_len
);
3882 /* If successive arguments have properites, be sure that
3883 the value of `composition' property be the copy. */
3884 if (n
> 1 && info
[n
- 1].end
)
3885 make_composition_value_copy (props
);
3886 add_text_properties_from_list (val
, props
,
3887 make_number (info
[n
].start
));
3897 format2 (string1
, arg0
, arg1
)
3899 Lisp_Object arg0
, arg1
;
3901 Lisp_Object args
[3];
3902 args
[0] = build_string (string1
);
3905 return Fformat (3, args
);
3908 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
3909 doc
: /* Return t if two characters match, optionally ignoring case.
3910 Both arguments must be characters (i.e. integers).
3911 Case is ignored if `case-fold-search' is non-nil in the current buffer. */)
3913 register Lisp_Object c1
, c2
;
3919 if (XINT (c1
) == XINT (c2
))
3921 if (NILP (current_buffer
->case_fold_search
))
3924 /* Do these in separate statements,
3925 then compare the variables.
3926 because of the way DOWNCASE uses temp variables. */
3927 i1
= DOWNCASE (XFASTINT (c1
));
3928 i2
= DOWNCASE (XFASTINT (c2
));
3929 return (i1
== i2
? Qt
: Qnil
);
3932 /* Transpose the markers in two regions of the current buffer, and
3933 adjust the ones between them if necessary (i.e.: if the regions
3936 START1, END1 are the character positions of the first region.
3937 START1_BYTE, END1_BYTE are the byte positions.
3938 START2, END2 are the character positions of the second region.
3939 START2_BYTE, END2_BYTE are the byte positions.
3941 Traverses the entire marker list of the buffer to do so, adding an
3942 appropriate amount to some, subtracting from some, and leaving the
3943 rest untouched. Most of this is copied from adjust_markers in insdel.c.
3945 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
3948 transpose_markers (start1
, end1
, start2
, end2
,
3949 start1_byte
, end1_byte
, start2_byte
, end2_byte
)
3950 register int start1
, end1
, start2
, end2
;
3951 register int start1_byte
, end1_byte
, start2_byte
, end2_byte
;
3953 register int amt1
, amt1_byte
, amt2
, amt2_byte
, diff
, diff_byte
, mpos
;
3954 register struct Lisp_Marker
*marker
;
3956 /* Update point as if it were a marker. */
3960 TEMP_SET_PT_BOTH (PT
+ (end2
- end1
),
3961 PT_BYTE
+ (end2_byte
- end1_byte
));
3962 else if (PT
< start2
)
3963 TEMP_SET_PT_BOTH (PT
+ (end2
- start2
) - (end1
- start1
),
3964 (PT_BYTE
+ (end2_byte
- start2_byte
)
3965 - (end1_byte
- start1_byte
)));
3967 TEMP_SET_PT_BOTH (PT
- (start2
- start1
),
3968 PT_BYTE
- (start2_byte
- start1_byte
));
3970 /* We used to adjust the endpoints here to account for the gap, but that
3971 isn't good enough. Even if we assume the caller has tried to move the
3972 gap out of our way, it might still be at start1 exactly, for example;
3973 and that places it `inside' the interval, for our purposes. The amount
3974 of adjustment is nontrivial if there's a `denormalized' marker whose
3975 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
3976 the dirty work to Fmarker_position, below. */
3978 /* The difference between the region's lengths */
3979 diff
= (end2
- start2
) - (end1
- start1
);
3980 diff_byte
= (end2_byte
- start2_byte
) - (end1_byte
- start1_byte
);
3982 /* For shifting each marker in a region by the length of the other
3983 region plus the distance between the regions. */
3984 amt1
= (end2
- start2
) + (start2
- end1
);
3985 amt2
= (end1
- start1
) + (start2
- end1
);
3986 amt1_byte
= (end2_byte
- start2_byte
) + (start2_byte
- end1_byte
);
3987 amt2_byte
= (end1_byte
- start1_byte
) + (start2_byte
- end1_byte
);
3989 for (marker
= BUF_MARKERS (current_buffer
); marker
; marker
= marker
->next
)
3991 mpos
= marker
->bytepos
;
3992 if (mpos
>= start1_byte
&& mpos
< end2_byte
)
3994 if (mpos
< end1_byte
)
3996 else if (mpos
< start2_byte
)
4000 marker
->bytepos
= mpos
;
4002 mpos
= marker
->charpos
;
4003 if (mpos
>= start1
&& mpos
< end2
)
4007 else if (mpos
< start2
)
4012 marker
->charpos
= mpos
;
4016 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
4017 doc
: /* Transpose region STARTR1 to ENDR1 with STARTR2 to ENDR2.
4018 The regions may not be overlapping, because the size of the buffer is
4019 never changed in a transposition.
4021 Optional fifth arg LEAVE-MARKERS, if non-nil, means don't update
4022 any markers that happen to be located in the regions.
4024 Transposing beyond buffer boundaries is an error. */)
4025 (startr1
, endr1
, startr2
, endr2
, leave_markers
)
4026 Lisp_Object startr1
, endr1
, startr2
, endr2
, leave_markers
;
4028 register int start1
, end1
, start2
, end2
;
4029 int start1_byte
, start2_byte
, len1_byte
, len2_byte
;
4030 int gap
, len1
, len_mid
, len2
;
4031 unsigned char *start1_addr
, *start2_addr
, *temp
;
4033 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
;
4034 cur_intv
= BUF_INTERVALS (current_buffer
);
4036 validate_region (&startr1
, &endr1
);
4037 validate_region (&startr2
, &endr2
);
4039 start1
= XFASTINT (startr1
);
4040 end1
= XFASTINT (endr1
);
4041 start2
= XFASTINT (startr2
);
4042 end2
= XFASTINT (endr2
);
4045 /* Swap the regions if they're reversed. */
4048 register int glumph
= start1
;
4056 len1
= end1
- start1
;
4057 len2
= end2
- start2
;
4060 error ("Transposed regions overlap");
4061 else if (start1
== end1
|| start2
== end2
)
4062 error ("Transposed region has length 0");
4064 /* The possibilities are:
4065 1. Adjacent (contiguous) regions, or separate but equal regions
4066 (no, really equal, in this case!), or
4067 2. Separate regions of unequal size.
4069 The worst case is usually No. 2. It means that (aside from
4070 potential need for getting the gap out of the way), there also
4071 needs to be a shifting of the text between the two regions. So
4072 if they are spread far apart, we are that much slower... sigh. */
4074 /* It must be pointed out that the really studly thing to do would
4075 be not to move the gap at all, but to leave it in place and work
4076 around it if necessary. This would be extremely efficient,
4077 especially considering that people are likely to do
4078 transpositions near where they are working interactively, which
4079 is exactly where the gap would be found. However, such code
4080 would be much harder to write and to read. So, if you are
4081 reading this comment and are feeling squirrely, by all means have
4082 a go! I just didn't feel like doing it, so I will simply move
4083 the gap the minimum distance to get it out of the way, and then
4084 deal with an unbroken array. */
4086 /* Make sure the gap won't interfere, by moving it out of the text
4087 we will operate on. */
4088 if (start1
< gap
&& gap
< end2
)
4090 if (gap
- start1
< end2
- gap
)
4096 start1_byte
= CHAR_TO_BYTE (start1
);
4097 start2_byte
= CHAR_TO_BYTE (start2
);
4098 len1_byte
= CHAR_TO_BYTE (end1
) - start1_byte
;
4099 len2_byte
= CHAR_TO_BYTE (end2
) - start2_byte
;
4101 #ifdef BYTE_COMBINING_DEBUG
4104 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4105 len2_byte
, start1
, start1_byte
)
4106 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4107 len1_byte
, end2
, start2_byte
+ len2_byte
)
4108 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4109 len1_byte
, end2
, start2_byte
+ len2_byte
))
4114 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4115 len2_byte
, start1
, start1_byte
)
4116 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4117 len1_byte
, start2
, start2_byte
)
4118 || count_combining_after (BYTE_POS_ADDR (start2_byte
),
4119 len2_byte
, end1
, start1_byte
+ len1_byte
)
4120 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4121 len1_byte
, end2
, start2_byte
+ len2_byte
))
4126 /* Hmmm... how about checking to see if the gap is large
4127 enough to use as the temporary storage? That would avoid an
4128 allocation... interesting. Later, don't fool with it now. */
4130 /* Working without memmove, for portability (sigh), so must be
4131 careful of overlapping subsections of the array... */
4133 if (end1
== start2
) /* adjacent regions */
4135 modify_region (current_buffer
, start1
, end2
);
4136 record_change (start1
, len1
+ len2
);
4138 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4139 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4140 Fset_text_properties (make_number (start1
), make_number (end2
),
4143 /* First region smaller than second. */
4144 if (len1_byte
< len2_byte
)
4148 SAFE_ALLOCA (temp
, unsigned char *, len2_byte
);
4150 /* Don't precompute these addresses. We have to compute them
4151 at the last minute, because the relocating allocator might
4152 have moved the buffer around during the xmalloc. */
4153 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4154 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4156 bcopy (start2_addr
, temp
, len2_byte
);
4157 bcopy (start1_addr
, start1_addr
+ len2_byte
, len1_byte
);
4158 bcopy (temp
, start1_addr
, len2_byte
);
4162 /* First region not smaller than second. */
4166 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4167 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4168 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4169 bcopy (start1_addr
, temp
, len1_byte
);
4170 bcopy (start2_addr
, start1_addr
, len2_byte
);
4171 bcopy (temp
, start1_addr
+ len2_byte
, len1_byte
);
4174 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
4175 len1
, current_buffer
, 0);
4176 graft_intervals_into_buffer (tmp_interval2
, start1
,
4177 len2
, current_buffer
, 0);
4178 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4179 update_compositions (start1
+ len2
, end2
, CHECK_TAIL
);
4181 /* Non-adjacent regions, because end1 != start2, bleagh... */
4184 len_mid
= start2_byte
- (start1_byte
+ len1_byte
);
4186 if (len1_byte
== len2_byte
)
4187 /* Regions are same size, though, how nice. */
4191 modify_region (current_buffer
, start1
, end1
);
4192 modify_region (current_buffer
, start2
, end2
);
4193 record_change (start1
, len1
);
4194 record_change (start2
, len2
);
4195 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4196 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4197 Fset_text_properties (make_number (start1
), make_number (end1
),
4199 Fset_text_properties (make_number (start2
), make_number (end2
),
4202 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4203 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4204 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4205 bcopy (start1_addr
, temp
, len1_byte
);
4206 bcopy (start2_addr
, start1_addr
, len2_byte
);
4207 bcopy (temp
, start2_addr
, len1_byte
);
4210 graft_intervals_into_buffer (tmp_interval1
, start2
,
4211 len1
, current_buffer
, 0);
4212 graft_intervals_into_buffer (tmp_interval2
, start1
,
4213 len2
, current_buffer
, 0);
4216 else if (len1_byte
< len2_byte
) /* Second region larger than first */
4217 /* Non-adjacent & unequal size, area between must also be shifted. */
4221 modify_region (current_buffer
, start1
, end2
);
4222 record_change (start1
, (end2
- start1
));
4223 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4224 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4225 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4226 Fset_text_properties (make_number (start1
), make_number (end2
),
4229 /* holds region 2 */
4230 SAFE_ALLOCA (temp
, unsigned char *, len2_byte
);
4231 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4232 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4233 bcopy (start2_addr
, temp
, len2_byte
);
4234 bcopy (start1_addr
, start1_addr
+ len_mid
+ len2_byte
, len1_byte
);
4235 safe_bcopy (start1_addr
+ len1_byte
, start1_addr
+ len2_byte
, len_mid
);
4236 bcopy (temp
, start1_addr
, len2_byte
);
4239 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4240 len1
, current_buffer
, 0);
4241 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4242 len_mid
, current_buffer
, 0);
4243 graft_intervals_into_buffer (tmp_interval2
, start1
,
4244 len2
, current_buffer
, 0);
4247 /* Second region smaller than first. */
4251 record_change (start1
, (end2
- start1
));
4252 modify_region (current_buffer
, start1
, end2
);
4254 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4255 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4256 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4257 Fset_text_properties (make_number (start1
), make_number (end2
),
4260 /* holds region 1 */
4261 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4262 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4263 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4264 bcopy (start1_addr
, temp
, len1_byte
);
4265 bcopy (start2_addr
, start1_addr
, len2_byte
);
4266 bcopy (start1_addr
+ len1_byte
, start1_addr
+ len2_byte
, len_mid
);
4267 bcopy (temp
, start1_addr
+ len2_byte
+ len_mid
, len1_byte
);
4270 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4271 len1
, current_buffer
, 0);
4272 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4273 len_mid
, current_buffer
, 0);
4274 graft_intervals_into_buffer (tmp_interval2
, start1
,
4275 len2
, current_buffer
, 0);
4278 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4279 update_compositions (end2
- len1
, end2
, CHECK_BORDER
);
4282 /* When doing multiple transpositions, it might be nice
4283 to optimize this. Perhaps the markers in any one buffer
4284 should be organized in some sorted data tree. */
4285 if (NILP (leave_markers
))
4287 transpose_markers (start1
, end1
, start2
, end2
,
4288 start1_byte
, start1_byte
+ len1_byte
,
4289 start2_byte
, start2_byte
+ len2_byte
);
4290 fix_start_end_in_overlays (start1
, end2
);
4302 Qbuffer_access_fontify_functions
4303 = intern ("buffer-access-fontify-functions");
4304 staticpro (&Qbuffer_access_fontify_functions
);
4306 DEFVAR_LISP ("inhibit-field-text-motion", &Vinhibit_field_text_motion
,
4307 doc
: /* Non-nil means text motion commands don't notice fields. */);
4308 Vinhibit_field_text_motion
= Qnil
;
4310 DEFVAR_LISP ("buffer-access-fontify-functions",
4311 &Vbuffer_access_fontify_functions
,
4312 doc
: /* List of functions called by `buffer-substring' to fontify if necessary.
4313 Each function is called with two arguments which specify the range
4314 of the buffer being accessed. */);
4315 Vbuffer_access_fontify_functions
= Qnil
;
4319 extern Lisp_Object Vprin1_to_string_buffer
;
4320 obuf
= Fcurrent_buffer ();
4321 /* Do this here, because init_buffer_once is too early--it won't work. */
4322 Fset_buffer (Vprin1_to_string_buffer
);
4323 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
4324 Fset (Fmake_local_variable (intern ("buffer-access-fontify-functions")),
4329 DEFVAR_LISP ("buffer-access-fontified-property",
4330 &Vbuffer_access_fontified_property
,
4331 doc
: /* Property which (if non-nil) indicates text has been fontified.
4332 `buffer-substring' need not call the `buffer-access-fontify-functions'
4333 functions if all the text being accessed has this property. */);
4334 Vbuffer_access_fontified_property
= Qnil
;
4336 DEFVAR_LISP ("system-name", &Vsystem_name
,
4337 doc
: /* The name of the machine Emacs is running on. */);
4339 DEFVAR_LISP ("user-full-name", &Vuser_full_name
,
4340 doc
: /* The full name of the user logged in. */);
4342 DEFVAR_LISP ("user-login-name", &Vuser_login_name
,
4343 doc
: /* The user's name, taken from environment variables if possible. */);
4345 DEFVAR_LISP ("user-real-login-name", &Vuser_real_login_name
,
4346 doc
: /* The user's name, based upon the real uid only. */);
4348 DEFVAR_LISP ("operating-system-release", &Voperating_system_release
,
4349 doc
: /* The release of the operating system Emacs is running on. */);
4351 defsubr (&Spropertize
);
4352 defsubr (&Schar_equal
);
4353 defsubr (&Sgoto_char
);
4354 defsubr (&Sstring_to_char
);
4355 defsubr (&Schar_to_string
);
4356 defsubr (&Sbuffer_substring
);
4357 defsubr (&Sbuffer_substring_no_properties
);
4358 defsubr (&Sbuffer_string
);
4360 defsubr (&Spoint_marker
);
4361 defsubr (&Smark_marker
);
4363 defsubr (&Sregion_beginning
);
4364 defsubr (&Sregion_end
);
4366 staticpro (&Qfield
);
4367 Qfield
= intern ("field");
4368 staticpro (&Qboundary
);
4369 Qboundary
= intern ("boundary");
4370 defsubr (&Sfield_beginning
);
4371 defsubr (&Sfield_end
);
4372 defsubr (&Sfield_string
);
4373 defsubr (&Sfield_string_no_properties
);
4374 defsubr (&Sdelete_field
);
4375 defsubr (&Sconstrain_to_field
);
4377 defsubr (&Sline_beginning_position
);
4378 defsubr (&Sline_end_position
);
4380 /* defsubr (&Smark); */
4381 /* defsubr (&Sset_mark); */
4382 defsubr (&Ssave_excursion
);
4383 defsubr (&Ssave_current_buffer
);
4385 defsubr (&Sbufsize
);
4386 defsubr (&Spoint_max
);
4387 defsubr (&Spoint_min
);
4388 defsubr (&Spoint_min_marker
);
4389 defsubr (&Spoint_max_marker
);
4390 defsubr (&Sgap_position
);
4391 defsubr (&Sgap_size
);
4392 defsubr (&Sposition_bytes
);
4393 defsubr (&Sbyte_to_position
);
4399 defsubr (&Sfollowing_char
);
4400 defsubr (&Sprevious_char
);
4401 defsubr (&Schar_after
);
4402 defsubr (&Schar_before
);
4404 defsubr (&Sinsert_before_markers
);
4405 defsubr (&Sinsert_and_inherit
);
4406 defsubr (&Sinsert_and_inherit_before_markers
);
4407 defsubr (&Sinsert_char
);
4409 defsubr (&Suser_login_name
);
4410 defsubr (&Suser_real_login_name
);
4411 defsubr (&Suser_uid
);
4412 defsubr (&Suser_real_uid
);
4413 defsubr (&Suser_full_name
);
4414 defsubr (&Semacs_pid
);
4415 defsubr (&Scurrent_time
);
4416 defsubr (&Sget_internal_run_time
);
4417 defsubr (&Sformat_time_string
);
4418 defsubr (&Sfloat_time
);
4419 defsubr (&Sdecode_time
);
4420 defsubr (&Sencode_time
);
4421 defsubr (&Scurrent_time_string
);
4422 defsubr (&Scurrent_time_zone
);
4423 defsubr (&Sset_time_zone_rule
);
4424 defsubr (&Ssystem_name
);
4425 defsubr (&Smessage
);
4426 defsubr (&Smessage_box
);
4427 defsubr (&Smessage_or_box
);
4428 defsubr (&Scurrent_message
);
4431 defsubr (&Sinsert_buffer_substring
);
4432 defsubr (&Scompare_buffer_substrings
);
4433 defsubr (&Ssubst_char_in_region
);
4434 defsubr (&Stranslate_region_internal
);
4435 defsubr (&Sdelete_region
);
4436 defsubr (&Sdelete_and_extract_region
);
4438 defsubr (&Snarrow_to_region
);
4439 defsubr (&Ssave_restriction
);
4440 defsubr (&Stranspose_regions
);
4443 /* arch-tag: fc3827d8-6f60-4067-b11e-c3218031b018
4444 (do not change this comment) */