1 /* Lisp functions pertaining to editing.
3 Copyright (C) 1985-1987, 1989, 1993-2011 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software: you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation, either version 3 of the License, or
10 (at your option) any later version.
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
22 #include <sys/types.h>
32 #ifdef HAVE_SYS_UTSNAME_H
33 #include <sys/utsname.h>
38 /* systime.h includes <sys/time.h> which, on some systems, is required
39 for <sys/resource.h>; thus systime.h must be included before
43 #if defined HAVE_SYS_RESOURCE_H
44 #include <sys/resource.h>
54 #include "intervals.h"
56 #include "character.h"
60 #include "blockinput.h"
66 #ifndef USER_FULL_NAME
67 #define USER_FULL_NAME pw->pw_gecos
71 extern char **environ
;
74 #define TM_YEAR_BASE 1900
76 /* Nonzero if TM_YEAR is a struct tm's tm_year value that causes
77 asctime to have well-defined behavior. */
78 #ifndef TM_YEAR_IN_ASCTIME_RANGE
79 # define TM_YEAR_IN_ASCTIME_RANGE(tm_year) \
80 (1000 - TM_YEAR_BASE <= (tm_year) && (tm_year) <= 9999 - TM_YEAR_BASE)
84 extern Lisp_Object
w32_get_internal_run_time (void);
87 static void time_overflow (void) NO_RETURN
;
88 static int tm_diff (struct tm
*, struct tm
*);
89 static void update_buffer_properties (EMACS_INT
, EMACS_INT
);
91 static Lisp_Object Qbuffer_access_fontify_functions
;
92 static Lisp_Object
Fuser_full_name (Lisp_Object
);
94 /* Symbol for the text property used to mark fields. */
98 /* A special value for Qfield properties. */
100 static Lisp_Object Qboundary
;
106 const char *user_name
;
108 struct passwd
*pw
; /* password entry for the current user */
111 /* Set up system_name even when dumping. */
115 /* Don't bother with this on initial start when just dumping out */
118 #endif /* not CANNOT_DUMP */
120 pw
= getpwuid (getuid ());
122 /* We let the real user name default to "root" because that's quite
123 accurate on MSDOG and because it lets Emacs find the init file.
124 (The DVX libraries override the Djgpp libraries here.) */
125 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "root");
127 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "unknown");
130 /* Get the effective user name, by consulting environment variables,
131 or the effective uid if those are unset. */
132 user_name
= getenv ("LOGNAME");
135 user_name
= getenv ("USERNAME"); /* it's USERNAME on NT */
136 #else /* WINDOWSNT */
137 user_name
= getenv ("USER");
138 #endif /* WINDOWSNT */
141 pw
= getpwuid (geteuid ());
142 user_name
= pw
? pw
->pw_name
: "unknown";
144 Vuser_login_name
= build_string (user_name
);
146 /* If the user name claimed in the environment vars differs from
147 the real uid, use the claimed name to find the full name. */
148 tem
= Fstring_equal (Vuser_login_name
, Vuser_real_login_name
);
149 Vuser_full_name
= Fuser_full_name (NILP (tem
)? make_number (geteuid())
154 Vuser_full_name
= build_string (p
);
155 else if (NILP (Vuser_full_name
))
156 Vuser_full_name
= build_string ("unknown");
158 #ifdef HAVE_SYS_UTSNAME_H
162 Voperating_system_release
= build_string (uts
.release
);
165 Voperating_system_release
= Qnil
;
169 DEFUN ("char-to-string", Fchar_to_string
, Schar_to_string
, 1, 1, 0,
170 doc
: /* Convert arg CHAR to a string containing that character.
171 usage: (char-to-string CHAR) */)
172 (Lisp_Object character
)
175 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
177 CHECK_CHARACTER (character
);
178 c
= XFASTINT (character
);
180 len
= CHAR_STRING (c
, str
);
181 return make_string_from_bytes ((char *) str
, 1, len
);
184 DEFUN ("byte-to-string", Fbyte_to_string
, Sbyte_to_string
, 1, 1, 0,
185 doc
: /* Convert arg BYTE to a unibyte string containing that byte. */)
190 if (XINT (byte
) < 0 || XINT (byte
) > 255)
191 error ("Invalid byte");
193 return make_string_from_bytes ((char *) &b
, 1, 1);
196 DEFUN ("string-to-char", Fstring_to_char
, Sstring_to_char
, 1, 1, 0,
197 doc
: /* Convert arg STRING to a character, the first character of that string.
198 A multibyte character is handled correctly. */)
199 (register Lisp_Object string
)
201 register Lisp_Object val
;
202 CHECK_STRING (string
);
205 if (STRING_MULTIBYTE (string
))
206 XSETFASTINT (val
, STRING_CHAR (SDATA (string
)));
208 XSETFASTINT (val
, SREF (string
, 0));
211 XSETFASTINT (val
, 0);
216 buildmark (EMACS_INT charpos
, EMACS_INT bytepos
)
218 register Lisp_Object mark
;
219 mark
= Fmake_marker ();
220 set_marker_both (mark
, Qnil
, charpos
, bytepos
);
224 DEFUN ("point", Fpoint
, Spoint
, 0, 0, 0,
225 doc
: /* Return value of point, as an integer.
226 Beginning of buffer is position (point-min). */)
230 XSETFASTINT (temp
, PT
);
234 DEFUN ("point-marker", Fpoint_marker
, Spoint_marker
, 0, 0, 0,
235 doc
: /* Return value of point, as a marker object. */)
238 return buildmark (PT
, PT_BYTE
);
242 clip_to_bounds (EMACS_INT lower
, EMACS_INT num
, EMACS_INT upper
)
246 else if (num
> upper
)
252 DEFUN ("goto-char", Fgoto_char
, Sgoto_char
, 1, 1, "NGoto char: ",
253 doc
: /* Set point to POSITION, a number or marker.
254 Beginning of buffer is position (point-min), end is (point-max).
256 The return value is POSITION. */)
257 (register Lisp_Object position
)
261 if (MARKERP (position
)
262 && current_buffer
== XMARKER (position
)->buffer
)
264 pos
= marker_position (position
);
266 SET_PT_BOTH (BEGV
, BEGV_BYTE
);
268 SET_PT_BOTH (ZV
, ZV_BYTE
);
270 SET_PT_BOTH (pos
, marker_byte_position (position
));
275 CHECK_NUMBER_COERCE_MARKER (position
);
277 pos
= clip_to_bounds (BEGV
, XINT (position
), ZV
);
283 /* Return the start or end position of the region.
284 BEGINNINGP non-zero means return the start.
285 If there is no region active, signal an error. */
288 region_limit (int beginningp
)
292 if (!NILP (Vtransient_mark_mode
)
293 && NILP (Vmark_even_if_inactive
)
294 && NILP (BVAR (current_buffer
, mark_active
)))
295 xsignal0 (Qmark_inactive
);
297 m
= Fmarker_position (BVAR (current_buffer
, mark
));
299 error ("The mark is not set now, so there is no region");
301 if ((PT
< XFASTINT (m
)) == (beginningp
!= 0))
302 m
= make_number (PT
);
306 DEFUN ("region-beginning", Fregion_beginning
, Sregion_beginning
, 0, 0, 0,
307 doc
: /* Return the integer value of point or mark, whichever is smaller. */)
310 return region_limit (1);
313 DEFUN ("region-end", Fregion_end
, Sregion_end
, 0, 0, 0,
314 doc
: /* Return the integer value of point or mark, whichever is larger. */)
317 return region_limit (0);
320 DEFUN ("mark-marker", Fmark_marker
, Smark_marker
, 0, 0, 0,
321 doc
: /* Return this buffer's mark, as a marker object.
322 Watch out! Moving this marker changes the mark position.
323 If you set the marker not to point anywhere, the buffer will have no mark. */)
326 return BVAR (current_buffer
, mark
);
330 /* Find all the overlays in the current buffer that touch position POS.
331 Return the number found, and store them in a vector in VEC
335 overlays_around (EMACS_INT pos
, Lisp_Object
*vec
, ptrdiff_t len
)
337 Lisp_Object overlay
, start
, end
;
338 struct Lisp_Overlay
*tail
;
339 EMACS_INT startpos
, endpos
;
342 for (tail
= current_buffer
->overlays_before
; tail
; tail
= tail
->next
)
344 XSETMISC (overlay
, tail
);
346 end
= OVERLAY_END (overlay
);
347 endpos
= OVERLAY_POSITION (end
);
350 start
= OVERLAY_START (overlay
);
351 startpos
= OVERLAY_POSITION (start
);
356 /* Keep counting overlays even if we can't return them all. */
361 for (tail
= current_buffer
->overlays_after
; tail
; tail
= tail
->next
)
363 XSETMISC (overlay
, tail
);
365 start
= OVERLAY_START (overlay
);
366 startpos
= OVERLAY_POSITION (start
);
369 end
= OVERLAY_END (overlay
);
370 endpos
= OVERLAY_POSITION (end
);
382 /* Return the value of property PROP, in OBJECT at POSITION.
383 It's the value of PROP that a char inserted at POSITION would get.
384 OBJECT is optional and defaults to the current buffer.
385 If OBJECT is a buffer, then overlay properties are considered as well as
387 If OBJECT is a window, then that window's buffer is used, but
388 window-specific overlays are considered only if they are associated
391 get_pos_property (Lisp_Object position
, register Lisp_Object prop
, Lisp_Object object
)
393 CHECK_NUMBER_COERCE_MARKER (position
);
396 XSETBUFFER (object
, current_buffer
);
397 else if (WINDOWP (object
))
398 object
= XWINDOW (object
)->buffer
;
400 if (!BUFFERP (object
))
401 /* pos-property only makes sense in buffers right now, since strings
402 have no overlays and no notion of insertion for which stickiness
404 return Fget_text_property (position
, prop
, object
);
407 EMACS_INT posn
= XINT (position
);
409 Lisp_Object
*overlay_vec
, tem
;
410 struct buffer
*obuf
= current_buffer
;
412 set_buffer_temp (XBUFFER (object
));
414 /* First try with room for 40 overlays. */
416 overlay_vec
= (Lisp_Object
*) alloca (noverlays
* sizeof (Lisp_Object
));
417 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
419 /* If there are more than 40,
420 make enough space for all, and try again. */
423 overlay_vec
= (Lisp_Object
*) alloca (noverlays
* sizeof (Lisp_Object
));
424 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
426 noverlays
= sort_overlays (overlay_vec
, noverlays
, NULL
);
428 set_buffer_temp (obuf
);
430 /* Now check the overlays in order of decreasing priority. */
431 while (--noverlays
>= 0)
433 Lisp_Object ol
= overlay_vec
[noverlays
];
434 tem
= Foverlay_get (ol
, prop
);
437 /* Check the overlay is indeed active at point. */
438 Lisp_Object start
= OVERLAY_START (ol
), finish
= OVERLAY_END (ol
);
439 if ((OVERLAY_POSITION (start
) == posn
440 && XMARKER (start
)->insertion_type
== 1)
441 || (OVERLAY_POSITION (finish
) == posn
442 && XMARKER (finish
)->insertion_type
== 0))
443 ; /* The overlay will not cover a char inserted at point. */
451 { /* Now check the text properties. */
452 int stickiness
= text_property_stickiness (prop
, position
, object
);
454 return Fget_text_property (position
, prop
, object
);
455 else if (stickiness
< 0
456 && XINT (position
) > BUF_BEGV (XBUFFER (object
)))
457 return Fget_text_property (make_number (XINT (position
) - 1),
465 /* Find the field surrounding POS in *BEG and *END. If POS is nil,
466 the value of point is used instead. If BEG or END is null,
467 means don't store the beginning or end of the field.
469 BEG_LIMIT and END_LIMIT serve to limit the ranged of the returned
470 results; they do not effect boundary behavior.
472 If MERGE_AT_BOUNDARY is nonzero, then if POS is at the very first
473 position of a field, then the beginning of the previous field is
474 returned instead of the beginning of POS's field (since the end of a
475 field is actually also the beginning of the next input field, this
476 behavior is sometimes useful). Additionally in the MERGE_AT_BOUNDARY
477 true case, if two fields are separated by a field with the special
478 value `boundary', and POS lies within it, then the two separated
479 fields are considered to be adjacent, and POS between them, when
480 finding the beginning and ending of the "merged" field.
482 Either BEG or END may be 0, in which case the corresponding value
486 find_field (Lisp_Object pos
, Lisp_Object merge_at_boundary
,
487 Lisp_Object beg_limit
,
488 EMACS_INT
*beg
, Lisp_Object end_limit
, EMACS_INT
*end
)
490 /* Fields right before and after the point. */
491 Lisp_Object before_field
, after_field
;
492 /* 1 if POS counts as the start of a field. */
493 int at_field_start
= 0;
494 /* 1 if POS counts as the end of a field. */
495 int at_field_end
= 0;
498 XSETFASTINT (pos
, PT
);
500 CHECK_NUMBER_COERCE_MARKER (pos
);
503 = get_char_property_and_overlay (pos
, Qfield
, Qnil
, NULL
);
505 = (XFASTINT (pos
) > BEGV
506 ? get_char_property_and_overlay (make_number (XINT (pos
) - 1),
508 /* Using nil here would be a more obvious choice, but it would
509 fail when the buffer starts with a non-sticky field. */
512 /* See if we need to handle the case where MERGE_AT_BOUNDARY is nil
513 and POS is at beginning of a field, which can also be interpreted
514 as the end of the previous field. Note that the case where if
515 MERGE_AT_BOUNDARY is non-nil (see function comment) is actually the
516 more natural one; then we avoid treating the beginning of a field
518 if (NILP (merge_at_boundary
))
520 Lisp_Object field
= get_pos_property (pos
, Qfield
, Qnil
);
521 if (!EQ (field
, after_field
))
523 if (!EQ (field
, before_field
))
525 if (NILP (field
) && at_field_start
&& at_field_end
)
526 /* If an inserted char would have a nil field while the surrounding
527 text is non-nil, we're probably not looking at a
528 zero-length field, but instead at a non-nil field that's
529 not intended for editing (such as comint's prompts). */
530 at_field_end
= at_field_start
= 0;
533 /* Note about special `boundary' fields:
535 Consider the case where the point (`.') is between the fields `x' and `y':
539 In this situation, if merge_at_boundary is true, we consider the
540 `x' and `y' fields as forming one big merged field, and so the end
541 of the field is the end of `y'.
543 However, if `x' and `y' are separated by a special `boundary' field
544 (a field with a `field' char-property of 'boundary), then we ignore
545 this special field when merging adjacent fields. Here's the same
546 situation, but with a `boundary' field between the `x' and `y' fields:
550 Here, if point is at the end of `x', the beginning of `y', or
551 anywhere in-between (within the `boundary' field), we merge all
552 three fields and consider the beginning as being the beginning of
553 the `x' field, and the end as being the end of the `y' field. */
558 /* POS is at the edge of a field, and we should consider it as
559 the beginning of the following field. */
560 *beg
= XFASTINT (pos
);
562 /* Find the previous field boundary. */
565 if (!NILP (merge_at_boundary
) && EQ (before_field
, Qboundary
))
566 /* Skip a `boundary' field. */
567 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
570 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
572 *beg
= NILP (p
) ? BEGV
: XFASTINT (p
);
579 /* POS is at the edge of a field, and we should consider it as
580 the end of the previous field. */
581 *end
= XFASTINT (pos
);
583 /* Find the next field boundary. */
585 if (!NILP (merge_at_boundary
) && EQ (after_field
, Qboundary
))
586 /* Skip a `boundary' field. */
587 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
590 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
592 *end
= NILP (pos
) ? ZV
: XFASTINT (pos
);
598 DEFUN ("delete-field", Fdelete_field
, Sdelete_field
, 0, 1, 0,
599 doc
: /* Delete the field surrounding POS.
600 A field is a region of text with the same `field' property.
601 If POS is nil, the value of point is used for POS. */)
605 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
607 del_range (beg
, end
);
611 DEFUN ("field-string", Ffield_string
, Sfield_string
, 0, 1, 0,
612 doc
: /* Return the contents of the field surrounding POS as a string.
613 A field is a region of text with the same `field' property.
614 If POS is nil, the value of point is used for POS. */)
618 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
619 return make_buffer_string (beg
, end
, 1);
622 DEFUN ("field-string-no-properties", Ffield_string_no_properties
, Sfield_string_no_properties
, 0, 1, 0,
623 doc
: /* Return the contents of the field around POS, without text properties.
624 A field is a region of text with the same `field' property.
625 If POS is nil, the value of point is used for POS. */)
629 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
630 return make_buffer_string (beg
, end
, 0);
633 DEFUN ("field-beginning", Ffield_beginning
, Sfield_beginning
, 0, 3, 0,
634 doc
: /* Return the beginning of the field surrounding POS.
635 A field is a region of text with the same `field' property.
636 If POS is nil, the value of point is used for POS.
637 If ESCAPE-FROM-EDGE is non-nil and POS is at the beginning of its
638 field, then the beginning of the *previous* field is returned.
639 If LIMIT is non-nil, it is a buffer position; if the beginning of the field
640 is before LIMIT, then LIMIT will be returned instead. */)
641 (Lisp_Object pos
, Lisp_Object escape_from_edge
, Lisp_Object limit
)
644 find_field (pos
, escape_from_edge
, limit
, &beg
, Qnil
, 0);
645 return make_number (beg
);
648 DEFUN ("field-end", Ffield_end
, Sfield_end
, 0, 3, 0,
649 doc
: /* Return the end of the field surrounding POS.
650 A field is a region of text with the same `field' property.
651 If POS is nil, the value of point is used for POS.
652 If ESCAPE-FROM-EDGE is non-nil and POS is at the end of its field,
653 then the end of the *following* field is returned.
654 If LIMIT is non-nil, it is a buffer position; if the end of the field
655 is after LIMIT, then LIMIT will be returned instead. */)
656 (Lisp_Object pos
, Lisp_Object escape_from_edge
, Lisp_Object limit
)
659 find_field (pos
, escape_from_edge
, Qnil
, 0, limit
, &end
);
660 return make_number (end
);
663 DEFUN ("constrain-to-field", Fconstrain_to_field
, Sconstrain_to_field
, 2, 5, 0,
664 doc
: /* Return the position closest to NEW-POS that is in the same field as OLD-POS.
666 A field is a region of text with the same `field' property.
667 If NEW-POS is nil, then the current point is used instead, and set to the
668 constrained position if that is different.
670 If OLD-POS is at the boundary of two fields, then the allowable
671 positions for NEW-POS depends on the value of the optional argument
672 ESCAPE-FROM-EDGE: If ESCAPE-FROM-EDGE is nil, then NEW-POS is
673 constrained to the field that has the same `field' char-property
674 as any new characters inserted at OLD-POS, whereas if ESCAPE-FROM-EDGE
675 is non-nil, NEW-POS is constrained to the union of the two adjacent
676 fields. Additionally, if two fields are separated by another field with
677 the special value `boundary', then any point within this special field is
678 also considered to be `on the boundary'.
680 If the optional argument ONLY-IN-LINE is non-nil and constraining
681 NEW-POS would move it to a different line, NEW-POS is returned
682 unconstrained. This useful for commands that move by line, like
683 \\[next-line] or \\[beginning-of-line], which should generally respect field boundaries
684 only in the case where they can still move to the right line.
686 If the optional argument INHIBIT-CAPTURE-PROPERTY is non-nil, and OLD-POS has
687 a non-nil property of that name, then any field boundaries are ignored.
689 Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */)
690 (Lisp_Object new_pos
, Lisp_Object old_pos
, Lisp_Object escape_from_edge
, Lisp_Object only_in_line
, Lisp_Object inhibit_capture_property
)
692 /* If non-zero, then the original point, before re-positioning. */
693 EMACS_INT orig_point
= 0;
695 Lisp_Object prev_old
, prev_new
;
698 /* Use the current point, and afterwards, set it. */
701 XSETFASTINT (new_pos
, PT
);
704 CHECK_NUMBER_COERCE_MARKER (new_pos
);
705 CHECK_NUMBER_COERCE_MARKER (old_pos
);
707 fwd
= (XFASTINT (new_pos
) > XFASTINT (old_pos
));
709 prev_old
= make_number (XFASTINT (old_pos
) - 1);
710 prev_new
= make_number (XFASTINT (new_pos
) - 1);
712 if (NILP (Vinhibit_field_text_motion
)
713 && !EQ (new_pos
, old_pos
)
714 && (!NILP (Fget_char_property (new_pos
, Qfield
, Qnil
))
715 || !NILP (Fget_char_property (old_pos
, Qfield
, Qnil
))
716 /* To recognize field boundaries, we must also look at the
717 previous positions; we could use `get_pos_property'
718 instead, but in itself that would fail inside non-sticky
719 fields (like comint prompts). */
720 || (XFASTINT (new_pos
) > BEGV
721 && !NILP (Fget_char_property (prev_new
, Qfield
, Qnil
)))
722 || (XFASTINT (old_pos
) > BEGV
723 && !NILP (Fget_char_property (prev_old
, Qfield
, Qnil
))))
724 && (NILP (inhibit_capture_property
)
725 /* Field boundaries are again a problem; but now we must
726 decide the case exactly, so we need to call
727 `get_pos_property' as well. */
728 || (NILP (get_pos_property (old_pos
, inhibit_capture_property
, Qnil
))
729 && (XFASTINT (old_pos
) <= BEGV
730 || NILP (Fget_char_property (old_pos
, inhibit_capture_property
, Qnil
))
731 || NILP (Fget_char_property (prev_old
, inhibit_capture_property
, Qnil
))))))
732 /* It is possible that NEW_POS is not within the same field as
733 OLD_POS; try to move NEW_POS so that it is. */
736 Lisp_Object field_bound
;
739 field_bound
= Ffield_end (old_pos
, escape_from_edge
, new_pos
);
741 field_bound
= Ffield_beginning (old_pos
, escape_from_edge
, new_pos
);
743 if (/* See if ESCAPE_FROM_EDGE caused FIELD_BOUND to jump to the
744 other side of NEW_POS, which would mean that NEW_POS is
745 already acceptable, and it's not necessary to constrain it
747 ((XFASTINT (field_bound
) < XFASTINT (new_pos
)) ? fwd
: !fwd
)
748 /* NEW_POS should be constrained, but only if either
749 ONLY_IN_LINE is nil (in which case any constraint is OK),
750 or NEW_POS and FIELD_BOUND are on the same line (in which
751 case the constraint is OK even if ONLY_IN_LINE is non-nil). */
752 && (NILP (only_in_line
)
753 /* This is the ONLY_IN_LINE case, check that NEW_POS and
754 FIELD_BOUND are on the same line by seeing whether
755 there's an intervening newline or not. */
756 || (scan_buffer ('\n',
757 XFASTINT (new_pos
), XFASTINT (field_bound
),
758 fwd
? -1 : 1, &shortage
, 1),
760 /* Constrain NEW_POS to FIELD_BOUND. */
761 new_pos
= field_bound
;
763 if (orig_point
&& XFASTINT (new_pos
) != orig_point
)
764 /* The NEW_POS argument was originally nil, so automatically set PT. */
765 SET_PT (XFASTINT (new_pos
));
772 DEFUN ("line-beginning-position",
773 Fline_beginning_position
, Sline_beginning_position
, 0, 1, 0,
774 doc
: /* Return the character position of the first character on the current line.
775 With argument N not nil or 1, move forward N - 1 lines first.
776 If scan reaches end of buffer, return that position.
778 The returned position is of the first character in the logical order,
779 i.e. the one that has the smallest character position.
781 This function constrains the returned position to the current field
782 unless that would be on a different line than the original,
783 unconstrained result. If N is nil or 1, and a front-sticky field
784 starts at point, the scan stops as soon as it starts. To ignore field
785 boundaries bind `inhibit-field-text-motion' to t.
787 This function does not move point. */)
790 EMACS_INT orig
, orig_byte
, end
;
791 int count
= SPECPDL_INDEX ();
792 specbind (Qinhibit_point_motion_hooks
, Qt
);
801 Fforward_line (make_number (XINT (n
) - 1));
804 SET_PT_BOTH (orig
, orig_byte
);
806 unbind_to (count
, Qnil
);
808 /* Return END constrained to the current input field. */
809 return Fconstrain_to_field (make_number (end
), make_number (orig
),
810 XINT (n
) != 1 ? Qt
: Qnil
,
814 DEFUN ("line-end-position", Fline_end_position
, Sline_end_position
, 0, 1, 0,
815 doc
: /* Return the character position of the last character on the current line.
816 With argument N not nil or 1, move forward N - 1 lines first.
817 If scan reaches end of buffer, return that position.
819 The returned position is of the last character in the logical order,
820 i.e. the character whose buffer position is the largest one.
822 This function constrains the returned position to the current field
823 unless that would be on a different line than the original,
824 unconstrained result. If N is nil or 1, and a rear-sticky field ends
825 at point, the scan stops as soon as it starts. To ignore field
826 boundaries bind `inhibit-field-text-motion' to t.
828 This function does not move point. */)
839 end_pos
= find_before_next_newline (orig
, 0, XINT (n
) - (XINT (n
) <= 0));
841 /* Return END_POS constrained to the current input field. */
842 return Fconstrain_to_field (make_number (end_pos
), make_number (orig
),
848 save_excursion_save (void)
850 int visible
= (XBUFFER (XWINDOW (selected_window
)->buffer
)
853 return Fcons (Fpoint_marker (),
854 Fcons (Fcopy_marker (BVAR (current_buffer
, mark
), Qnil
),
855 Fcons (visible
? Qt
: Qnil
,
856 Fcons (BVAR (current_buffer
, mark_active
),
861 save_excursion_restore (Lisp_Object info
)
863 Lisp_Object tem
, tem1
, omark
, nmark
;
864 struct gcpro gcpro1
, gcpro2
, gcpro3
;
867 tem
= Fmarker_buffer (XCAR (info
));
868 /* If buffer being returned to is now deleted, avoid error */
869 /* Otherwise could get error here while unwinding to top level
871 /* In that case, Fmarker_buffer returns nil now. */
875 omark
= nmark
= Qnil
;
876 GCPRO3 (info
, omark
, nmark
);
883 unchain_marker (XMARKER (tem
));
888 omark
= Fmarker_position (BVAR (current_buffer
, mark
));
889 Fset_marker (BVAR (current_buffer
, mark
), tem
, Fcurrent_buffer ());
890 nmark
= Fmarker_position (tem
);
891 unchain_marker (XMARKER (tem
));
895 visible_p
= !NILP (XCAR (info
));
897 #if 0 /* We used to make the current buffer visible in the selected window
898 if that was true previously. That avoids some anomalies.
899 But it creates others, and it wasn't documented, and it is simpler
900 and cleaner never to alter the window/buffer connections. */
903 && current_buffer
!= XBUFFER (XWINDOW (selected_window
)->buffer
))
904 Fswitch_to_buffer (Fcurrent_buffer (), Qnil
);
910 tem1
= BVAR (current_buffer
, mark_active
);
911 BVAR (current_buffer
, mark_active
) = tem
;
913 /* If mark is active now, and either was not active
914 or was at a different place, run the activate hook. */
917 if (! EQ (omark
, nmark
))
919 tem
= intern ("activate-mark-hook");
920 Frun_hooks (1, &tem
);
923 /* If mark has ceased to be active, run deactivate hook. */
924 else if (! NILP (tem1
))
926 tem
= intern ("deactivate-mark-hook");
927 Frun_hooks (1, &tem
);
930 /* If buffer was visible in a window, and a different window was
931 selected, and the old selected window is still showing this
932 buffer, restore point in that window. */
935 && !EQ (tem
, selected_window
)
936 && (tem1
= XWINDOW (tem
)->buffer
,
937 (/* Window is live... */
939 /* ...and it shows the current buffer. */
940 && XBUFFER (tem1
) == current_buffer
)))
941 Fset_window_point (tem
, make_number (PT
));
947 DEFUN ("save-excursion", Fsave_excursion
, Ssave_excursion
, 0, UNEVALLED
, 0,
948 doc
: /* Save point, mark, and current buffer; execute BODY; restore those things.
949 Executes BODY just like `progn'.
950 The values of point, mark and the current buffer are restored
951 even in case of abnormal exit (throw or error).
952 The state of activation of the mark is also restored.
954 This construct does not save `deactivate-mark', and therefore
955 functions that change the buffer will still cause deactivation
956 of the mark at the end of the command. To prevent that, bind
957 `deactivate-mark' with `let'.
959 If you only want to save the current buffer but not point nor mark,
960 then just use `save-current-buffer', or even `with-current-buffer'.
962 usage: (save-excursion &rest BODY) */)
965 register Lisp_Object val
;
966 int count
= SPECPDL_INDEX ();
968 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
971 return unbind_to (count
, val
);
974 DEFUN ("save-current-buffer", Fsave_current_buffer
, Ssave_current_buffer
, 0, UNEVALLED
, 0,
975 doc
: /* Save the current buffer; execute BODY; restore the current buffer.
976 Executes BODY just like `progn'.
977 usage: (save-current-buffer &rest BODY) */)
981 int count
= SPECPDL_INDEX ();
983 record_unwind_protect (set_buffer_if_live
, Fcurrent_buffer ());
986 return unbind_to (count
, val
);
989 DEFUN ("buffer-size", Fbufsize
, Sbufsize
, 0, 1, 0,
990 doc
: /* Return the number of characters in the current buffer.
991 If BUFFER, return the number of characters in that buffer instead. */)
995 return make_number (Z
- BEG
);
998 CHECK_BUFFER (buffer
);
999 return make_number (BUF_Z (XBUFFER (buffer
))
1000 - BUF_BEG (XBUFFER (buffer
)));
1004 DEFUN ("point-min", Fpoint_min
, Spoint_min
, 0, 0, 0,
1005 doc
: /* Return the minimum permissible value of point in the current buffer.
1006 This is 1, unless narrowing (a buffer restriction) is in effect. */)
1010 XSETFASTINT (temp
, BEGV
);
1014 DEFUN ("point-min-marker", Fpoint_min_marker
, Spoint_min_marker
, 0, 0, 0,
1015 doc
: /* Return a marker to the minimum permissible value of point in this buffer.
1016 This is the beginning, unless narrowing (a buffer restriction) is in effect. */)
1019 return buildmark (BEGV
, BEGV_BYTE
);
1022 DEFUN ("point-max", Fpoint_max
, Spoint_max
, 0, 0, 0,
1023 doc
: /* Return the maximum permissible value of point in the current buffer.
1024 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1025 is in effect, in which case it is less. */)
1029 XSETFASTINT (temp
, ZV
);
1033 DEFUN ("point-max-marker", Fpoint_max_marker
, Spoint_max_marker
, 0, 0, 0,
1034 doc
: /* Return a marker to the maximum permissible value of point in this buffer.
1035 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1036 is in effect, in which case it is less. */)
1039 return buildmark (ZV
, ZV_BYTE
);
1042 DEFUN ("gap-position", Fgap_position
, Sgap_position
, 0, 0, 0,
1043 doc
: /* Return the position of the gap, in the current buffer.
1044 See also `gap-size'. */)
1048 XSETFASTINT (temp
, GPT
);
1052 DEFUN ("gap-size", Fgap_size
, Sgap_size
, 0, 0, 0,
1053 doc
: /* Return the size of the current buffer's gap.
1054 See also `gap-position'. */)
1058 XSETFASTINT (temp
, GAP_SIZE
);
1062 DEFUN ("position-bytes", Fposition_bytes
, Sposition_bytes
, 1, 1, 0,
1063 doc
: /* Return the byte position for character position POSITION.
1064 If POSITION is out of range, the value is nil. */)
1065 (Lisp_Object position
)
1067 CHECK_NUMBER_COERCE_MARKER (position
);
1068 if (XINT (position
) < BEG
|| XINT (position
) > Z
)
1070 return make_number (CHAR_TO_BYTE (XINT (position
)));
1073 DEFUN ("byte-to-position", Fbyte_to_position
, Sbyte_to_position
, 1, 1, 0,
1074 doc
: /* Return the character position for byte position BYTEPOS.
1075 If BYTEPOS is out of range, the value is nil. */)
1076 (Lisp_Object bytepos
)
1078 CHECK_NUMBER (bytepos
);
1079 if (XINT (bytepos
) < BEG_BYTE
|| XINT (bytepos
) > Z_BYTE
)
1081 return make_number (BYTE_TO_CHAR (XINT (bytepos
)));
1084 DEFUN ("following-char", Ffollowing_char
, Sfollowing_char
, 0, 0, 0,
1085 doc
: /* Return the character following point, as a number.
1086 At the end of the buffer or accessible region, return 0. */)
1091 XSETFASTINT (temp
, 0);
1093 XSETFASTINT (temp
, FETCH_CHAR (PT_BYTE
));
1097 DEFUN ("preceding-char", Fprevious_char
, Sprevious_char
, 0, 0, 0,
1098 doc
: /* Return the character preceding point, as a number.
1099 At the beginning of the buffer or accessible region, return 0. */)
1104 XSETFASTINT (temp
, 0);
1105 else if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
1107 EMACS_INT pos
= PT_BYTE
;
1109 XSETFASTINT (temp
, FETCH_CHAR (pos
));
1112 XSETFASTINT (temp
, FETCH_BYTE (PT_BYTE
- 1));
1116 DEFUN ("bobp", Fbobp
, Sbobp
, 0, 0, 0,
1117 doc
: /* Return t if point is at the beginning of the buffer.
1118 If the buffer is narrowed, this means the beginning of the narrowed part. */)
1126 DEFUN ("eobp", Feobp
, Seobp
, 0, 0, 0,
1127 doc
: /* Return t if point is at the end of the buffer.
1128 If the buffer is narrowed, this means the end of the narrowed part. */)
1136 DEFUN ("bolp", Fbolp
, Sbolp
, 0, 0, 0,
1137 doc
: /* Return t if point is at the beginning of a line. */)
1140 if (PT
== BEGV
|| FETCH_BYTE (PT_BYTE
- 1) == '\n')
1145 DEFUN ("eolp", Feolp
, Seolp
, 0, 0, 0,
1146 doc
: /* Return t if point is at the end of a line.
1147 `End of a line' includes point being at the end of the buffer. */)
1150 if (PT
== ZV
|| FETCH_BYTE (PT_BYTE
) == '\n')
1155 DEFUN ("char-after", Fchar_after
, Schar_after
, 0, 1, 0,
1156 doc
: /* Return character in current buffer at position POS.
1157 POS is an integer or a marker and defaults to point.
1158 If POS is out of range, the value is nil. */)
1161 register EMACS_INT pos_byte
;
1166 XSETFASTINT (pos
, PT
);
1171 pos_byte
= marker_byte_position (pos
);
1172 if (pos_byte
< BEGV_BYTE
|| pos_byte
>= ZV_BYTE
)
1177 CHECK_NUMBER_COERCE_MARKER (pos
);
1178 if (XINT (pos
) < BEGV
|| XINT (pos
) >= ZV
)
1181 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1184 return make_number (FETCH_CHAR (pos_byte
));
1187 DEFUN ("char-before", Fchar_before
, Schar_before
, 0, 1, 0,
1188 doc
: /* Return character in current buffer preceding position POS.
1189 POS is an integer or a marker and defaults to point.
1190 If POS is out of range, the value is nil. */)
1193 register Lisp_Object val
;
1194 register EMACS_INT pos_byte
;
1199 XSETFASTINT (pos
, PT
);
1204 pos_byte
= marker_byte_position (pos
);
1206 if (pos_byte
<= BEGV_BYTE
|| pos_byte
> ZV_BYTE
)
1211 CHECK_NUMBER_COERCE_MARKER (pos
);
1213 if (XINT (pos
) <= BEGV
|| XINT (pos
) > ZV
)
1216 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1219 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
1222 XSETFASTINT (val
, FETCH_CHAR (pos_byte
));
1227 XSETFASTINT (val
, FETCH_BYTE (pos_byte
));
1232 DEFUN ("user-login-name", Fuser_login_name
, Suser_login_name
, 0, 1, 0,
1233 doc
: /* Return the name under which the user logged in, as a string.
1234 This is based on the effective uid, not the real uid.
1235 Also, if the environment variables LOGNAME or USER are set,
1236 that determines the value of this function.
1238 If optional argument UID is an integer or a float, return the login name
1239 of the user with that uid, or nil if there is no such user. */)
1245 /* Set up the user name info if we didn't do it before.
1246 (That can happen if Emacs is dumpable
1247 but you decide to run `temacs -l loadup' and not dump. */
1248 if (INTEGERP (Vuser_login_name
))
1252 return Vuser_login_name
;
1254 id
= XFLOATINT (uid
);
1258 return (pw
? build_string (pw
->pw_name
) : Qnil
);
1261 DEFUN ("user-real-login-name", Fuser_real_login_name
, Suser_real_login_name
,
1263 doc
: /* Return the name of the user's real uid, as a string.
1264 This ignores the environment variables LOGNAME and USER, so it differs from
1265 `user-login-name' when running under `su'. */)
1268 /* Set up the user name info if we didn't do it before.
1269 (That can happen if Emacs is dumpable
1270 but you decide to run `temacs -l loadup' and not dump. */
1271 if (INTEGERP (Vuser_login_name
))
1273 return Vuser_real_login_name
;
1276 DEFUN ("user-uid", Fuser_uid
, Suser_uid
, 0, 0, 0,
1277 doc
: /* Return the effective uid of Emacs.
1278 Value is an integer or a float, depending on the value. */)
1281 /* Assignment to EMACS_INT stops GCC whining about limited range of
1283 EMACS_INT euid
= geteuid ();
1285 /* Make sure we don't produce a negative UID due to signed integer
1288 return make_float (geteuid ());
1289 return make_fixnum_or_float (euid
);
1292 DEFUN ("user-real-uid", Fuser_real_uid
, Suser_real_uid
, 0, 0, 0,
1293 doc
: /* Return the real uid of Emacs.
1294 Value is an integer or a float, depending on the value. */)
1297 /* Assignment to EMACS_INT stops GCC whining about limited range of
1299 EMACS_INT uid
= getuid ();
1301 /* Make sure we don't produce a negative UID due to signed integer
1304 return make_float (getuid ());
1305 return make_fixnum_or_float (uid
);
1308 DEFUN ("user-full-name", Fuser_full_name
, Suser_full_name
, 0, 1, 0,
1309 doc
: /* Return the full name of the user logged in, as a string.
1310 If the full name corresponding to Emacs's userid is not known,
1313 If optional argument UID is an integer or float, return the full name
1314 of the user with that uid, or nil if there is no such user.
1315 If UID is a string, return the full name of the user with that login
1316 name, or nil if there is no such user. */)
1320 register char *p
, *q
;
1324 return Vuser_full_name
;
1325 else if (NUMBERP (uid
))
1327 uid_t u
= XFLOATINT (uid
);
1332 else if (STRINGP (uid
))
1335 pw
= getpwnam (SSDATA (uid
));
1339 error ("Invalid UID specification");
1345 /* Chop off everything after the first comma. */
1346 q
= strchr (p
, ',');
1347 full
= make_string (p
, q
? q
- p
: strlen (p
));
1349 #ifdef AMPERSAND_FULL_NAME
1351 q
= strchr (p
, '&');
1352 /* Substitute the login name for the &, upcasing the first character. */
1358 login
= Fuser_login_name (make_number (pw
->pw_uid
));
1359 r
= (char *) alloca (strlen (p
) + SCHARS (login
) + 1);
1360 memcpy (r
, p
, q
- p
);
1362 strcat (r
, SSDATA (login
));
1363 r
[q
- p
] = upcase ((unsigned char) r
[q
- p
]);
1365 full
= build_string (r
);
1367 #endif /* AMPERSAND_FULL_NAME */
1372 DEFUN ("system-name", Fsystem_name
, Ssystem_name
, 0, 0, 0,
1373 doc
: /* Return the host name of the machine you are running on, as a string. */)
1376 return Vsystem_name
;
1380 get_system_name (void)
1382 if (STRINGP (Vsystem_name
))
1383 return SSDATA (Vsystem_name
);
1388 DEFUN ("emacs-pid", Femacs_pid
, Semacs_pid
, 0, 0, 0,
1389 doc
: /* Return the process ID of Emacs, as an integer. */)
1392 return make_number (getpid ());
1398 # define TIME_T_MIN TYPE_MINIMUM (time_t)
1401 # define TIME_T_MAX TYPE_MAXIMUM (time_t)
1404 /* Report that a time value is out of range for Emacs. */
1406 time_overflow (void)
1408 error ("Specified time is not representable");
1411 /* Return the upper part of the time T (everything but the bottom 16 bits),
1412 making sure that it is representable. */
1416 time_t hi
= t
>> 16;
1418 /* Check for overflow, helping the compiler for common cases where
1419 no runtime check is needed, and taking care not to convert
1420 negative numbers to unsigned before comparing them. */
1421 if (! ((! TYPE_SIGNED (time_t)
1422 || MOST_NEGATIVE_FIXNUM
<= TIME_T_MIN
>> 16
1423 || MOST_NEGATIVE_FIXNUM
<= hi
)
1424 && (TIME_T_MAX
>> 16 <= MOST_POSITIVE_FIXNUM
1425 || hi
<= MOST_POSITIVE_FIXNUM
)))
1431 /* Return the bottom 16 bits of the time T. */
1435 return t
& ((1 << 16) - 1);
1438 DEFUN ("current-time", Fcurrent_time
, Scurrent_time
, 0, 0, 0,
1439 doc
: /* Return the current time, as the number of seconds since 1970-01-01 00:00:00.
1440 The time is returned as a list of three integers. The first has the
1441 most significant 16 bits of the seconds, while the second has the
1442 least significant 16 bits. The third integer gives the microsecond
1445 The microsecond count is zero on systems that do not provide
1446 resolution finer than a second. */)
1452 return list3 (make_number (hi_time (EMACS_SECS (t
))),
1453 make_number (lo_time (EMACS_SECS (t
))),
1454 make_number (EMACS_USECS (t
)));
1457 DEFUN ("get-internal-run-time", Fget_internal_run_time
, Sget_internal_run_time
,
1459 doc
: /* Return the current run time used by Emacs.
1460 The time is returned as a list of three integers. The first has the
1461 most significant 16 bits of the seconds, while the second has the
1462 least significant 16 bits. The third integer gives the microsecond
1465 On systems that can't determine the run time, `get-internal-run-time'
1466 does the same thing as `current-time'. The microsecond count is zero
1467 on systems that do not provide resolution finer than a second. */)
1470 #ifdef HAVE_GETRUSAGE
1471 struct rusage usage
;
1475 if (getrusage (RUSAGE_SELF
, &usage
) < 0)
1476 /* This shouldn't happen. What action is appropriate? */
1479 /* Sum up user time and system time. */
1480 secs
= usage
.ru_utime
.tv_sec
+ usage
.ru_stime
.tv_sec
;
1481 usecs
= usage
.ru_utime
.tv_usec
+ usage
.ru_stime
.tv_usec
;
1482 if (usecs
>= 1000000)
1488 return list3 (make_number (hi_time (secs
)),
1489 make_number (lo_time (secs
)),
1490 make_number (usecs
));
1491 #else /* ! HAVE_GETRUSAGE */
1493 return w32_get_internal_run_time ();
1494 #else /* ! WINDOWSNT */
1495 return Fcurrent_time ();
1496 #endif /* WINDOWSNT */
1497 #endif /* HAVE_GETRUSAGE */
1501 /* Make a Lisp list that represents the time T. */
1503 make_time (time_t t
)
1505 return list2 (make_number (hi_time (t
)),
1506 make_number (lo_time (t
)));
1509 /* Decode a Lisp list SPECIFIED_TIME that represents a time.
1510 If SPECIFIED_TIME is nil, use the current time.
1511 Set *RESULT to seconds since the Epoch.
1512 If USEC is not null, set *USEC to the microseconds component.
1513 Return nonzero if successful. */
1515 lisp_time_argument (Lisp_Object specified_time
, time_t *result
, int *usec
)
1517 if (NILP (specified_time
))
1524 *usec
= EMACS_USECS (t
);
1525 *result
= EMACS_SECS (t
);
1529 return time (result
) != -1;
1533 Lisp_Object high
, low
;
1535 high
= Fcar (specified_time
);
1536 CHECK_NUMBER (high
);
1537 low
= Fcdr (specified_time
);
1542 Lisp_Object usec_l
= Fcdr (low
);
1544 usec_l
= Fcar (usec_l
);
1549 CHECK_NUMBER (usec_l
);
1550 *usec
= XINT (usec_l
);
1560 /* Check for overflow, helping the compiler for common cases
1561 where no runtime check is needed, and taking care not to
1562 convert negative numbers to unsigned before comparing them. */
1563 if (! ((TYPE_SIGNED (time_t)
1564 ? (TIME_T_MIN
>> 16 <= MOST_NEGATIVE_FIXNUM
1565 || TIME_T_MIN
>> 16 <= hi
)
1567 && (MOST_POSITIVE_FIXNUM
<= TIME_T_MAX
>> 16
1568 || hi
<= TIME_T_MAX
>> 16)))
1571 *result
= (hi
<< 16) + (XINT (low
) & 0xffff);
1576 DEFUN ("float-time", Ffloat_time
, Sfloat_time
, 0, 1, 0,
1577 doc
: /* Return the current time, as a float number of seconds since the epoch.
1578 If SPECIFIED-TIME is given, it is the time to convert to float
1579 instead of the current time. The argument should have the form
1580 (HIGH LOW) or (HIGH LOW USEC). Thus, you can use times obtained from
1581 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
1582 have the form (HIGH . LOW), but this is considered obsolete.
1584 WARNING: Since the result is floating point, it may not be exact.
1585 If precise time stamps are required, use either `current-time',
1586 or (if you need time as a string) `format-time-string'. */)
1587 (Lisp_Object specified_time
)
1592 if (! lisp_time_argument (specified_time
, &sec
, &usec
))
1593 error ("Invalid time specification");
1595 return make_float ((sec
* 1e6
+ usec
) / 1e6
);
1598 /* Write information into buffer S of size MAXSIZE, according to the
1599 FORMAT of length FORMAT_LEN, using time information taken from *TP.
1600 Default to Universal Time if UT is nonzero, local time otherwise.
1601 Use NS as the number of nanoseconds in the %N directive.
1602 Return the number of bytes written, not including the terminating
1603 '\0'. If S is NULL, nothing will be written anywhere; so to
1604 determine how many bytes would be written, use NULL for S and
1605 ((size_t) -1) for MAXSIZE.
1607 This function behaves like nstrftime, except it allows null
1608 bytes in FORMAT and it does not support nanoseconds. */
1610 emacs_nmemftime (char *s
, size_t maxsize
, const char *format
,
1611 size_t format_len
, const struct tm
*tp
, int ut
, int ns
)
1615 /* Loop through all the null-terminated strings in the format
1616 argument. Normally there's just one null-terminated string, but
1617 there can be arbitrarily many, concatenated together, if the
1618 format contains '\0' bytes. nstrftime stops at the first
1619 '\0' byte so we must invoke it separately for each such string. */
1628 result
= nstrftime (s
, maxsize
, format
, tp
, ut
, ns
);
1632 if (result
== 0 && s
[0] != '\0')
1637 maxsize
-= result
+ 1;
1639 len
= strlen (format
);
1640 if (len
== format_len
)
1644 format_len
-= len
+ 1;
1648 DEFUN ("format-time-string", Fformat_time_string
, Sformat_time_string
, 1, 3, 0,
1649 doc
: /* Use FORMAT-STRING to format the time TIME, or now if omitted.
1650 TIME is specified as (HIGH LOW . IGNORED), as returned by
1651 `current-time' or `file-attributes'. The obsolete form (HIGH . LOW)
1652 is also still accepted.
1653 The third, optional, argument UNIVERSAL, if non-nil, means describe TIME
1654 as Universal Time; nil means describe TIME in the local time zone.
1655 The value is a copy of FORMAT-STRING, but with certain constructs replaced
1656 by text that describes the specified date and time in TIME:
1658 %Y is the year, %y within the century, %C the century.
1659 %G is the year corresponding to the ISO week, %g within the century.
1660 %m is the numeric month.
1661 %b and %h are the locale's abbreviated month name, %B the full name.
1662 %d is the day of the month, zero-padded, %e is blank-padded.
1663 %u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.
1664 %a is the locale's abbreviated name of the day of week, %A the full name.
1665 %U is the week number starting on Sunday, %W starting on Monday,
1666 %V according to ISO 8601.
1667 %j is the day of the year.
1669 %H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H
1670 only blank-padded, %l is like %I blank-padded.
1671 %p is the locale's equivalent of either AM or PM.
1674 %N is the nanosecond, %6N the microsecond, %3N the millisecond, etc.
1675 %Z is the time zone name, %z is the numeric form.
1676 %s is the number of seconds since 1970-01-01 00:00:00 +0000.
1678 %c is the locale's date and time format.
1679 %x is the locale's "preferred" date format.
1680 %D is like "%m/%d/%y".
1682 %R is like "%H:%M", %T is like "%H:%M:%S", %r is like "%I:%M:%S %p".
1683 %X is the locale's "preferred" time format.
1685 Finally, %n is a newline, %t is a tab, %% is a literal %.
1687 Certain flags and modifiers are available with some format controls.
1688 The flags are `_', `-', `^' and `#'. For certain characters X,
1689 %_X is like %X, but padded with blanks; %-X is like %X,
1690 but without padding. %^X is like %X, but with all textual
1691 characters up-cased; %#X is like %X, but with letter-case of
1692 all textual characters reversed.
1693 %NX (where N stands for an integer) is like %X,
1694 but takes up at least N (a number) positions.
1695 The modifiers are `E' and `O'. For certain characters X,
1696 %EX is a locale's alternative version of %X;
1697 %OX is like %X, but uses the locale's number symbols.
1699 For example, to produce full ISO 8601 format, use "%Y-%m-%dT%T%z". */)
1700 (Lisp_Object format_string
, Lisp_Object timeval
, Lisp_Object universal
)
1707 int ut
= ! NILP (universal
);
1709 CHECK_STRING (format_string
);
1711 if (! (lisp_time_argument (timeval
, &value
, &usec
)
1712 && 0 <= usec
&& usec
< 1000000))
1713 error ("Invalid time specification");
1716 format_string
= code_convert_string_norecord (format_string
,
1717 Vlocale_coding_system
, 1);
1719 /* This is probably enough. */
1720 size
= SBYTES (format_string
);
1721 if (size
<= (STRING_BYTES_BOUND
- 50) / 6)
1722 size
= size
* 6 + 50;
1725 tm
= ut
? gmtime (&value
) : localtime (&value
);
1730 synchronize_system_time_locale ();
1734 char *buf
= (char *) alloca (size
+ 1);
1739 result
= emacs_nmemftime (buf
, size
, SSDATA (format_string
),
1740 SBYTES (format_string
),
1743 if ((result
> 0 && result
< size
) || (result
== 0 && buf
[0] == '\0'))
1744 return code_convert_string_norecord (make_unibyte_string (buf
, result
),
1745 Vlocale_coding_system
, 0);
1747 /* If buffer was too small, make it bigger and try again. */
1749 result
= emacs_nmemftime (NULL
, (size_t) -1,
1750 SSDATA (format_string
),
1751 SBYTES (format_string
),
1754 if (STRING_BYTES_BOUND
<= result
)
1760 DEFUN ("decode-time", Fdecode_time
, Sdecode_time
, 0, 1, 0,
1761 doc
: /* Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST ZONE).
1762 The optional SPECIFIED-TIME should be a list of (HIGH LOW . IGNORED),
1763 as from `current-time' and `file-attributes', or nil to use the
1764 current time. The obsolete form (HIGH . LOW) is also still accepted.
1765 The list has the following nine members: SEC is an integer between 0
1766 and 60; SEC is 60 for a leap second, which only some operating systems
1767 support. MINUTE is an integer between 0 and 59. HOUR is an integer
1768 between 0 and 23. DAY is an integer between 1 and 31. MONTH is an
1769 integer between 1 and 12. YEAR is an integer indicating the
1770 four-digit year. DOW is the day of week, an integer between 0 and 6,
1771 where 0 is Sunday. DST is t if daylight saving time is in effect,
1772 otherwise nil. ZONE is an integer indicating the number of seconds
1773 east of Greenwich. (Note that Common Lisp has different meanings for
1775 (Lisp_Object specified_time
)
1779 struct tm
*decoded_time
;
1780 Lisp_Object list_args
[9];
1782 if (! lisp_time_argument (specified_time
, &time_spec
, NULL
))
1783 error ("Invalid time specification");
1786 decoded_time
= localtime (&time_spec
);
1789 && MOST_NEGATIVE_FIXNUM
- TM_YEAR_BASE
<= decoded_time
->tm_year
1790 && decoded_time
->tm_year
<= MOST_POSITIVE_FIXNUM
- TM_YEAR_BASE
))
1792 XSETFASTINT (list_args
[0], decoded_time
->tm_sec
);
1793 XSETFASTINT (list_args
[1], decoded_time
->tm_min
);
1794 XSETFASTINT (list_args
[2], decoded_time
->tm_hour
);
1795 XSETFASTINT (list_args
[3], decoded_time
->tm_mday
);
1796 XSETFASTINT (list_args
[4], decoded_time
->tm_mon
+ 1);
1797 /* On 64-bit machines an int is narrower than EMACS_INT, thus the
1798 cast below avoids overflow in int arithmetics. */
1799 XSETINT (list_args
[5], TM_YEAR_BASE
+ (EMACS_INT
) decoded_time
->tm_year
);
1800 XSETFASTINT (list_args
[6], decoded_time
->tm_wday
);
1801 list_args
[7] = (decoded_time
->tm_isdst
)? Qt
: Qnil
;
1803 /* Make a copy, in case gmtime modifies the struct. */
1804 save_tm
= *decoded_time
;
1806 decoded_time
= gmtime (&time_spec
);
1808 if (decoded_time
== 0)
1809 list_args
[8] = Qnil
;
1811 XSETINT (list_args
[8], tm_diff (&save_tm
, decoded_time
));
1812 return Flist (9, list_args
);
1815 /* Return OBJ - OFFSET, checking that OBJ is a valid fixnum and that
1816 the result is representable as an int. Assume OFFSET is small and
1819 check_tm_member (Lisp_Object obj
, int offset
)
1824 if (! (INT_MIN
+ offset
<= n
&& n
- offset
<= INT_MAX
))
1829 DEFUN ("encode-time", Fencode_time
, Sencode_time
, 6, MANY
, 0,
1830 doc
: /* Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.
1831 This is the reverse operation of `decode-time', which see.
1832 ZONE defaults to the current time zone rule. This can
1833 be a string or t (as from `set-time-zone-rule'), or it can be a list
1834 \(as from `current-time-zone') or an integer (as from `decode-time')
1835 applied without consideration for daylight saving time.
1837 You can pass more than 7 arguments; then the first six arguments
1838 are used as SECOND through YEAR, and the *last* argument is used as ZONE.
1839 The intervening arguments are ignored.
1840 This feature lets (apply 'encode-time (decode-time ...)) work.
1842 Out-of-range values for SECOND, MINUTE, HOUR, DAY, or MONTH are allowed;
1843 for example, a DAY of 0 means the day preceding the given month.
1844 Year numbers less than 100 are treated just like other year numbers.
1845 If you want them to stand for years in this century, you must do that yourself.
1847 Years before 1970 are not guaranteed to work. On some systems,
1848 year values as low as 1901 do work.
1850 usage: (encode-time SECOND MINUTE HOUR DAY MONTH YEAR &optional ZONE) */)
1851 (ptrdiff_t nargs
, Lisp_Object
*args
)
1855 Lisp_Object zone
= (nargs
> 6 ? args
[nargs
- 1] : Qnil
);
1857 tm
.tm_sec
= check_tm_member (args
[0], 0);
1858 tm
.tm_min
= check_tm_member (args
[1], 0);
1859 tm
.tm_hour
= check_tm_member (args
[2], 0);
1860 tm
.tm_mday
= check_tm_member (args
[3], 0);
1861 tm
.tm_mon
= check_tm_member (args
[4], 1);
1862 tm
.tm_year
= check_tm_member (args
[5], TM_YEAR_BASE
);
1870 value
= mktime (&tm
);
1876 const char *tzstring
;
1877 char **oldenv
= environ
, **newenv
;
1881 else if (STRINGP (zone
))
1882 tzstring
= SSDATA (zone
);
1883 else if (INTEGERP (zone
))
1885 int abszone
= eabs (XINT (zone
));
1886 sprintf (tzbuf
, "XXX%s%d:%02d:%02d", "-" + (XINT (zone
) < 0),
1887 abszone
/ (60*60), (abszone
/60) % 60, abszone
% 60);
1891 error ("Invalid time zone specification");
1893 /* Set TZ before calling mktime; merely adjusting mktime's returned
1894 value doesn't suffice, since that would mishandle leap seconds. */
1895 set_time_zone_rule (tzstring
);
1898 value
= mktime (&tm
);
1901 /* Restore TZ to previous value. */
1905 #ifdef LOCALTIME_CACHE
1910 if (value
== (time_t) -1)
1913 return make_time (value
);
1916 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
, 0, 1, 0,
1917 doc
: /* Return the current local time, as a human-readable string.
1918 Programs can use this function to decode a time,
1919 since the number of columns in each field is fixed
1920 if the year is in the range 1000-9999.
1921 The format is `Sun Sep 16 01:03:52 1973'.
1922 However, see also the functions `decode-time' and `format-time-string'
1923 which provide a much more powerful and general facility.
1925 If SPECIFIED-TIME is given, it is a time to format instead of the
1926 current time. The argument should have the form (HIGH LOW . IGNORED).
1927 Thus, you can use times obtained from `current-time' and from
1928 `file-attributes'. SPECIFIED-TIME can also have the form (HIGH . LOW),
1929 but this is considered obsolete. */)
1930 (Lisp_Object specified_time
)
1936 if (! lisp_time_argument (specified_time
, &value
, NULL
))
1937 error ("Invalid time specification");
1939 /* Convert to a string, checking for out-of-range time stamps.
1940 Don't use 'ctime', as that might dump core if VALUE is out of
1943 tm
= localtime (&value
);
1945 if (! (tm
&& TM_YEAR_IN_ASCTIME_RANGE (tm
->tm_year
) && (tem
= asctime (tm
))))
1948 /* Remove the trailing newline. */
1949 tem
[strlen (tem
) - 1] = '\0';
1951 return build_string (tem
);
1954 /* Yield A - B, measured in seconds.
1955 This function is copied from the GNU C Library. */
1957 tm_diff (struct tm
*a
, struct tm
*b
)
1959 /* Compute intervening leap days correctly even if year is negative.
1960 Take care to avoid int overflow in leap day calculations,
1961 but it's OK to assume that A and B are close to each other. */
1962 int a4
= (a
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (a
->tm_year
& 3);
1963 int b4
= (b
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (b
->tm_year
& 3);
1964 int a100
= a4
/ 25 - (a4
% 25 < 0);
1965 int b100
= b4
/ 25 - (b4
% 25 < 0);
1966 int a400
= a100
>> 2;
1967 int b400
= b100
>> 2;
1968 int intervening_leap_days
= (a4
- b4
) - (a100
- b100
) + (a400
- b400
);
1969 int years
= a
->tm_year
- b
->tm_year
;
1970 int days
= (365 * years
+ intervening_leap_days
1971 + (a
->tm_yday
- b
->tm_yday
));
1972 return (60 * (60 * (24 * days
+ (a
->tm_hour
- b
->tm_hour
))
1973 + (a
->tm_min
- b
->tm_min
))
1974 + (a
->tm_sec
- b
->tm_sec
));
1977 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 1, 0,
1978 doc
: /* Return the offset and name for the local time zone.
1979 This returns a list of the form (OFFSET NAME).
1980 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).
1981 A negative value means west of Greenwich.
1982 NAME is a string giving the name of the time zone.
1983 If SPECIFIED-TIME is given, the time zone offset is determined from it
1984 instead of using the current time. The argument should have the form
1985 (HIGH LOW . IGNORED). Thus, you can use times obtained from
1986 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
1987 have the form (HIGH . LOW), but this is considered obsolete.
1989 Some operating systems cannot provide all this information to Emacs;
1990 in this case, `current-time-zone' returns a list containing nil for
1991 the data it can't find. */)
1992 (Lisp_Object specified_time
)
1998 if (!lisp_time_argument (specified_time
, &value
, NULL
))
2003 t
= gmtime (&value
);
2007 t
= localtime (&value
);
2014 int offset
= tm_diff (t
, &gmt
);
2020 s
= (char *)t
->tm_zone
;
2021 #else /* not HAVE_TM_ZONE */
2023 if (t
->tm_isdst
== 0 || t
->tm_isdst
== 1)
2024 s
= tzname
[t
->tm_isdst
];
2026 #endif /* not HAVE_TM_ZONE */
2030 /* No local time zone name is available; use "+-NNNN" instead. */
2031 int am
= (offset
< 0 ? -offset
: offset
) / 60;
2032 sprintf (buf
, "%c%02d%02d", (offset
< 0 ? '-' : '+'), am
/60, am
%60);
2036 return Fcons (make_number (offset
), Fcons (build_string (s
), Qnil
));
2039 return Fmake_list (make_number (2), Qnil
);
2042 /* This holds the value of `environ' produced by the previous
2043 call to Fset_time_zone_rule, or 0 if Fset_time_zone_rule
2044 has never been called. */
2045 static char **environbuf
;
2047 /* This holds the startup value of the TZ environment variable so it
2048 can be restored if the user calls set-time-zone-rule with a nil
2050 static char *initial_tz
;
2052 DEFUN ("set-time-zone-rule", Fset_time_zone_rule
, Sset_time_zone_rule
, 1, 1, 0,
2053 doc
: /* Set the local time zone using TZ, a string specifying a time zone rule.
2054 If TZ is nil, use implementation-defined default time zone information.
2055 If TZ is t, use Universal Time. */)
2058 const char *tzstring
;
2060 /* When called for the first time, save the original TZ. */
2062 initial_tz
= (char *) getenv ("TZ");
2065 tzstring
= initial_tz
;
2066 else if (EQ (tz
, Qt
))
2071 tzstring
= SSDATA (tz
);
2074 set_time_zone_rule (tzstring
);
2076 environbuf
= environ
;
2081 #ifdef LOCALTIME_CACHE
2083 /* These two values are known to load tz files in buggy implementations,
2084 i.e. Solaris 1 executables running under either Solaris 1 or Solaris 2.
2085 Their values shouldn't matter in non-buggy implementations.
2086 We don't use string literals for these strings,
2087 since if a string in the environment is in readonly
2088 storage, it runs afoul of bugs in SVR4 and Solaris 2.3.
2089 See Sun bugs 1113095 and 1114114, ``Timezone routines
2090 improperly modify environment''. */
2092 static char set_time_zone_rule_tz1
[] = "TZ=GMT+0";
2093 static char set_time_zone_rule_tz2
[] = "TZ=GMT+1";
2097 /* Set the local time zone rule to TZSTRING.
2098 This allocates memory into `environ', which it is the caller's
2099 responsibility to free. */
2102 set_time_zone_rule (const char *tzstring
)
2105 char **from
, **to
, **newenv
;
2107 /* Make the ENVIRON vector longer with room for TZSTRING. */
2108 for (from
= environ
; *from
; from
++)
2110 envptrs
= from
- environ
+ 2;
2111 newenv
= to
= (char **) xmalloc (envptrs
* sizeof (char *)
2112 + (tzstring
? strlen (tzstring
) + 4 : 0));
2114 /* Add TZSTRING to the end of environ, as a value for TZ. */
2117 char *t
= (char *) (to
+ envptrs
);
2119 strcat (t
, tzstring
);
2123 /* Copy the old environ vector elements into NEWENV,
2124 but don't copy the TZ variable.
2125 So we have only one definition of TZ, which came from TZSTRING. */
2126 for (from
= environ
; *from
; from
++)
2127 if (strncmp (*from
, "TZ=", 3) != 0)
2133 /* If we do have a TZSTRING, NEWENV points to the vector slot where
2134 the TZ variable is stored. If we do not have a TZSTRING,
2135 TO points to the vector slot which has the terminating null. */
2137 #ifdef LOCALTIME_CACHE
2139 /* In SunOS 4.1.3_U1 and 4.1.4, if TZ has a value like
2140 "US/Pacific" that loads a tz file, then changes to a value like
2141 "XXX0" that does not load a tz file, and then changes back to
2142 its original value, the last change is (incorrectly) ignored.
2143 Also, if TZ changes twice in succession to values that do
2144 not load a tz file, tzset can dump core (see Sun bug#1225179).
2145 The following code works around these bugs. */
2149 /* Temporarily set TZ to a value that loads a tz file
2150 and that differs from tzstring. */
2152 *newenv
= (strcmp (tzstring
, set_time_zone_rule_tz1
+ 3) == 0
2153 ? set_time_zone_rule_tz2
: set_time_zone_rule_tz1
);
2159 /* The implied tzstring is unknown, so temporarily set TZ to
2160 two different values that each load a tz file. */
2161 *to
= set_time_zone_rule_tz1
;
2164 *to
= set_time_zone_rule_tz2
;
2169 /* Now TZ has the desired value, and tzset can be invoked safely. */
2176 /* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC
2177 (if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a
2178 type of object is Lisp_String). INHERIT is passed to
2179 INSERT_FROM_STRING_FUNC as the last argument. */
2182 general_insert_function (void (*insert_func
)
2183 (const char *, EMACS_INT
),
2184 void (*insert_from_string_func
)
2185 (Lisp_Object
, EMACS_INT
, EMACS_INT
,
2186 EMACS_INT
, EMACS_INT
, int),
2187 int inherit
, ptrdiff_t nargs
, Lisp_Object
*args
)
2190 register Lisp_Object val
;
2192 for (argnum
= 0; argnum
< nargs
; argnum
++)
2195 if (CHARACTERP (val
))
2197 int c
= XFASTINT (val
);
2198 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2201 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2202 len
= CHAR_STRING (c
, str
);
2205 str
[0] = ASCII_CHAR_P (c
) ? c
: multibyte_char_to_unibyte (c
);
2208 (*insert_func
) ((char *) str
, len
);
2210 else if (STRINGP (val
))
2212 (*insert_from_string_func
) (val
, 0, 0,
2218 wrong_type_argument (Qchar_or_string_p
, val
);
2223 insert1 (Lisp_Object arg
)
2229 /* Callers passing one argument to Finsert need not gcpro the
2230 argument "array", since the only element of the array will
2231 not be used after calling insert or insert_from_string, so
2232 we don't care if it gets trashed. */
2234 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
2235 doc
: /* Insert the arguments, either strings or characters, at point.
2236 Point and before-insertion markers move forward to end up
2237 after the inserted text.
2238 Any other markers at the point of insertion remain before the text.
2240 If the current buffer is multibyte, unibyte strings are converted
2241 to multibyte for insertion (see `string-make-multibyte').
2242 If the current buffer is unibyte, multibyte strings are converted
2243 to unibyte for insertion (see `string-make-unibyte').
2245 When operating on binary data, it may be necessary to preserve the
2246 original bytes of a unibyte string when inserting it into a multibyte
2247 buffer; to accomplish this, apply `string-as-multibyte' to the string
2248 and insert the result.
2250 usage: (insert &rest ARGS) */)
2251 (ptrdiff_t nargs
, Lisp_Object
*args
)
2253 general_insert_function (insert
, insert_from_string
, 0, nargs
, args
);
2257 DEFUN ("insert-and-inherit", Finsert_and_inherit
, Sinsert_and_inherit
,
2259 doc
: /* Insert the arguments at point, inheriting properties from adjoining text.
2260 Point and before-insertion markers move forward to end up
2261 after the inserted text.
2262 Any other markers at the point of insertion remain before the text.
2264 If the current buffer is multibyte, unibyte strings are converted
2265 to multibyte for insertion (see `unibyte-char-to-multibyte').
2266 If the current buffer is unibyte, multibyte strings are converted
2267 to unibyte for insertion.
2269 usage: (insert-and-inherit &rest ARGS) */)
2270 (ptrdiff_t nargs
, Lisp_Object
*args
)
2272 general_insert_function (insert_and_inherit
, insert_from_string
, 1,
2277 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
2278 doc
: /* Insert strings or characters at point, relocating markers after the text.
2279 Point and markers move forward to end up after the inserted text.
2281 If the current buffer is multibyte, unibyte strings are converted
2282 to multibyte for insertion (see `unibyte-char-to-multibyte').
2283 If the current buffer is unibyte, multibyte strings are converted
2284 to unibyte for insertion.
2286 usage: (insert-before-markers &rest ARGS) */)
2287 (ptrdiff_t nargs
, Lisp_Object
*args
)
2289 general_insert_function (insert_before_markers
,
2290 insert_from_string_before_markers
, 0,
2295 DEFUN ("insert-before-markers-and-inherit", Finsert_and_inherit_before_markers
,
2296 Sinsert_and_inherit_before_markers
, 0, MANY
, 0,
2297 doc
: /* Insert text at point, relocating markers and inheriting properties.
2298 Point and markers move forward to end up after the inserted text.
2300 If the current buffer is multibyte, unibyte strings are converted
2301 to multibyte for insertion (see `unibyte-char-to-multibyte').
2302 If the current buffer is unibyte, multibyte strings are converted
2303 to unibyte for insertion.
2305 usage: (insert-before-markers-and-inherit &rest ARGS) */)
2306 (ptrdiff_t nargs
, Lisp_Object
*args
)
2308 general_insert_function (insert_before_markers_and_inherit
,
2309 insert_from_string_before_markers
, 1,
2314 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 2, 3, 0,
2315 doc
: /* Insert COUNT copies of CHARACTER.
2316 Point, and before-insertion markers, are relocated as in the function `insert'.
2317 The optional third arg INHERIT, if non-nil, says to inherit text properties
2318 from adjoining text, if those properties are sticky. */)
2319 (Lisp_Object character
, Lisp_Object count
, Lisp_Object inherit
)
2322 register EMACS_INT n
;
2324 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2327 CHECK_CHARACTER (character
);
2328 CHECK_NUMBER (count
);
2329 c
= XFASTINT (character
);
2331 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2332 len
= CHAR_STRING (c
, str
);
2334 str
[0] = c
, len
= 1;
2335 if (XINT (count
) <= 0)
2337 if (BUF_BYTES_MAX
/ len
< XINT (count
))
2339 n
= XINT (count
) * len
;
2340 stringlen
= min (n
, sizeof string
- sizeof string
% len
);
2341 for (i
= 0; i
< stringlen
; i
++)
2342 string
[i
] = str
[i
% len
];
2343 while (n
> stringlen
)
2346 if (!NILP (inherit
))
2347 insert_and_inherit (string
, stringlen
);
2349 insert (string
, stringlen
);
2352 if (!NILP (inherit
))
2353 insert_and_inherit (string
, n
);
2359 DEFUN ("insert-byte", Finsert_byte
, Sinsert_byte
, 2, 3, 0,
2360 doc
: /* Insert COUNT (second arg) copies of BYTE (first arg).
2361 Both arguments are required.
2362 BYTE is a number of the range 0..255.
2364 If BYTE is 128..255 and the current buffer is multibyte, the
2365 corresponding eight-bit character is inserted.
2367 Point, and before-insertion markers, are relocated as in the function `insert'.
2368 The optional third arg INHERIT, if non-nil, says to inherit text properties
2369 from adjoining text, if those properties are sticky. */)
2370 (Lisp_Object byte
, Lisp_Object count
, Lisp_Object inherit
)
2372 CHECK_NUMBER (byte
);
2373 if (XINT (byte
) < 0 || XINT (byte
) > 255)
2374 args_out_of_range_3 (byte
, make_number (0), make_number (255));
2375 if (XINT (byte
) >= 128
2376 && ! NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2377 XSETFASTINT (byte
, BYTE8_TO_CHAR (XINT (byte
)));
2378 return Finsert_char (byte
, count
, inherit
);
2382 /* Making strings from buffer contents. */
2384 /* Return a Lisp_String containing the text of the current buffer from
2385 START to END. If text properties are in use and the current buffer
2386 has properties in the range specified, the resulting string will also
2387 have them, if PROPS is nonzero.
2389 We don't want to use plain old make_string here, because it calls
2390 make_uninit_string, which can cause the buffer arena to be
2391 compacted. make_string has no way of knowing that the data has
2392 been moved, and thus copies the wrong data into the string. This
2393 doesn't effect most of the other users of make_string, so it should
2394 be left as is. But we should use this function when conjuring
2395 buffer substrings. */
2398 make_buffer_string (EMACS_INT start
, EMACS_INT end
, int props
)
2400 EMACS_INT start_byte
= CHAR_TO_BYTE (start
);
2401 EMACS_INT end_byte
= CHAR_TO_BYTE (end
);
2403 return make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
);
2406 /* Return a Lisp_String containing the text of the current buffer from
2407 START / START_BYTE to END / END_BYTE.
2409 If text properties are in use and the current buffer
2410 has properties in the range specified, the resulting string will also
2411 have them, if PROPS is nonzero.
2413 We don't want to use plain old make_string here, because it calls
2414 make_uninit_string, which can cause the buffer arena to be
2415 compacted. make_string has no way of knowing that the data has
2416 been moved, and thus copies the wrong data into the string. This
2417 doesn't effect most of the other users of make_string, so it should
2418 be left as is. But we should use this function when conjuring
2419 buffer substrings. */
2422 make_buffer_string_both (EMACS_INT start
, EMACS_INT start_byte
,
2423 EMACS_INT end
, EMACS_INT end_byte
, int props
)
2425 Lisp_Object result
, tem
, tem1
;
2427 if (start
< GPT
&& GPT
< end
)
2430 if (! NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2431 result
= make_uninit_multibyte_string (end
- start
, end_byte
- start_byte
);
2433 result
= make_uninit_string (end
- start
);
2434 memcpy (SDATA (result
), BYTE_POS_ADDR (start_byte
), end_byte
- start_byte
);
2436 /* If desired, update and copy the text properties. */
2439 update_buffer_properties (start
, end
);
2441 tem
= Fnext_property_change (make_number (start
), Qnil
, make_number (end
));
2442 tem1
= Ftext_properties_at (make_number (start
), Qnil
);
2444 if (XINT (tem
) != end
|| !NILP (tem1
))
2445 copy_intervals_to_string (result
, current_buffer
, start
,
2452 /* Call Vbuffer_access_fontify_functions for the range START ... END
2453 in the current buffer, if necessary. */
2456 update_buffer_properties (EMACS_INT start
, EMACS_INT end
)
2458 /* If this buffer has some access functions,
2459 call them, specifying the range of the buffer being accessed. */
2460 if (!NILP (Vbuffer_access_fontify_functions
))
2462 Lisp_Object args
[3];
2465 args
[0] = Qbuffer_access_fontify_functions
;
2466 XSETINT (args
[1], start
);
2467 XSETINT (args
[2], end
);
2469 /* But don't call them if we can tell that the work
2470 has already been done. */
2471 if (!NILP (Vbuffer_access_fontified_property
))
2473 tem
= Ftext_property_any (args
[1], args
[2],
2474 Vbuffer_access_fontified_property
,
2477 Frun_hook_with_args (3, args
);
2480 Frun_hook_with_args (3, args
);
2484 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
2485 doc
: /* Return the contents of part of the current buffer as a string.
2486 The two arguments START and END are character positions;
2487 they can be in either order.
2488 The string returned is multibyte if the buffer is multibyte.
2490 This function copies the text properties of that part of the buffer
2491 into the result string; if you don't want the text properties,
2492 use `buffer-substring-no-properties' instead. */)
2493 (Lisp_Object start
, Lisp_Object end
)
2495 register EMACS_INT b
, e
;
2497 validate_region (&start
, &end
);
2501 return make_buffer_string (b
, e
, 1);
2504 DEFUN ("buffer-substring-no-properties", Fbuffer_substring_no_properties
,
2505 Sbuffer_substring_no_properties
, 2, 2, 0,
2506 doc
: /* Return the characters of part of the buffer, without the text properties.
2507 The two arguments START and END are character positions;
2508 they can be in either order. */)
2509 (Lisp_Object start
, Lisp_Object end
)
2511 register EMACS_INT b
, e
;
2513 validate_region (&start
, &end
);
2517 return make_buffer_string (b
, e
, 0);
2520 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
2521 doc
: /* Return the contents of the current buffer as a string.
2522 If narrowing is in effect, this function returns only the visible part
2526 return make_buffer_string (BEGV
, ZV
, 1);
2529 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
2531 doc
: /* Insert before point a substring of the contents of BUFFER.
2532 BUFFER may be a buffer or a buffer name.
2533 Arguments START and END are character positions specifying the substring.
2534 They default to the values of (point-min) and (point-max) in BUFFER. */)
2535 (Lisp_Object buffer
, Lisp_Object start
, Lisp_Object end
)
2537 register EMACS_INT b
, e
, temp
;
2538 register struct buffer
*bp
, *obuf
;
2541 buf
= Fget_buffer (buffer
);
2545 if (NILP (BVAR (bp
, name
)))
2546 error ("Selecting deleted buffer");
2552 CHECK_NUMBER_COERCE_MARKER (start
);
2559 CHECK_NUMBER_COERCE_MARKER (end
);
2564 temp
= b
, b
= e
, e
= temp
;
2566 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
2567 args_out_of_range (start
, end
);
2569 obuf
= current_buffer
;
2570 set_buffer_internal_1 (bp
);
2571 update_buffer_properties (b
, e
);
2572 set_buffer_internal_1 (obuf
);
2574 insert_from_buffer (bp
, b
, e
- b
, 0);
2578 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
2580 doc
: /* Compare two substrings of two buffers; return result as number.
2581 the value is -N if first string is less after N-1 chars,
2582 +N if first string is greater after N-1 chars, or 0 if strings match.
2583 Each substring is represented as three arguments: BUFFER, START and END.
2584 That makes six args in all, three for each substring.
2586 The value of `case-fold-search' in the current buffer
2587 determines whether case is significant or ignored. */)
2588 (Lisp_Object buffer1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object buffer2
, Lisp_Object start2
, Lisp_Object end2
)
2590 register EMACS_INT begp1
, endp1
, begp2
, endp2
, temp
;
2591 register struct buffer
*bp1
, *bp2
;
2592 register Lisp_Object trt
2593 = (!NILP (BVAR (current_buffer
, case_fold_search
))
2594 ? BVAR (current_buffer
, case_canon_table
) : Qnil
);
2595 EMACS_INT chars
= 0;
2596 EMACS_INT i1
, i2
, i1_byte
, i2_byte
;
2598 /* Find the first buffer and its substring. */
2601 bp1
= current_buffer
;
2605 buf1
= Fget_buffer (buffer1
);
2608 bp1
= XBUFFER (buf1
);
2609 if (NILP (BVAR (bp1
, name
)))
2610 error ("Selecting deleted buffer");
2614 begp1
= BUF_BEGV (bp1
);
2617 CHECK_NUMBER_COERCE_MARKER (start1
);
2618 begp1
= XINT (start1
);
2621 endp1
= BUF_ZV (bp1
);
2624 CHECK_NUMBER_COERCE_MARKER (end1
);
2625 endp1
= XINT (end1
);
2629 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
2631 if (!(BUF_BEGV (bp1
) <= begp1
2633 && endp1
<= BUF_ZV (bp1
)))
2634 args_out_of_range (start1
, end1
);
2636 /* Likewise for second substring. */
2639 bp2
= current_buffer
;
2643 buf2
= Fget_buffer (buffer2
);
2646 bp2
= XBUFFER (buf2
);
2647 if (NILP (BVAR (bp2
, name
)))
2648 error ("Selecting deleted buffer");
2652 begp2
= BUF_BEGV (bp2
);
2655 CHECK_NUMBER_COERCE_MARKER (start2
);
2656 begp2
= XINT (start2
);
2659 endp2
= BUF_ZV (bp2
);
2662 CHECK_NUMBER_COERCE_MARKER (end2
);
2663 endp2
= XINT (end2
);
2667 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
2669 if (!(BUF_BEGV (bp2
) <= begp2
2671 && endp2
<= BUF_ZV (bp2
)))
2672 args_out_of_range (start2
, end2
);
2676 i1_byte
= buf_charpos_to_bytepos (bp1
, i1
);
2677 i2_byte
= buf_charpos_to_bytepos (bp2
, i2
);
2679 while (i1
< endp1
&& i2
< endp2
)
2681 /* When we find a mismatch, we must compare the
2682 characters, not just the bytes. */
2687 if (! NILP (BVAR (bp1
, enable_multibyte_characters
)))
2689 c1
= BUF_FETCH_MULTIBYTE_CHAR (bp1
, i1_byte
);
2690 BUF_INC_POS (bp1
, i1_byte
);
2695 c1
= BUF_FETCH_BYTE (bp1
, i1
);
2696 MAKE_CHAR_MULTIBYTE (c1
);
2700 if (! NILP (BVAR (bp2
, enable_multibyte_characters
)))
2702 c2
= BUF_FETCH_MULTIBYTE_CHAR (bp2
, i2_byte
);
2703 BUF_INC_POS (bp2
, i2_byte
);
2708 c2
= BUF_FETCH_BYTE (bp2
, i2
);
2709 MAKE_CHAR_MULTIBYTE (c2
);
2715 c1
= CHAR_TABLE_TRANSLATE (trt
, c1
);
2716 c2
= CHAR_TABLE_TRANSLATE (trt
, c2
);
2719 return make_number (- 1 - chars
);
2721 return make_number (chars
+ 1);
2726 /* The strings match as far as they go.
2727 If one is shorter, that one is less. */
2728 if (chars
< endp1
- begp1
)
2729 return make_number (chars
+ 1);
2730 else if (chars
< endp2
- begp2
)
2731 return make_number (- chars
- 1);
2733 /* Same length too => they are equal. */
2734 return make_number (0);
2738 subst_char_in_region_unwind (Lisp_Object arg
)
2740 return BVAR (current_buffer
, undo_list
) = arg
;
2744 subst_char_in_region_unwind_1 (Lisp_Object arg
)
2746 return BVAR (current_buffer
, filename
) = arg
;
2749 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
2750 Ssubst_char_in_region
, 4, 5, 0,
2751 doc
: /* From START to END, replace FROMCHAR with TOCHAR each time it occurs.
2752 If optional arg NOUNDO is non-nil, don't record this change for undo
2753 and don't mark the buffer as really changed.
2754 Both characters must have the same length of multi-byte form. */)
2755 (Lisp_Object start
, Lisp_Object end
, Lisp_Object fromchar
, Lisp_Object tochar
, Lisp_Object noundo
)
2757 register EMACS_INT pos
, pos_byte
, stop
, i
, len
, end_byte
;
2758 /* Keep track of the first change in the buffer:
2759 if 0 we haven't found it yet.
2760 if < 0 we've found it and we've run the before-change-function.
2761 if > 0 we've actually performed it and the value is its position. */
2762 EMACS_INT changed
= 0;
2763 unsigned char fromstr
[MAX_MULTIBYTE_LENGTH
], tostr
[MAX_MULTIBYTE_LENGTH
];
2765 int count
= SPECPDL_INDEX ();
2766 #define COMBINING_NO 0
2767 #define COMBINING_BEFORE 1
2768 #define COMBINING_AFTER 2
2769 #define COMBINING_BOTH (COMBINING_BEFORE | COMBINING_AFTER)
2770 int maybe_byte_combining
= COMBINING_NO
;
2771 EMACS_INT last_changed
= 0;
2772 int multibyte_p
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
2777 validate_region (&start
, &end
);
2778 CHECK_CHARACTER (fromchar
);
2779 CHECK_CHARACTER (tochar
);
2780 fromc
= XFASTINT (fromchar
);
2781 toc
= XFASTINT (tochar
);
2785 len
= CHAR_STRING (fromc
, fromstr
);
2786 if (CHAR_STRING (toc
, tostr
) != len
)
2787 error ("Characters in `subst-char-in-region' have different byte-lengths");
2788 if (!ASCII_BYTE_P (*tostr
))
2790 /* If *TOSTR is in the range 0x80..0x9F and TOCHAR is not a
2791 complete multibyte character, it may be combined with the
2792 after bytes. If it is in the range 0xA0..0xFF, it may be
2793 combined with the before and after bytes. */
2794 if (!CHAR_HEAD_P (*tostr
))
2795 maybe_byte_combining
= COMBINING_BOTH
;
2796 else if (BYTES_BY_CHAR_HEAD (*tostr
) > len
)
2797 maybe_byte_combining
= COMBINING_AFTER
;
2808 pos_byte
= CHAR_TO_BYTE (pos
);
2809 stop
= CHAR_TO_BYTE (XINT (end
));
2812 /* If we don't want undo, turn off putting stuff on the list.
2813 That's faster than getting rid of things,
2814 and it prevents even the entry for a first change.
2815 Also inhibit locking the file. */
2816 if (!changed
&& !NILP (noundo
))
2818 record_unwind_protect (subst_char_in_region_unwind
,
2819 BVAR (current_buffer
, undo_list
));
2820 BVAR (current_buffer
, undo_list
) = Qt
;
2821 /* Don't do file-locking. */
2822 record_unwind_protect (subst_char_in_region_unwind_1
,
2823 BVAR (current_buffer
, filename
));
2824 BVAR (current_buffer
, filename
) = Qnil
;
2827 if (pos_byte
< GPT_BYTE
)
2828 stop
= min (stop
, GPT_BYTE
);
2831 EMACS_INT pos_byte_next
= pos_byte
;
2833 if (pos_byte
>= stop
)
2835 if (pos_byte
>= end_byte
) break;
2838 p
= BYTE_POS_ADDR (pos_byte
);
2840 INC_POS (pos_byte_next
);
2843 if (pos_byte_next
- pos_byte
== len
2844 && p
[0] == fromstr
[0]
2846 || (p
[1] == fromstr
[1]
2847 && (len
== 2 || (p
[2] == fromstr
[2]
2848 && (len
== 3 || p
[3] == fromstr
[3]))))))
2851 /* We've already seen this and run the before-change-function;
2852 this time we only need to record the actual position. */
2857 modify_region (current_buffer
, pos
, XINT (end
), 0);
2859 if (! NILP (noundo
))
2861 if (MODIFF
- 1 == SAVE_MODIFF
)
2863 if (MODIFF
- 1 == BUF_AUTOSAVE_MODIFF (current_buffer
))
2864 BUF_AUTOSAVE_MODIFF (current_buffer
)++;
2867 /* The before-change-function may have moved the gap
2868 or even modified the buffer so we should start over. */
2872 /* Take care of the case where the new character
2873 combines with neighboring bytes. */
2874 if (maybe_byte_combining
2875 && (maybe_byte_combining
== COMBINING_AFTER
2876 ? (pos_byte_next
< Z_BYTE
2877 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2878 : ((pos_byte_next
< Z_BYTE
2879 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2880 || (pos_byte
> BEG_BYTE
2881 && ! ASCII_BYTE_P (FETCH_BYTE (pos_byte
- 1))))))
2883 Lisp_Object tem
, string
;
2885 struct gcpro gcpro1
;
2887 tem
= BVAR (current_buffer
, undo_list
);
2890 /* Make a multibyte string containing this single character. */
2891 string
= make_multibyte_string ((char *) tostr
, 1, len
);
2892 /* replace_range is less efficient, because it moves the gap,
2893 but it handles combining correctly. */
2894 replace_range (pos
, pos
+ 1, string
,
2896 pos_byte_next
= CHAR_TO_BYTE (pos
);
2897 if (pos_byte_next
> pos_byte
)
2898 /* Before combining happened. We should not increment
2899 POS. So, to cancel the later increment of POS,
2903 INC_POS (pos_byte_next
);
2905 if (! NILP (noundo
))
2906 BVAR (current_buffer
, undo_list
) = tem
;
2913 record_change (pos
, 1);
2914 for (i
= 0; i
< len
; i
++) *p
++ = tostr
[i
];
2916 last_changed
= pos
+ 1;
2918 pos_byte
= pos_byte_next
;
2924 signal_after_change (changed
,
2925 last_changed
- changed
, last_changed
- changed
);
2926 update_compositions (changed
, last_changed
, CHECK_ALL
);
2929 unbind_to (count
, Qnil
);
2934 static Lisp_Object
check_translation (EMACS_INT
, EMACS_INT
, EMACS_INT
,
2937 /* Helper function for Ftranslate_region_internal.
2939 Check if a character sequence at POS (POS_BYTE) matches an element
2940 of VAL. VAL is a list (([FROM-CHAR ...] . TO) ...). If a matching
2941 element is found, return it. Otherwise return Qnil. */
2944 check_translation (EMACS_INT pos
, EMACS_INT pos_byte
, EMACS_INT end
,
2947 int buf_size
= 16, buf_used
= 0;
2948 int *buf
= alloca (sizeof (int) * buf_size
);
2950 for (; CONSP (val
); val
= XCDR (val
))
2959 if (! VECTORP (elt
))
2962 if (len
<= end
- pos
)
2964 for (i
= 0; i
< len
; i
++)
2968 unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
2971 if (buf_used
== buf_size
)
2976 newbuf
= alloca (sizeof (int) * buf_size
);
2977 memcpy (newbuf
, buf
, sizeof (int) * buf_used
);
2980 buf
[buf_used
++] = STRING_CHAR_AND_LENGTH (p
, len1
);
2983 if (XINT (AREF (elt
, i
)) != buf
[i
])
2994 DEFUN ("translate-region-internal", Ftranslate_region_internal
,
2995 Stranslate_region_internal
, 3, 3, 0,
2996 doc
: /* Internal use only.
2997 From START to END, translate characters according to TABLE.
2998 TABLE is a string or a char-table; the Nth character in it is the
2999 mapping for the character with code N.
3000 It returns the number of characters changed. */)
3001 (Lisp_Object start
, Lisp_Object end
, register Lisp_Object table
)
3003 register unsigned char *tt
; /* Trans table. */
3004 register int nc
; /* New character. */
3005 int cnt
; /* Number of changes made. */
3006 EMACS_INT size
; /* Size of translate table. */
3007 EMACS_INT pos
, pos_byte
, end_pos
;
3008 int multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3009 int string_multibyte
IF_LINT (= 0);
3011 validate_region (&start
, &end
);
3012 if (CHAR_TABLE_P (table
))
3014 if (! EQ (XCHAR_TABLE (table
)->purpose
, Qtranslation_table
))
3015 error ("Not a translation table");
3021 CHECK_STRING (table
);
3023 if (! multibyte
&& (SCHARS (table
) < SBYTES (table
)))
3024 table
= string_make_unibyte (table
);
3025 string_multibyte
= SCHARS (table
) < SBYTES (table
);
3026 size
= SBYTES (table
);
3031 pos_byte
= CHAR_TO_BYTE (pos
);
3032 end_pos
= XINT (end
);
3033 modify_region (current_buffer
, pos
, end_pos
, 0);
3036 for (; pos
< end_pos
; )
3038 register unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
3039 unsigned char *str
, buf
[MAX_MULTIBYTE_LENGTH
];
3045 oc
= STRING_CHAR_AND_LENGTH (p
, len
);
3052 /* Reload as signal_after_change in last iteration may GC. */
3054 if (string_multibyte
)
3056 str
= tt
+ string_char_to_byte (table
, oc
);
3057 nc
= STRING_CHAR_AND_LENGTH (str
, str_len
);
3062 if (! ASCII_BYTE_P (nc
) && multibyte
)
3064 str_len
= BYTE8_STRING (nc
, buf
);
3077 val
= CHAR_TABLE_REF (table
, oc
);
3078 if (CHARACTERP (val
))
3080 nc
= XFASTINT (val
);
3081 str_len
= CHAR_STRING (nc
, buf
);
3084 else if (VECTORP (val
) || (CONSP (val
)))
3086 /* VAL is [TO_CHAR ...] or (([FROM-CHAR ...] . TO) ...)
3087 where TO is TO-CHAR or [TO-CHAR ...]. */
3092 if (nc
!= oc
&& nc
>= 0)
3094 /* Simple one char to one char translation. */
3099 /* This is less efficient, because it moves the gap,
3100 but it should handle multibyte characters correctly. */
3101 string
= make_multibyte_string ((char *) str
, 1, str_len
);
3102 replace_range (pos
, pos
+ 1, string
, 1, 0, 1);
3107 record_change (pos
, 1);
3108 while (str_len
-- > 0)
3110 signal_after_change (pos
, 1, 1);
3111 update_compositions (pos
, pos
+ 1, CHECK_BORDER
);
3121 val
= check_translation (pos
, pos_byte
, end_pos
, val
);
3128 /* VAL is ([FROM-CHAR ...] . TO). */
3129 len
= ASIZE (XCAR (val
));
3137 string
= Fconcat (1, &val
);
3141 string
= Fmake_string (make_number (1), val
);
3143 replace_range (pos
, pos
+ len
, string
, 1, 0, 1);
3144 pos_byte
+= SBYTES (string
);
3145 pos
+= SCHARS (string
);
3146 cnt
+= SCHARS (string
);
3147 end_pos
+= SCHARS (string
) - len
;
3155 return make_number (cnt
);
3158 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
3159 doc
: /* Delete the text between point and mark.
3161 When called from a program, expects two arguments,
3162 positions (integers or markers) specifying the stretch to be deleted. */)
3163 (Lisp_Object start
, Lisp_Object end
)
3165 validate_region (&start
, &end
);
3166 del_range (XINT (start
), XINT (end
));
3170 DEFUN ("delete-and-extract-region", Fdelete_and_extract_region
,
3171 Sdelete_and_extract_region
, 2, 2, 0,
3172 doc
: /* Delete the text between START and END and return it. */)
3173 (Lisp_Object start
, Lisp_Object end
)
3175 validate_region (&start
, &end
);
3176 if (XINT (start
) == XINT (end
))
3177 return empty_unibyte_string
;
3178 return del_range_1 (XINT (start
), XINT (end
), 1, 1);
3181 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
3182 doc
: /* Remove restrictions (narrowing) from current buffer.
3183 This allows the buffer's full text to be seen and edited. */)
3186 if (BEG
!= BEGV
|| Z
!= ZV
)
3187 current_buffer
->clip_changed
= 1;
3189 BEGV_BYTE
= BEG_BYTE
;
3190 SET_BUF_ZV_BOTH (current_buffer
, Z
, Z_BYTE
);
3191 /* Changing the buffer bounds invalidates any recorded current column. */
3192 invalidate_current_column ();
3196 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
3197 doc
: /* Restrict editing in this buffer to the current region.
3198 The rest of the text becomes temporarily invisible and untouchable
3199 but is not deleted; if you save the buffer in a file, the invisible
3200 text is included in the file. \\[widen] makes all visible again.
3201 See also `save-restriction'.
3203 When calling from a program, pass two arguments; positions (integers
3204 or markers) bounding the text that should remain visible. */)
3205 (register Lisp_Object start
, Lisp_Object end
)
3207 CHECK_NUMBER_COERCE_MARKER (start
);
3208 CHECK_NUMBER_COERCE_MARKER (end
);
3210 if (XINT (start
) > XINT (end
))
3213 tem
= start
; start
= end
; end
= tem
;
3216 if (!(BEG
<= XINT (start
) && XINT (start
) <= XINT (end
) && XINT (end
) <= Z
))
3217 args_out_of_range (start
, end
);
3219 if (BEGV
!= XFASTINT (start
) || ZV
!= XFASTINT (end
))
3220 current_buffer
->clip_changed
= 1;
3222 SET_BUF_BEGV (current_buffer
, XFASTINT (start
));
3223 SET_BUF_ZV (current_buffer
, XFASTINT (end
));
3224 if (PT
< XFASTINT (start
))
3225 SET_PT (XFASTINT (start
));
3226 if (PT
> XFASTINT (end
))
3227 SET_PT (XFASTINT (end
));
3228 /* Changing the buffer bounds invalidates any recorded current column. */
3229 invalidate_current_column ();
3234 save_restriction_save (void)
3236 if (BEGV
== BEG
&& ZV
== Z
)
3237 /* The common case that the buffer isn't narrowed.
3238 We return just the buffer object, which save_restriction_restore
3239 recognizes as meaning `no restriction'. */
3240 return Fcurrent_buffer ();
3242 /* We have to save a restriction, so return a pair of markers, one
3243 for the beginning and one for the end. */
3245 Lisp_Object beg
, end
;
3247 beg
= buildmark (BEGV
, BEGV_BYTE
);
3248 end
= buildmark (ZV
, ZV_BYTE
);
3250 /* END must move forward if text is inserted at its exact location. */
3251 XMARKER(end
)->insertion_type
= 1;
3253 return Fcons (beg
, end
);
3258 save_restriction_restore (Lisp_Object data
)
3260 struct buffer
*cur
= NULL
;
3261 struct buffer
*buf
= (CONSP (data
)
3262 ? XMARKER (XCAR (data
))->buffer
3265 if (buf
&& buf
!= current_buffer
&& !NILP (BVAR (buf
, pt_marker
)))
3266 { /* If `buf' uses markers to keep track of PT, BEGV, and ZV (as
3267 is the case if it is or has an indirect buffer), then make
3268 sure it is current before we update BEGV, so
3269 set_buffer_internal takes care of managing those markers. */
3270 cur
= current_buffer
;
3271 set_buffer_internal (buf
);
3275 /* A pair of marks bounding a saved restriction. */
3277 struct Lisp_Marker
*beg
= XMARKER (XCAR (data
));
3278 struct Lisp_Marker
*end
= XMARKER (XCDR (data
));
3279 eassert (buf
== end
->buffer
);
3281 if (buf
/* Verify marker still points to a buffer. */
3282 && (beg
->charpos
!= BUF_BEGV (buf
) || end
->charpos
!= BUF_ZV (buf
)))
3283 /* The restriction has changed from the saved one, so restore
3284 the saved restriction. */
3286 EMACS_INT pt
= BUF_PT (buf
);
3288 SET_BUF_BEGV_BOTH (buf
, beg
->charpos
, beg
->bytepos
);
3289 SET_BUF_ZV_BOTH (buf
, end
->charpos
, end
->bytepos
);
3291 if (pt
< beg
->charpos
|| pt
> end
->charpos
)
3292 /* The point is outside the new visible range, move it inside. */
3293 SET_BUF_PT_BOTH (buf
,
3294 clip_to_bounds (beg
->charpos
, pt
, end
->charpos
),
3295 clip_to_bounds (beg
->bytepos
, BUF_PT_BYTE (buf
),
3298 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3302 /* A buffer, which means that there was no old restriction. */
3304 if (buf
/* Verify marker still points to a buffer. */
3305 && (BUF_BEGV (buf
) != BUF_BEG (buf
) || BUF_ZV (buf
) != BUF_Z (buf
)))
3306 /* The buffer has been narrowed, get rid of the narrowing. */
3308 SET_BUF_BEGV_BOTH (buf
, BUF_BEG (buf
), BUF_BEG_BYTE (buf
));
3309 SET_BUF_ZV_BOTH (buf
, BUF_Z (buf
), BUF_Z_BYTE (buf
));
3311 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3315 /* Changing the buffer bounds invalidates any recorded current column. */
3316 invalidate_current_column ();
3319 set_buffer_internal (cur
);
3324 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
3325 doc
: /* Execute BODY, saving and restoring current buffer's restrictions.
3326 The buffer's restrictions make parts of the beginning and end invisible.
3327 \(They are set up with `narrow-to-region' and eliminated with `widen'.)
3328 This special form, `save-restriction', saves the current buffer's restrictions
3329 when it is entered, and restores them when it is exited.
3330 So any `narrow-to-region' within BODY lasts only until the end of the form.
3331 The old restrictions settings are restored
3332 even in case of abnormal exit (throw or error).
3334 The value returned is the value of the last form in BODY.
3336 Note: if you are using both `save-excursion' and `save-restriction',
3337 use `save-excursion' outermost:
3338 (save-excursion (save-restriction ...))
3340 usage: (save-restriction &rest BODY) */)
3343 register Lisp_Object val
;
3344 int count
= SPECPDL_INDEX ();
3346 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
3347 val
= Fprogn (body
);
3348 return unbind_to (count
, val
);
3351 /* Buffer for the most recent text displayed by Fmessage_box. */
3352 static char *message_text
;
3354 /* Allocated length of that buffer. */
3355 static int message_length
;
3357 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
3358 doc
: /* Display a message at the bottom of the screen.
3359 The message also goes into the `*Messages*' buffer.
3360 \(In keyboard macros, that's all it does.)
3363 The first argument is a format control string, and the rest are data
3364 to be formatted under control of the string. See `format' for details.
3366 Note: Use (message "%s" VALUE) to print the value of expressions and
3367 variables to avoid accidentally interpreting `%' as format specifiers.
3369 If the first argument is nil or the empty string, the function clears
3370 any existing message; this lets the minibuffer contents show. See
3371 also `current-message'.
3373 usage: (message FORMAT-STRING &rest ARGS) */)
3374 (ptrdiff_t nargs
, Lisp_Object
*args
)
3377 || (STRINGP (args
[0])
3378 && SBYTES (args
[0]) == 0))
3385 register Lisp_Object val
;
3386 val
= Fformat (nargs
, args
);
3387 message3 (val
, SBYTES (val
), STRING_MULTIBYTE (val
));
3392 DEFUN ("message-box", Fmessage_box
, Smessage_box
, 1, MANY
, 0,
3393 doc
: /* Display a message, in a dialog box if possible.
3394 If a dialog box is not available, use the echo area.
3395 The first argument is a format control string, and the rest are data
3396 to be formatted under control of the string. See `format' for details.
3398 If the first argument is nil or the empty string, clear any existing
3399 message; let the minibuffer contents show.
3401 usage: (message-box FORMAT-STRING &rest ARGS) */)
3402 (ptrdiff_t nargs
, Lisp_Object
*args
)
3411 register Lisp_Object val
;
3412 val
= Fformat (nargs
, args
);
3414 /* The MS-DOS frames support popup menus even though they are
3415 not FRAME_WINDOW_P. */
3416 if (FRAME_WINDOW_P (XFRAME (selected_frame
))
3417 || FRAME_MSDOS_P (XFRAME (selected_frame
)))
3419 Lisp_Object pane
, menu
;
3420 struct gcpro gcpro1
;
3421 pane
= Fcons (Fcons (build_string ("OK"), Qt
), Qnil
);
3423 menu
= Fcons (val
, pane
);
3424 Fx_popup_dialog (Qt
, menu
, Qt
);
3428 #endif /* HAVE_MENUS */
3429 /* Copy the data so that it won't move when we GC. */
3432 message_text
= (char *)xmalloc (80);
3433 message_length
= 80;
3435 if (SBYTES (val
) > message_length
)
3437 message_length
= SBYTES (val
);
3438 message_text
= (char *)xrealloc (message_text
, message_length
);
3440 memcpy (message_text
, SDATA (val
), SBYTES (val
));
3441 message2 (message_text
, SBYTES (val
),
3442 STRING_MULTIBYTE (val
));
3447 DEFUN ("message-or-box", Fmessage_or_box
, Smessage_or_box
, 1, MANY
, 0,
3448 doc
: /* Display a message in a dialog box or in the echo area.
3449 If this command was invoked with the mouse, use a dialog box if
3450 `use-dialog-box' is non-nil.
3451 Otherwise, use the echo area.
3452 The first argument is a format control string, and the rest are data
3453 to be formatted under control of the string. See `format' for details.
3455 If the first argument is nil or the empty string, clear any existing
3456 message; let the minibuffer contents show.
3458 usage: (message-or-box FORMAT-STRING &rest ARGS) */)
3459 (ptrdiff_t nargs
, Lisp_Object
*args
)
3462 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3464 return Fmessage_box (nargs
, args
);
3466 return Fmessage (nargs
, args
);
3469 DEFUN ("current-message", Fcurrent_message
, Scurrent_message
, 0, 0, 0,
3470 doc
: /* Return the string currently displayed in the echo area, or nil if none. */)
3473 return current_message ();
3477 DEFUN ("propertize", Fpropertize
, Spropertize
, 1, MANY
, 0,
3478 doc
: /* Return a copy of STRING with text properties added.
3479 First argument is the string to copy.
3480 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
3481 properties to add to the result.
3482 usage: (propertize STRING &rest PROPERTIES) */)
3483 (ptrdiff_t nargs
, Lisp_Object
*args
)
3485 Lisp_Object properties
, string
;
3486 struct gcpro gcpro1
, gcpro2
;
3489 /* Number of args must be odd. */
3490 if ((nargs
& 1) == 0)
3491 error ("Wrong number of arguments");
3493 properties
= string
= Qnil
;
3494 GCPRO2 (properties
, string
);
3496 /* First argument must be a string. */
3497 CHECK_STRING (args
[0]);
3498 string
= Fcopy_sequence (args
[0]);
3500 for (i
= 1; i
< nargs
; i
+= 2)
3501 properties
= Fcons (args
[i
], Fcons (args
[i
+ 1], properties
));
3503 Fadd_text_properties (make_number (0),
3504 make_number (SCHARS (string
)),
3505 properties
, string
);
3506 RETURN_UNGCPRO (string
);
3509 /* pWIDE is a conversion for printing large decimal integers (possibly with a
3510 trailing "d" that is ignored). pWIDElen is its length. signed_wide and
3511 unsigned_wide are signed and unsigned types for printing them. Use widest
3512 integers if available so that more floating point values can be converted. */
3514 # define pWIDE PRIdMAX
3515 enum { pWIDElen
= sizeof PRIdMAX
- 2 }; /* Don't count trailing "d". */
3516 typedef intmax_t signed_wide
;
3517 typedef uintmax_t unsigned_wide
;
3520 enum { pWIDElen
= sizeof pI
- 1 };
3521 typedef EMACS_INT signed_wide
;
3522 typedef EMACS_UINT unsigned_wide
;
3525 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
3526 doc
: /* Format a string out of a format-string and arguments.
3527 The first argument is a format control string.
3528 The other arguments are substituted into it to make the result, a string.
3530 The format control string may contain %-sequences meaning to substitute
3531 the next available argument:
3533 %s means print a string argument. Actually, prints any object, with `princ'.
3534 %d means print as number in decimal (%o octal, %x hex).
3535 %X is like %x, but uses upper case.
3536 %e means print a number in exponential notation.
3537 %f means print a number in decimal-point notation.
3538 %g means print a number in exponential notation
3539 or decimal-point notation, whichever uses fewer characters.
3540 %c means print a number as a single character.
3541 %S means print any object as an s-expression (using `prin1').
3543 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.
3544 Use %% to put a single % into the output.
3546 A %-sequence may contain optional flag, width, and precision
3547 specifiers, as follows:
3549 %<flags><width><precision>character
3551 where flags is [+ #-0]+, width is [0-9]+, and precision is .[0-9]+
3553 The + flag character inserts a + before any positive number, while a
3554 space inserts a space before any positive number; these flags only
3555 affect %d, %e, %f, and %g sequences, and the + flag takes precedence.
3556 The # flag means to use an alternate display form for %o, %x, %X, %e,
3557 %f, and %g sequences. The - and 0 flags affect the width specifier,
3560 The width specifier supplies a lower limit for the length of the
3561 printed representation. The padding, if any, normally goes on the
3562 left, but it goes on the right if the - flag is present. The padding
3563 character is normally a space, but it is 0 if the 0 flag is present.
3564 The 0 flag is ignored if the - flag is present, or the format sequence
3565 is something other than %d, %e, %f, and %g.
3567 For %e, %f, and %g sequences, the number after the "." in the
3568 precision specifier says how many decimal places to show; if zero, the
3569 decimal point itself is omitted. For %s and %S, the precision
3570 specifier truncates the string to the given width.
3572 usage: (format STRING &rest OBJECTS) */)
3573 (ptrdiff_t nargs
, Lisp_Object
*args
)
3575 ptrdiff_t n
; /* The number of the next arg to substitute */
3576 char initial_buffer
[4000];
3577 char *buf
= initial_buffer
;
3578 EMACS_INT bufsize
= sizeof initial_buffer
;
3579 EMACS_INT max_bufsize
= STRING_BYTES_BOUND
+ 1;
3581 Lisp_Object buf_save_value
IF_LINT (= {0});
3582 register char *format
, *end
, *format_start
;
3583 EMACS_INT formatlen
, nchars
;
3584 /* Nonzero if the format is multibyte. */
3585 int multibyte_format
= 0;
3586 /* Nonzero if the output should be a multibyte string,
3587 which is true if any of the inputs is one. */
3589 /* When we make a multibyte string, we must pay attention to the
3590 byte combining problem, i.e., a byte may be combined with a
3591 multibyte character of the previous string. This flag tells if we
3592 must consider such a situation or not. */
3593 int maybe_combine_byte
;
3595 int arg_intervals
= 0;
3598 /* discarded[I] is 1 if byte I of the format
3599 string was not copied into the output.
3600 It is 2 if byte I was not the first byte of its character. */
3603 /* Each element records, for one argument,
3604 the start and end bytepos in the output string,
3605 whether the argument has been converted to string (e.g., due to "%S"),
3606 and whether the argument is a string with intervals.
3607 info[0] is unused. Unused elements have -1 for start. */
3610 EMACS_INT start
, end
;
3611 int converted_to_string
;
3615 /* It should not be necessary to GCPRO ARGS, because
3616 the caller in the interpreter should take care of that. */
3618 CHECK_STRING (args
[0]);
3619 format_start
= SSDATA (args
[0]);
3620 formatlen
= SBYTES (args
[0]);
3622 /* Allocate the info and discarded tables. */
3625 if ((SIZE_MAX
- formatlen
) / sizeof (struct info
) <= nargs
)
3626 memory_full (SIZE_MAX
);
3627 SAFE_ALLOCA (info
, struct info
*, (nargs
+ 1) * sizeof *info
+ formatlen
);
3628 discarded
= (char *) &info
[nargs
+ 1];
3629 for (i
= 0; i
< nargs
+ 1; i
++)
3632 info
[i
].intervals
= info
[i
].converted_to_string
= 0;
3634 memset (discarded
, 0, formatlen
);
3637 /* Try to determine whether the result should be multibyte.
3638 This is not always right; sometimes the result needs to be multibyte
3639 because of an object that we will pass through prin1,
3640 and in that case, we won't know it here. */
3641 multibyte_format
= STRING_MULTIBYTE (args
[0]);
3642 multibyte
= multibyte_format
;
3643 for (n
= 1; !multibyte
&& n
< nargs
; n
++)
3644 if (STRINGP (args
[n
]) && STRING_MULTIBYTE (args
[n
]))
3647 /* If we start out planning a unibyte result,
3648 then discover it has to be multibyte, we jump back to retry. */
3655 /* Scan the format and store result in BUF. */
3656 format
= format_start
;
3657 end
= format
+ formatlen
;
3658 maybe_combine_byte
= 0;
3660 while (format
!= end
)
3662 /* The values of N and FORMAT when the loop body is entered. */
3664 char *format0
= format
;
3666 /* Bytes needed to represent the output of this conversion. */
3667 EMACS_INT convbytes
;
3671 /* General format specifications look like
3673 '%' [flags] [field-width] [precision] format
3678 field-width ::= [0-9]+
3679 precision ::= '.' [0-9]*
3681 If a field-width is specified, it specifies to which width
3682 the output should be padded with blanks, if the output
3683 string is shorter than field-width.
3685 If precision is specified, it specifies the number of
3686 digits to print after the '.' for floats, or the max.
3687 number of chars to print from a string. */
3694 EMACS_INT field_width
;
3695 int precision_given
;
3696 uintmax_t precision
= UINTMAX_MAX
;
3704 case '-': minus_flag
= 1; continue;
3705 case '+': plus_flag
= 1; continue;
3706 case ' ': space_flag
= 1; continue;
3707 case '#': sharp_flag
= 1; continue;
3708 case '0': zero_flag
= 1; continue;
3713 /* Ignore flags when sprintf ignores them. */
3714 space_flag
&= ~ plus_flag
;
3715 zero_flag
&= ~ minus_flag
;
3718 uintmax_t w
= strtoumax (format
, &num_end
, 10);
3719 if (max_bufsize
<= w
)
3723 precision_given
= *num_end
== '.';
3724 if (precision_given
)
3725 precision
= strtoumax (num_end
+ 1, &num_end
, 10);
3729 error ("Format string ends in middle of format specifier");
3731 memset (&discarded
[format0
- format_start
], 1, format
- format0
);
3732 conversion
= *format
;
3733 if (conversion
== '%')
3735 discarded
[format
- format_start
] = 1;
3740 error ("Not enough arguments for format string");
3742 /* For 'S', prin1 the argument, and then treat like 's'.
3743 For 's', princ any argument that is not a string or
3744 symbol. But don't do this conversion twice, which might
3745 happen after retrying. */
3746 if ((conversion
== 'S'
3747 || (conversion
== 's'
3748 && ! STRINGP (args
[n
]) && ! SYMBOLP (args
[n
]))))
3750 if (! info
[n
].converted_to_string
)
3752 Lisp_Object noescape
= conversion
== 'S' ? Qnil
: Qt
;
3753 args
[n
] = Fprin1_to_string (args
[n
], noescape
);
3754 info
[n
].converted_to_string
= 1;
3755 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
3763 else if (conversion
== 'c')
3765 if (FLOATP (args
[n
]))
3767 double d
= XFLOAT_DATA (args
[n
]);
3768 args
[n
] = make_number (FIXNUM_OVERFLOW_P (d
) ? -1 : d
);
3771 if (INTEGERP (args
[n
]) && ! ASCII_CHAR_P (XINT (args
[n
])))
3778 args
[n
] = Fchar_to_string (args
[n
]);
3779 info
[n
].converted_to_string
= 1;
3782 if (info
[n
].converted_to_string
)
3787 if (SYMBOLP (args
[n
]))
3789 args
[n
] = SYMBOL_NAME (args
[n
]);
3790 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
3797 if (conversion
== 's')
3799 /* handle case (precision[n] >= 0) */
3801 EMACS_INT width
, padding
, nbytes
;
3802 EMACS_INT nchars_string
;
3804 EMACS_INT prec
= -1;
3805 if (precision_given
&& precision
<= TYPE_MAXIMUM (EMACS_INT
))
3808 /* lisp_string_width ignores a precision of 0, but GNU
3809 libc functions print 0 characters when the precision
3810 is 0. Imitate libc behavior here. Changing
3811 lisp_string_width is the right thing, and will be
3812 done, but meanwhile we work with it. */
3815 width
= nchars_string
= nbytes
= 0;
3819 width
= lisp_string_width (args
[n
], prec
, &nch
, &nby
);
3822 nchars_string
= SCHARS (args
[n
]);
3823 nbytes
= SBYTES (args
[n
]);
3827 nchars_string
= nch
;
3833 if (convbytes
&& multibyte
&& ! STRING_MULTIBYTE (args
[n
]))
3834 convbytes
= count_size_as_multibyte (SDATA (args
[n
]), nbytes
);
3836 padding
= width
< field_width
? field_width
- width
: 0;
3838 if (max_bufsize
- padding
<= convbytes
)
3840 convbytes
+= padding
;
3841 if (convbytes
<= buf
+ bufsize
- p
)
3845 memset (p
, ' ', padding
);
3852 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3853 && STRING_MULTIBYTE (args
[n
])
3854 && !CHAR_HEAD_P (SREF (args
[n
], 0)))
3855 maybe_combine_byte
= 1;
3857 p
+= copy_text (SDATA (args
[n
]), (unsigned char *) p
,
3859 STRING_MULTIBYTE (args
[n
]), multibyte
);
3861 info
[n
].start
= nchars
;
3862 nchars
+= nchars_string
;
3863 info
[n
].end
= nchars
;
3867 memset (p
, ' ', padding
);
3872 /* If this argument has text properties, record where
3873 in the result string it appears. */
3874 if (STRING_INTERVALS (args
[n
]))
3875 info
[n
].intervals
= arg_intervals
= 1;
3880 else if (! (conversion
== 'c' || conversion
== 'd'
3881 || conversion
== 'e' || conversion
== 'f'
3882 || conversion
== 'g' || conversion
== 'i'
3883 || conversion
== 'o' || conversion
== 'x'
3884 || conversion
== 'X'))
3885 error ("Invalid format operation %%%c",
3886 STRING_CHAR ((unsigned char *) format
- 1));
3887 else if (! (INTEGERP (args
[n
]) || FLOATP (args
[n
])))
3888 error ("Format specifier doesn't match argument type");
3893 /* Maximum precision for a %f conversion such that the
3894 trailing output digit might be nonzero. Any precisions
3895 larger than this will not yield useful information. */
3896 USEFUL_PRECISION_MAX
=
3898 * (FLT_RADIX
== 2 || FLT_RADIX
== 10 ? 1
3899 : FLT_RADIX
== 16 ? 4
3902 /* Maximum number of bytes generated by any format, if
3903 precision is no more than DBL_USEFUL_PRECISION_MAX.
3904 On all practical hosts, %f is the worst case. */
3906 sizeof "-." + (DBL_MAX_10_EXP
+ 1) + USEFUL_PRECISION_MAX
3908 verify (0 < USEFUL_PRECISION_MAX
);
3911 EMACS_INT padding
, sprintf_bytes
;
3912 uintmax_t excess_precision
, numwidth
;
3913 uintmax_t leading_zeros
= 0, trailing_zeros
= 0;
3915 char sprintf_buf
[SPRINTF_BUFSIZE
];
3917 /* Copy of conversion specification, modified somewhat.
3918 At most three flags F can be specified at once. */
3919 char convspec
[sizeof "%FFF.*d" + pWIDElen
];
3921 /* Avoid undefined behavior in underlying sprintf. */
3922 if (conversion
== 'd' || conversion
== 'i')
3925 /* Create the copy of the conversion specification, with
3926 any width and precision removed, with ".*" inserted,
3927 and with pWIDE inserted for integer formats. */
3931 *f
= '-'; f
+= minus_flag
;
3932 *f
= '+'; f
+= plus_flag
;
3933 *f
= ' '; f
+= space_flag
;
3934 *f
= '#'; f
+= sharp_flag
;
3935 *f
= '0'; f
+= zero_flag
;
3938 if (conversion
== 'd' || conversion
== 'i'
3939 || conversion
== 'o' || conversion
== 'x'
3940 || conversion
== 'X')
3942 memcpy (f
, pWIDE
, pWIDElen
);
3944 zero_flag
&= ~ precision_given
;
3951 if (precision_given
)
3952 prec
= min (precision
, USEFUL_PRECISION_MAX
);
3954 /* Use sprintf to format this number into sprintf_buf. Omit
3955 padding and excess precision, though, because sprintf limits
3956 output length to INT_MAX.
3958 There are four types of conversion: double, unsigned
3959 char (passed as int), wide signed int, and wide
3960 unsigned int. Treat them separately because the
3961 sprintf ABI is sensitive to which type is passed. Be
3962 careful about integer overflow, NaNs, infinities, and
3963 conversions; for example, the min and max macros are
3964 not suitable here. */
3965 if (conversion
== 'e' || conversion
== 'f' || conversion
== 'g')
3967 double x
= (INTEGERP (args
[n
])
3969 : XFLOAT_DATA (args
[n
]));
3970 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
3972 else if (conversion
== 'c')
3974 /* Don't use sprintf here, as it might mishandle prec. */
3975 sprintf_buf
[0] = XINT (args
[n
]);
3976 sprintf_bytes
= prec
!= 0;
3978 else if (conversion
== 'd')
3980 /* For float, maybe we should use "%1.0f"
3981 instead so it also works for values outside
3982 the integer range. */
3984 if (INTEGERP (args
[n
]))
3988 double d
= XFLOAT_DATA (args
[n
]);
3991 x
= TYPE_MINIMUM (signed_wide
);
3997 x
= TYPE_MAXIMUM (signed_wide
);
4002 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4006 /* Don't sign-extend for octal or hex printing. */
4008 if (INTEGERP (args
[n
]))
4009 x
= XUINT (args
[n
]);
4012 double d
= XFLOAT_DATA (args
[n
]);
4017 x
= TYPE_MAXIMUM (unsigned_wide
);
4022 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4025 /* Now the length of the formatted item is known, except it omits
4026 padding and excess precision. Deal with excess precision
4027 first. This happens only when the format specifies
4028 ridiculously large precision. */
4029 excess_precision
= precision
- prec
;
4030 if (excess_precision
)
4032 if (conversion
== 'e' || conversion
== 'f'
4033 || conversion
== 'g')
4035 if ((conversion
== 'g' && ! sharp_flag
)
4036 || ! ('0' <= sprintf_buf
[sprintf_bytes
- 1]
4037 && sprintf_buf
[sprintf_bytes
- 1] <= '9'))
4038 excess_precision
= 0;
4041 if (conversion
== 'g')
4043 char *dot
= strchr (sprintf_buf
, '.');
4045 excess_precision
= 0;
4048 trailing_zeros
= excess_precision
;
4051 leading_zeros
= excess_precision
;
4054 /* Compute the total bytes needed for this item, including
4055 excess precision and padding. */
4056 numwidth
= sprintf_bytes
+ excess_precision
;
4057 padding
= numwidth
< field_width
? field_width
- numwidth
: 0;
4058 if (max_bufsize
- sprintf_bytes
<= excess_precision
4059 || max_bufsize
- padding
<= numwidth
)
4061 convbytes
= numwidth
+ padding
;
4063 if (convbytes
<= buf
+ bufsize
- p
)
4065 /* Copy the formatted item from sprintf_buf into buf,
4066 inserting padding and excess-precision zeros. */
4068 char *src
= sprintf_buf
;
4070 int exponent_bytes
= 0;
4071 int signedp
= src0
== '-' || src0
== '+' || src0
== ' ';
4072 int significand_bytes
;
4074 && ((src
[signedp
] >= '0' && src
[signedp
] <= '9')
4075 || (src
[signedp
] >= 'a' && src
[signedp
] <= 'f')
4076 || (src
[signedp
] >= 'A' && src
[signedp
] <= 'F')))
4078 leading_zeros
+= padding
;
4082 if (excess_precision
4083 && (conversion
== 'e' || conversion
== 'g'))
4085 char *e
= strchr (src
, 'e');
4087 exponent_bytes
= src
+ sprintf_bytes
- e
;
4092 memset (p
, ' ', padding
);
4100 memset (p
, '0', leading_zeros
);
4102 significand_bytes
= sprintf_bytes
- signedp
- exponent_bytes
;
4103 memcpy (p
, src
, significand_bytes
);
4104 p
+= significand_bytes
;
4105 src
+= significand_bytes
;
4106 memset (p
, '0', trailing_zeros
);
4107 p
+= trailing_zeros
;
4108 memcpy (p
, src
, exponent_bytes
);
4109 p
+= exponent_bytes
;
4111 info
[n
].start
= nchars
;
4112 nchars
+= leading_zeros
+ sprintf_bytes
+ trailing_zeros
;
4113 info
[n
].end
= nchars
;
4117 memset (p
, ' ', padding
);
4129 /* Copy a single character from format to buf. */
4132 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
4134 if (multibyte_format
)
4136 /* Copy a whole multibyte character. */
4138 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
4139 && !CHAR_HEAD_P (*format
))
4140 maybe_combine_byte
= 1;
4144 while (! CHAR_HEAD_P (*format
));
4146 convbytes
= format
- format0
;
4147 memset (&discarded
[format0
+ 1 - format_start
], 2, convbytes
- 1);
4151 unsigned char uc
= *format
++;
4152 if (! multibyte
|| ASCII_BYTE_P (uc
))
4156 int c
= BYTE8_TO_CHAR (uc
);
4157 convbytes
= CHAR_STRING (c
, str
);
4162 if (convbytes
<= buf
+ bufsize
- p
)
4164 memcpy (p
, src
, convbytes
);
4171 /* There wasn't enough room to store this conversion or single
4172 character. CONVBYTES says how much room is needed. Allocate
4173 enough room (and then some) and do it again. */
4175 EMACS_INT used
= p
- buf
;
4177 if (max_bufsize
- used
< convbytes
)
4179 bufsize
= used
+ convbytes
;
4180 bufsize
= bufsize
< max_bufsize
/ 2 ? bufsize
* 2 : max_bufsize
;
4182 if (buf
== initial_buffer
)
4184 buf
= xmalloc (bufsize
);
4186 buf_save_value
= make_save_value (buf
, 0);
4187 record_unwind_protect (safe_alloca_unwind
, buf_save_value
);
4188 memcpy (buf
, initial_buffer
, used
);
4191 XSAVE_VALUE (buf_save_value
)->pointer
= buf
= xrealloc (buf
, bufsize
);
4200 if (bufsize
< p
- buf
)
4203 if (maybe_combine_byte
)
4204 nchars
= multibyte_chars_in_text ((unsigned char *) buf
, p
- buf
);
4205 val
= make_specified_string (buf
, nchars
, p
- buf
, multibyte
);
4207 /* If we allocated BUF with malloc, free it too. */
4210 /* If the format string has text properties, or any of the string
4211 arguments has text properties, set up text properties of the
4214 if (STRING_INTERVALS (args
[0]) || arg_intervals
)
4216 Lisp_Object len
, new_len
, props
;
4217 struct gcpro gcpro1
;
4219 /* Add text properties from the format string. */
4220 len
= make_number (SCHARS (args
[0]));
4221 props
= text_property_list (args
[0], make_number (0), len
, Qnil
);
4226 EMACS_INT bytepos
= 0, position
= 0, translated
= 0;
4230 /* Adjust the bounds of each text property
4231 to the proper start and end in the output string. */
4233 /* Put the positions in PROPS in increasing order, so that
4234 we can do (effectively) one scan through the position
4235 space of the format string. */
4236 props
= Fnreverse (props
);
4238 /* BYTEPOS is the byte position in the format string,
4239 POSITION is the untranslated char position in it,
4240 TRANSLATED is the translated char position in BUF,
4241 and ARGN is the number of the next arg we will come to. */
4242 for (list
= props
; CONSP (list
); list
= XCDR (list
))
4249 /* First adjust the property start position. */
4250 pos
= XINT (XCAR (item
));
4252 /* Advance BYTEPOS, POSITION, TRANSLATED and ARGN
4253 up to this position. */
4254 for (; position
< pos
; bytepos
++)
4256 if (! discarded
[bytepos
])
4257 position
++, translated
++;
4258 else if (discarded
[bytepos
] == 1)
4261 if (translated
== info
[argn
].start
)
4263 translated
+= info
[argn
].end
- info
[argn
].start
;
4269 XSETCAR (item
, make_number (translated
));
4271 /* Likewise adjust the property end position. */
4272 pos
= XINT (XCAR (XCDR (item
)));
4274 for (; position
< pos
; bytepos
++)
4276 if (! discarded
[bytepos
])
4277 position
++, translated
++;
4278 else if (discarded
[bytepos
] == 1)
4281 if (translated
== info
[argn
].start
)
4283 translated
+= info
[argn
].end
- info
[argn
].start
;
4289 XSETCAR (XCDR (item
), make_number (translated
));
4292 add_text_properties_from_list (val
, props
, make_number (0));
4295 /* Add text properties from arguments. */
4297 for (n
= 1; n
< nargs
; ++n
)
4298 if (info
[n
].intervals
)
4300 len
= make_number (SCHARS (args
[n
]));
4301 new_len
= make_number (info
[n
].end
- info
[n
].start
);
4302 props
= text_property_list (args
[n
], make_number (0), len
, Qnil
);
4303 props
= extend_property_ranges (props
, new_len
);
4304 /* If successive arguments have properties, be sure that
4305 the value of `composition' property be the copy. */
4306 if (n
> 1 && info
[n
- 1].end
)
4307 make_composition_value_copy (props
);
4308 add_text_properties_from_list (val
, props
,
4309 make_number (info
[n
].start
));
4319 format2 (const char *string1
, Lisp_Object arg0
, Lisp_Object arg1
)
4321 Lisp_Object args
[3];
4322 args
[0] = build_string (string1
);
4325 return Fformat (3, args
);
4328 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
4329 doc
: /* Return t if two characters match, optionally ignoring case.
4330 Both arguments must be characters (i.e. integers).
4331 Case is ignored if `case-fold-search' is non-nil in the current buffer. */)
4332 (register Lisp_Object c1
, Lisp_Object c2
)
4335 /* Check they're chars, not just integers, otherwise we could get array
4336 bounds violations in downcase. */
4337 CHECK_CHARACTER (c1
);
4338 CHECK_CHARACTER (c2
);
4340 if (XINT (c1
) == XINT (c2
))
4342 if (NILP (BVAR (current_buffer
, case_fold_search
)))
4346 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
))
4347 && ! ASCII_CHAR_P (i1
))
4349 MAKE_CHAR_MULTIBYTE (i1
);
4352 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
))
4353 && ! ASCII_CHAR_P (i2
))
4355 MAKE_CHAR_MULTIBYTE (i2
);
4357 return (downcase (i1
) == downcase (i2
) ? Qt
: Qnil
);
4360 /* Transpose the markers in two regions of the current buffer, and
4361 adjust the ones between them if necessary (i.e.: if the regions
4364 START1, END1 are the character positions of the first region.
4365 START1_BYTE, END1_BYTE are the byte positions.
4366 START2, END2 are the character positions of the second region.
4367 START2_BYTE, END2_BYTE are the byte positions.
4369 Traverses the entire marker list of the buffer to do so, adding an
4370 appropriate amount to some, subtracting from some, and leaving the
4371 rest untouched. Most of this is copied from adjust_markers in insdel.c.
4373 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
4376 transpose_markers (EMACS_INT start1
, EMACS_INT end1
,
4377 EMACS_INT start2
, EMACS_INT end2
,
4378 EMACS_INT start1_byte
, EMACS_INT end1_byte
,
4379 EMACS_INT start2_byte
, EMACS_INT end2_byte
)
4381 register EMACS_INT amt1
, amt1_byte
, amt2
, amt2_byte
, diff
, diff_byte
, mpos
;
4382 register struct Lisp_Marker
*marker
;
4384 /* Update point as if it were a marker. */
4388 TEMP_SET_PT_BOTH (PT
+ (end2
- end1
),
4389 PT_BYTE
+ (end2_byte
- end1_byte
));
4390 else if (PT
< start2
)
4391 TEMP_SET_PT_BOTH (PT
+ (end2
- start2
) - (end1
- start1
),
4392 (PT_BYTE
+ (end2_byte
- start2_byte
)
4393 - (end1_byte
- start1_byte
)));
4395 TEMP_SET_PT_BOTH (PT
- (start2
- start1
),
4396 PT_BYTE
- (start2_byte
- start1_byte
));
4398 /* We used to adjust the endpoints here to account for the gap, but that
4399 isn't good enough. Even if we assume the caller has tried to move the
4400 gap out of our way, it might still be at start1 exactly, for example;
4401 and that places it `inside' the interval, for our purposes. The amount
4402 of adjustment is nontrivial if there's a `denormalized' marker whose
4403 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
4404 the dirty work to Fmarker_position, below. */
4406 /* The difference between the region's lengths */
4407 diff
= (end2
- start2
) - (end1
- start1
);
4408 diff_byte
= (end2_byte
- start2_byte
) - (end1_byte
- start1_byte
);
4410 /* For shifting each marker in a region by the length of the other
4411 region plus the distance between the regions. */
4412 amt1
= (end2
- start2
) + (start2
- end1
);
4413 amt2
= (end1
- start1
) + (start2
- end1
);
4414 amt1_byte
= (end2_byte
- start2_byte
) + (start2_byte
- end1_byte
);
4415 amt2_byte
= (end1_byte
- start1_byte
) + (start2_byte
- end1_byte
);
4417 for (marker
= BUF_MARKERS (current_buffer
); marker
; marker
= marker
->next
)
4419 mpos
= marker
->bytepos
;
4420 if (mpos
>= start1_byte
&& mpos
< end2_byte
)
4422 if (mpos
< end1_byte
)
4424 else if (mpos
< start2_byte
)
4428 marker
->bytepos
= mpos
;
4430 mpos
= marker
->charpos
;
4431 if (mpos
>= start1
&& mpos
< end2
)
4435 else if (mpos
< start2
)
4440 marker
->charpos
= mpos
;
4444 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
4445 doc
: /* Transpose region STARTR1 to ENDR1 with STARTR2 to ENDR2.
4446 The regions should not be overlapping, because the size of the buffer is
4447 never changed in a transposition.
4449 Optional fifth arg LEAVE-MARKERS, if non-nil, means don't update
4450 any markers that happen to be located in the regions.
4452 Transposing beyond buffer boundaries is an error. */)
4453 (Lisp_Object startr1
, Lisp_Object endr1
, Lisp_Object startr2
, Lisp_Object endr2
, Lisp_Object leave_markers
)
4455 register EMACS_INT start1
, end1
, start2
, end2
;
4456 EMACS_INT start1_byte
, start2_byte
, len1_byte
, len2_byte
;
4457 EMACS_INT gap
, len1
, len_mid
, len2
;
4458 unsigned char *start1_addr
, *start2_addr
, *temp
;
4460 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
, tmp_interval3
;
4463 XSETBUFFER (buf
, current_buffer
);
4464 cur_intv
= BUF_INTERVALS (current_buffer
);
4466 validate_region (&startr1
, &endr1
);
4467 validate_region (&startr2
, &endr2
);
4469 start1
= XFASTINT (startr1
);
4470 end1
= XFASTINT (endr1
);
4471 start2
= XFASTINT (startr2
);
4472 end2
= XFASTINT (endr2
);
4475 /* Swap the regions if they're reversed. */
4478 register EMACS_INT glumph
= start1
;
4486 len1
= end1
- start1
;
4487 len2
= end2
- start2
;
4490 error ("Transposed regions overlap");
4491 /* Nothing to change for adjacent regions with one being empty */
4492 else if ((start1
== end1
|| start2
== end2
) && end1
== start2
)
4495 /* The possibilities are:
4496 1. Adjacent (contiguous) regions, or separate but equal regions
4497 (no, really equal, in this case!), or
4498 2. Separate regions of unequal size.
4500 The worst case is usually No. 2. It means that (aside from
4501 potential need for getting the gap out of the way), there also
4502 needs to be a shifting of the text between the two regions. So
4503 if they are spread far apart, we are that much slower... sigh. */
4505 /* It must be pointed out that the really studly thing to do would
4506 be not to move the gap at all, but to leave it in place and work
4507 around it if necessary. This would be extremely efficient,
4508 especially considering that people are likely to do
4509 transpositions near where they are working interactively, which
4510 is exactly where the gap would be found. However, such code
4511 would be much harder to write and to read. So, if you are
4512 reading this comment and are feeling squirrely, by all means have
4513 a go! I just didn't feel like doing it, so I will simply move
4514 the gap the minimum distance to get it out of the way, and then
4515 deal with an unbroken array. */
4517 /* Make sure the gap won't interfere, by moving it out of the text
4518 we will operate on. */
4519 if (start1
< gap
&& gap
< end2
)
4521 if (gap
- start1
< end2
- gap
)
4527 start1_byte
= CHAR_TO_BYTE (start1
);
4528 start2_byte
= CHAR_TO_BYTE (start2
);
4529 len1_byte
= CHAR_TO_BYTE (end1
) - start1_byte
;
4530 len2_byte
= CHAR_TO_BYTE (end2
) - start2_byte
;
4532 #ifdef BYTE_COMBINING_DEBUG
4535 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4536 len2_byte
, start1
, start1_byte
)
4537 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4538 len1_byte
, end2
, start2_byte
+ len2_byte
)
4539 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4540 len1_byte
, end2
, start2_byte
+ len2_byte
))
4545 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4546 len2_byte
, start1
, start1_byte
)
4547 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4548 len1_byte
, start2
, start2_byte
)
4549 || count_combining_after (BYTE_POS_ADDR (start2_byte
),
4550 len2_byte
, end1
, start1_byte
+ len1_byte
)
4551 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4552 len1_byte
, end2
, start2_byte
+ len2_byte
))
4557 /* Hmmm... how about checking to see if the gap is large
4558 enough to use as the temporary storage? That would avoid an
4559 allocation... interesting. Later, don't fool with it now. */
4561 /* Working without memmove, for portability (sigh), so must be
4562 careful of overlapping subsections of the array... */
4564 if (end1
== start2
) /* adjacent regions */
4566 modify_region (current_buffer
, start1
, end2
, 0);
4567 record_change (start1
, len1
+ len2
);
4569 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4570 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4571 /* Don't use Fset_text_properties: that can cause GC, which can
4572 clobber objects stored in the tmp_intervals. */
4573 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4574 if (!NULL_INTERVAL_P (tmp_interval3
))
4575 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4577 /* First region smaller than second. */
4578 if (len1_byte
< len2_byte
)
4582 SAFE_ALLOCA (temp
, unsigned char *, len2_byte
);
4584 /* Don't precompute these addresses. We have to compute them
4585 at the last minute, because the relocating allocator might
4586 have moved the buffer around during the xmalloc. */
4587 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4588 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4590 memcpy (temp
, start2_addr
, len2_byte
);
4591 memcpy (start1_addr
+ len2_byte
, start1_addr
, len1_byte
);
4592 memcpy (start1_addr
, temp
, len2_byte
);
4596 /* First region not smaller than second. */
4600 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4601 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4602 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4603 memcpy (temp
, start1_addr
, len1_byte
);
4604 memcpy (start1_addr
, start2_addr
, len2_byte
);
4605 memcpy (start1_addr
+ len2_byte
, temp
, len1_byte
);
4608 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
4609 len1
, current_buffer
, 0);
4610 graft_intervals_into_buffer (tmp_interval2
, start1
,
4611 len2
, current_buffer
, 0);
4612 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4613 update_compositions (start1
+ len2
, end2
, CHECK_TAIL
);
4615 /* Non-adjacent regions, because end1 != start2, bleagh... */
4618 len_mid
= start2_byte
- (start1_byte
+ len1_byte
);
4620 if (len1_byte
== len2_byte
)
4621 /* Regions are same size, though, how nice. */
4625 modify_region (current_buffer
, start1
, end1
, 0);
4626 modify_region (current_buffer
, start2
, end2
, 0);
4627 record_change (start1
, len1
);
4628 record_change (start2
, len2
);
4629 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4630 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4632 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr1
, 0);
4633 if (!NULL_INTERVAL_P (tmp_interval3
))
4634 set_text_properties_1 (startr1
, endr1
, Qnil
, buf
, tmp_interval3
);
4636 tmp_interval3
= validate_interval_range (buf
, &startr2
, &endr2
, 0);
4637 if (!NULL_INTERVAL_P (tmp_interval3
))
4638 set_text_properties_1 (startr2
, endr2
, Qnil
, buf
, tmp_interval3
);
4640 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4641 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4642 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4643 memcpy (temp
, start1_addr
, len1_byte
);
4644 memcpy (start1_addr
, start2_addr
, len2_byte
);
4645 memcpy (start2_addr
, temp
, len1_byte
);
4648 graft_intervals_into_buffer (tmp_interval1
, start2
,
4649 len1
, current_buffer
, 0);
4650 graft_intervals_into_buffer (tmp_interval2
, start1
,
4651 len2
, current_buffer
, 0);
4654 else if (len1_byte
< len2_byte
) /* Second region larger than first */
4655 /* Non-adjacent & unequal size, area between must also be shifted. */
4659 modify_region (current_buffer
, start1
, end2
, 0);
4660 record_change (start1
, (end2
- start1
));
4661 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4662 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4663 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4665 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4666 if (!NULL_INTERVAL_P (tmp_interval3
))
4667 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4669 /* holds region 2 */
4670 SAFE_ALLOCA (temp
, unsigned char *, len2_byte
);
4671 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4672 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4673 memcpy (temp
, start2_addr
, len2_byte
);
4674 memcpy (start1_addr
+ len_mid
+ len2_byte
, start1_addr
, len1_byte
);
4675 memmove (start1_addr
+ len2_byte
, start1_addr
+ len1_byte
, len_mid
);
4676 memcpy (start1_addr
, temp
, len2_byte
);
4679 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4680 len1
, current_buffer
, 0);
4681 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4682 len_mid
, current_buffer
, 0);
4683 graft_intervals_into_buffer (tmp_interval2
, start1
,
4684 len2
, current_buffer
, 0);
4687 /* Second region smaller than first. */
4691 record_change (start1
, (end2
- start1
));
4692 modify_region (current_buffer
, start1
, end2
, 0);
4694 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4695 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4696 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4698 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4699 if (!NULL_INTERVAL_P (tmp_interval3
))
4700 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4702 /* holds region 1 */
4703 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4704 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4705 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4706 memcpy (temp
, start1_addr
, len1_byte
);
4707 memcpy (start1_addr
, start2_addr
, len2_byte
);
4708 memcpy (start1_addr
+ len2_byte
, start1_addr
+ len1_byte
, len_mid
);
4709 memcpy (start1_addr
+ len2_byte
+ len_mid
, temp
, len1_byte
);
4712 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4713 len1
, current_buffer
, 0);
4714 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4715 len_mid
, current_buffer
, 0);
4716 graft_intervals_into_buffer (tmp_interval2
, start1
,
4717 len2
, current_buffer
, 0);
4720 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4721 update_compositions (end2
- len1
, end2
, CHECK_BORDER
);
4724 /* When doing multiple transpositions, it might be nice
4725 to optimize this. Perhaps the markers in any one buffer
4726 should be organized in some sorted data tree. */
4727 if (NILP (leave_markers
))
4729 transpose_markers (start1
, end1
, start2
, end2
,
4730 start1_byte
, start1_byte
+ len1_byte
,
4731 start2_byte
, start2_byte
+ len2_byte
);
4732 fix_start_end_in_overlays (start1
, end2
);
4735 signal_after_change (start1
, end2
- start1
, end2
- start1
);
4741 syms_of_editfns (void)
4746 DEFSYM (Qbuffer_access_fontify_functions
, "buffer-access-fontify-functions");
4748 DEFVAR_LISP ("inhibit-field-text-motion", Vinhibit_field_text_motion
,
4749 doc
: /* Non-nil means text motion commands don't notice fields. */);
4750 Vinhibit_field_text_motion
= Qnil
;
4752 DEFVAR_LISP ("buffer-access-fontify-functions",
4753 Vbuffer_access_fontify_functions
,
4754 doc
: /* List of functions called by `buffer-substring' to fontify if necessary.
4755 Each function is called with two arguments which specify the range
4756 of the buffer being accessed. */);
4757 Vbuffer_access_fontify_functions
= Qnil
;
4761 obuf
= Fcurrent_buffer ();
4762 /* Do this here, because init_buffer_once is too early--it won't work. */
4763 Fset_buffer (Vprin1_to_string_buffer
);
4764 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
4765 Fset (Fmake_local_variable (intern_c_string ("buffer-access-fontify-functions")),
4770 DEFVAR_LISP ("buffer-access-fontified-property",
4771 Vbuffer_access_fontified_property
,
4772 doc
: /* Property which (if non-nil) indicates text has been fontified.
4773 `buffer-substring' need not call the `buffer-access-fontify-functions'
4774 functions if all the text being accessed has this property. */);
4775 Vbuffer_access_fontified_property
= Qnil
;
4777 DEFVAR_LISP ("system-name", Vsystem_name
,
4778 doc
: /* The host name of the machine Emacs is running on. */);
4780 DEFVAR_LISP ("user-full-name", Vuser_full_name
,
4781 doc
: /* The full name of the user logged in. */);
4783 DEFVAR_LISP ("user-login-name", Vuser_login_name
,
4784 doc
: /* The user's name, taken from environment variables if possible. */);
4786 DEFVAR_LISP ("user-real-login-name", Vuser_real_login_name
,
4787 doc
: /* The user's name, based upon the real uid only. */);
4789 DEFVAR_LISP ("operating-system-release", Voperating_system_release
,
4790 doc
: /* The release of the operating system Emacs is running on. */);
4792 defsubr (&Spropertize
);
4793 defsubr (&Schar_equal
);
4794 defsubr (&Sgoto_char
);
4795 defsubr (&Sstring_to_char
);
4796 defsubr (&Schar_to_string
);
4797 defsubr (&Sbyte_to_string
);
4798 defsubr (&Sbuffer_substring
);
4799 defsubr (&Sbuffer_substring_no_properties
);
4800 defsubr (&Sbuffer_string
);
4802 defsubr (&Spoint_marker
);
4803 defsubr (&Smark_marker
);
4805 defsubr (&Sregion_beginning
);
4806 defsubr (&Sregion_end
);
4808 DEFSYM (Qfield
, "field");
4809 DEFSYM (Qboundary
, "boundary");
4810 defsubr (&Sfield_beginning
);
4811 defsubr (&Sfield_end
);
4812 defsubr (&Sfield_string
);
4813 defsubr (&Sfield_string_no_properties
);
4814 defsubr (&Sdelete_field
);
4815 defsubr (&Sconstrain_to_field
);
4817 defsubr (&Sline_beginning_position
);
4818 defsubr (&Sline_end_position
);
4820 /* defsubr (&Smark); */
4821 /* defsubr (&Sset_mark); */
4822 defsubr (&Ssave_excursion
);
4823 defsubr (&Ssave_current_buffer
);
4825 defsubr (&Sbufsize
);
4826 defsubr (&Spoint_max
);
4827 defsubr (&Spoint_min
);
4828 defsubr (&Spoint_min_marker
);
4829 defsubr (&Spoint_max_marker
);
4830 defsubr (&Sgap_position
);
4831 defsubr (&Sgap_size
);
4832 defsubr (&Sposition_bytes
);
4833 defsubr (&Sbyte_to_position
);
4839 defsubr (&Sfollowing_char
);
4840 defsubr (&Sprevious_char
);
4841 defsubr (&Schar_after
);
4842 defsubr (&Schar_before
);
4844 defsubr (&Sinsert_before_markers
);
4845 defsubr (&Sinsert_and_inherit
);
4846 defsubr (&Sinsert_and_inherit_before_markers
);
4847 defsubr (&Sinsert_char
);
4848 defsubr (&Sinsert_byte
);
4850 defsubr (&Suser_login_name
);
4851 defsubr (&Suser_real_login_name
);
4852 defsubr (&Suser_uid
);
4853 defsubr (&Suser_real_uid
);
4854 defsubr (&Suser_full_name
);
4855 defsubr (&Semacs_pid
);
4856 defsubr (&Scurrent_time
);
4857 defsubr (&Sget_internal_run_time
);
4858 defsubr (&Sformat_time_string
);
4859 defsubr (&Sfloat_time
);
4860 defsubr (&Sdecode_time
);
4861 defsubr (&Sencode_time
);
4862 defsubr (&Scurrent_time_string
);
4863 defsubr (&Scurrent_time_zone
);
4864 defsubr (&Sset_time_zone_rule
);
4865 defsubr (&Ssystem_name
);
4866 defsubr (&Smessage
);
4867 defsubr (&Smessage_box
);
4868 defsubr (&Smessage_or_box
);
4869 defsubr (&Scurrent_message
);
4872 defsubr (&Sinsert_buffer_substring
);
4873 defsubr (&Scompare_buffer_substrings
);
4874 defsubr (&Ssubst_char_in_region
);
4875 defsubr (&Stranslate_region_internal
);
4876 defsubr (&Sdelete_region
);
4877 defsubr (&Sdelete_and_extract_region
);
4879 defsubr (&Snarrow_to_region
);
4880 defsubr (&Ssave_restriction
);
4881 defsubr (&Stranspose_regions
);