1 /* Lisp functions pertaining to editing.
3 Copyright (C) 1985-1987, 1989, 1993-2012 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"
62 #ifndef USER_FULL_NAME
63 #define USER_FULL_NAME pw->pw_gecos
67 extern char **environ
;
70 #define TM_YEAR_BASE 1900
73 extern Lisp_Object
w32_get_internal_run_time (void);
76 static void time_overflow (void) NO_RETURN
;
77 static Lisp_Object
format_time_string (char const *, ptrdiff_t, Lisp_Object
,
78 int, time_t *, struct tm
*);
79 static int tm_diff (struct tm
*, struct tm
*);
80 static void update_buffer_properties (EMACS_INT
, EMACS_INT
);
82 static Lisp_Object Qbuffer_access_fontify_functions
;
83 static Lisp_Object
Fuser_full_name (Lisp_Object
);
85 /* Symbol for the text property used to mark fields. */
89 /* A special value for Qfield properties. */
91 static Lisp_Object Qboundary
;
97 const char *user_name
;
99 struct passwd
*pw
; /* password entry for the current user */
102 /* Set up system_name even when dumping. */
106 /* Don't bother with this on initial start when just dumping out */
109 #endif /* not CANNOT_DUMP */
111 pw
= getpwuid (getuid ());
113 /* We let the real user name default to "root" because that's quite
114 accurate on MSDOG and because it lets Emacs find the init file.
115 (The DVX libraries override the Djgpp libraries here.) */
116 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "root");
118 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "unknown");
121 /* Get the effective user name, by consulting environment variables,
122 or the effective uid if those are unset. */
123 user_name
= getenv ("LOGNAME");
126 user_name
= getenv ("USERNAME"); /* it's USERNAME on NT */
127 #else /* WINDOWSNT */
128 user_name
= getenv ("USER");
129 #endif /* WINDOWSNT */
132 pw
= getpwuid (geteuid ());
133 user_name
= pw
? pw
->pw_name
: "unknown";
135 Vuser_login_name
= build_string (user_name
);
137 /* If the user name claimed in the environment vars differs from
138 the real uid, use the claimed name to find the full name. */
139 tem
= Fstring_equal (Vuser_login_name
, Vuser_real_login_name
);
140 Vuser_full_name
= Fuser_full_name (NILP (tem
)? make_number (geteuid ())
145 Vuser_full_name
= build_string (p
);
146 else if (NILP (Vuser_full_name
))
147 Vuser_full_name
= build_string ("unknown");
149 #ifdef HAVE_SYS_UTSNAME_H
153 Voperating_system_release
= build_string (uts
.release
);
156 Voperating_system_release
= Qnil
;
160 DEFUN ("char-to-string", Fchar_to_string
, Schar_to_string
, 1, 1, 0,
161 doc
: /* Convert arg CHAR to a string containing that character.
162 usage: (char-to-string CHAR) */)
163 (Lisp_Object character
)
166 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
168 CHECK_CHARACTER (character
);
169 c
= XFASTINT (character
);
171 len
= CHAR_STRING (c
, str
);
172 return make_string_from_bytes ((char *) str
, 1, len
);
175 DEFUN ("byte-to-string", Fbyte_to_string
, Sbyte_to_string
, 1, 1, 0,
176 doc
: /* Convert arg BYTE to a unibyte string containing that byte. */)
181 if (XINT (byte
) < 0 || XINT (byte
) > 255)
182 error ("Invalid byte");
184 return make_string_from_bytes ((char *) &b
, 1, 1);
187 DEFUN ("string-to-char", Fstring_to_char
, Sstring_to_char
, 1, 1, 0,
188 doc
: /* Return the first character in STRING. */)
189 (register Lisp_Object string
)
191 register Lisp_Object val
;
192 CHECK_STRING (string
);
195 if (STRING_MULTIBYTE (string
))
196 XSETFASTINT (val
, STRING_CHAR (SDATA (string
)));
198 XSETFASTINT (val
, SREF (string
, 0));
201 XSETFASTINT (val
, 0);
206 buildmark (EMACS_INT charpos
, EMACS_INT bytepos
)
208 register Lisp_Object mark
;
209 mark
= Fmake_marker ();
210 set_marker_both (mark
, Qnil
, charpos
, bytepos
);
214 DEFUN ("point", Fpoint
, Spoint
, 0, 0, 0,
215 doc
: /* Return value of point, as an integer.
216 Beginning of buffer is position (point-min). */)
220 XSETFASTINT (temp
, PT
);
224 DEFUN ("point-marker", Fpoint_marker
, Spoint_marker
, 0, 0, 0,
225 doc
: /* Return value of point, as a marker object. */)
228 return buildmark (PT
, PT_BYTE
);
232 clip_to_bounds (EMACS_INT lower
, EMACS_INT num
, EMACS_INT upper
)
236 else if (num
> upper
)
242 DEFUN ("goto-char", Fgoto_char
, Sgoto_char
, 1, 1, "NGoto char: ",
243 doc
: /* Set point to POSITION, a number or marker.
244 Beginning of buffer is position (point-min), end is (point-max).
246 The return value is POSITION. */)
247 (register Lisp_Object position
)
251 if (MARKERP (position
)
252 && current_buffer
== XMARKER (position
)->buffer
)
254 pos
= marker_position (position
);
256 SET_PT_BOTH (BEGV
, BEGV_BYTE
);
258 SET_PT_BOTH (ZV
, ZV_BYTE
);
260 SET_PT_BOTH (pos
, marker_byte_position (position
));
265 CHECK_NUMBER_COERCE_MARKER (position
);
267 pos
= clip_to_bounds (BEGV
, XINT (position
), ZV
);
273 /* Return the start or end position of the region.
274 BEGINNINGP non-zero means return the start.
275 If there is no region active, signal an error. */
278 region_limit (int beginningp
)
282 if (!NILP (Vtransient_mark_mode
)
283 && NILP (Vmark_even_if_inactive
)
284 && NILP (BVAR (current_buffer
, mark_active
)))
285 xsignal0 (Qmark_inactive
);
287 m
= Fmarker_position (BVAR (current_buffer
, mark
));
289 error ("The mark is not set now, so there is no region");
291 if ((PT
< XFASTINT (m
)) == (beginningp
!= 0))
292 m
= make_number (PT
);
296 DEFUN ("region-beginning", Fregion_beginning
, Sregion_beginning
, 0, 0, 0,
297 doc
: /* Return the integer value of point or mark, whichever is smaller. */)
300 return region_limit (1);
303 DEFUN ("region-end", Fregion_end
, Sregion_end
, 0, 0, 0,
304 doc
: /* Return the integer value of point or mark, whichever is larger. */)
307 return region_limit (0);
310 DEFUN ("mark-marker", Fmark_marker
, Smark_marker
, 0, 0, 0,
311 doc
: /* Return this buffer's mark, as a marker object.
312 Watch out! Moving this marker changes the mark position.
313 If you set the marker not to point anywhere, the buffer will have no mark. */)
316 return BVAR (current_buffer
, mark
);
320 /* Find all the overlays in the current buffer that touch position POS.
321 Return the number found, and store them in a vector in VEC
325 overlays_around (EMACS_INT pos
, Lisp_Object
*vec
, ptrdiff_t len
)
327 Lisp_Object overlay
, start
, end
;
328 struct Lisp_Overlay
*tail
;
329 EMACS_INT startpos
, endpos
;
332 for (tail
= current_buffer
->overlays_before
; tail
; tail
= tail
->next
)
334 XSETMISC (overlay
, tail
);
336 end
= OVERLAY_END (overlay
);
337 endpos
= OVERLAY_POSITION (end
);
340 start
= OVERLAY_START (overlay
);
341 startpos
= OVERLAY_POSITION (start
);
346 /* Keep counting overlays even if we can't return them all. */
351 for (tail
= current_buffer
->overlays_after
; tail
; tail
= tail
->next
)
353 XSETMISC (overlay
, tail
);
355 start
= OVERLAY_START (overlay
);
356 startpos
= OVERLAY_POSITION (start
);
359 end
= OVERLAY_END (overlay
);
360 endpos
= OVERLAY_POSITION (end
);
372 /* Return the value of property PROP, in OBJECT at POSITION.
373 It's the value of PROP that a char inserted at POSITION would get.
374 OBJECT is optional and defaults to the current buffer.
375 If OBJECT is a buffer, then overlay properties are considered as well as
377 If OBJECT is a window, then that window's buffer is used, but
378 window-specific overlays are considered only if they are associated
381 get_pos_property (Lisp_Object position
, register Lisp_Object prop
, Lisp_Object object
)
383 CHECK_NUMBER_COERCE_MARKER (position
);
386 XSETBUFFER (object
, current_buffer
);
387 else if (WINDOWP (object
))
388 object
= XWINDOW (object
)->buffer
;
390 if (!BUFFERP (object
))
391 /* pos-property only makes sense in buffers right now, since strings
392 have no overlays and no notion of insertion for which stickiness
394 return Fget_text_property (position
, prop
, object
);
397 EMACS_INT posn
= XINT (position
);
399 Lisp_Object
*overlay_vec
, tem
;
400 struct buffer
*obuf
= current_buffer
;
402 set_buffer_temp (XBUFFER (object
));
404 /* First try with room for 40 overlays. */
406 overlay_vec
= (Lisp_Object
*) alloca (noverlays
* sizeof (Lisp_Object
));
407 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
409 /* If there are more than 40,
410 make enough space for all, and try again. */
413 overlay_vec
= (Lisp_Object
*) alloca (noverlays
* sizeof (Lisp_Object
));
414 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
416 noverlays
= sort_overlays (overlay_vec
, noverlays
, NULL
);
418 set_buffer_temp (obuf
);
420 /* Now check the overlays in order of decreasing priority. */
421 while (--noverlays
>= 0)
423 Lisp_Object ol
= overlay_vec
[noverlays
];
424 tem
= Foverlay_get (ol
, prop
);
427 /* Check the overlay is indeed active at point. */
428 Lisp_Object start
= OVERLAY_START (ol
), finish
= OVERLAY_END (ol
);
429 if ((OVERLAY_POSITION (start
) == posn
430 && XMARKER (start
)->insertion_type
== 1)
431 || (OVERLAY_POSITION (finish
) == posn
432 && XMARKER (finish
)->insertion_type
== 0))
433 ; /* The overlay will not cover a char inserted at point. */
441 { /* Now check the text properties. */
442 int stickiness
= text_property_stickiness (prop
, position
, object
);
444 return Fget_text_property (position
, prop
, object
);
445 else if (stickiness
< 0
446 && XINT (position
) > BUF_BEGV (XBUFFER (object
)))
447 return Fget_text_property (make_number (XINT (position
) - 1),
455 /* Find the field surrounding POS in *BEG and *END. If POS is nil,
456 the value of point is used instead. If BEG or END is null,
457 means don't store the beginning or end of the field.
459 BEG_LIMIT and END_LIMIT serve to limit the ranged of the returned
460 results; they do not effect boundary behavior.
462 If MERGE_AT_BOUNDARY is nonzero, then if POS is at the very first
463 position of a field, then the beginning of the previous field is
464 returned instead of the beginning of POS's field (since the end of a
465 field is actually also the beginning of the next input field, this
466 behavior is sometimes useful). Additionally in the MERGE_AT_BOUNDARY
467 true case, if two fields are separated by a field with the special
468 value `boundary', and POS lies within it, then the two separated
469 fields are considered to be adjacent, and POS between them, when
470 finding the beginning and ending of the "merged" field.
472 Either BEG or END may be 0, in which case the corresponding value
476 find_field (Lisp_Object pos
, Lisp_Object merge_at_boundary
,
477 Lisp_Object beg_limit
,
478 EMACS_INT
*beg
, Lisp_Object end_limit
, EMACS_INT
*end
)
480 /* Fields right before and after the point. */
481 Lisp_Object before_field
, after_field
;
482 /* 1 if POS counts as the start of a field. */
483 int at_field_start
= 0;
484 /* 1 if POS counts as the end of a field. */
485 int at_field_end
= 0;
488 XSETFASTINT (pos
, PT
);
490 CHECK_NUMBER_COERCE_MARKER (pos
);
493 = get_char_property_and_overlay (pos
, Qfield
, Qnil
, NULL
);
495 = (XFASTINT (pos
) > BEGV
496 ? get_char_property_and_overlay (make_number (XINT (pos
) - 1),
498 /* Using nil here would be a more obvious choice, but it would
499 fail when the buffer starts with a non-sticky field. */
502 /* See if we need to handle the case where MERGE_AT_BOUNDARY is nil
503 and POS is at beginning of a field, which can also be interpreted
504 as the end of the previous field. Note that the case where if
505 MERGE_AT_BOUNDARY is non-nil (see function comment) is actually the
506 more natural one; then we avoid treating the beginning of a field
508 if (NILP (merge_at_boundary
))
510 Lisp_Object field
= get_pos_property (pos
, Qfield
, Qnil
);
511 if (!EQ (field
, after_field
))
513 if (!EQ (field
, before_field
))
515 if (NILP (field
) && at_field_start
&& at_field_end
)
516 /* If an inserted char would have a nil field while the surrounding
517 text is non-nil, we're probably not looking at a
518 zero-length field, but instead at a non-nil field that's
519 not intended for editing (such as comint's prompts). */
520 at_field_end
= at_field_start
= 0;
523 /* Note about special `boundary' fields:
525 Consider the case where the point (`.') is between the fields `x' and `y':
529 In this situation, if merge_at_boundary is true, we consider the
530 `x' and `y' fields as forming one big merged field, and so the end
531 of the field is the end of `y'.
533 However, if `x' and `y' are separated by a special `boundary' field
534 (a field with a `field' char-property of 'boundary), then we ignore
535 this special field when merging adjacent fields. Here's the same
536 situation, but with a `boundary' field between the `x' and `y' fields:
540 Here, if point is at the end of `x', the beginning of `y', or
541 anywhere in-between (within the `boundary' field), we merge all
542 three fields and consider the beginning as being the beginning of
543 the `x' field, and the end as being the end of the `y' field. */
548 /* POS is at the edge of a field, and we should consider it as
549 the beginning of the following field. */
550 *beg
= XFASTINT (pos
);
552 /* Find the previous field boundary. */
555 if (!NILP (merge_at_boundary
) && EQ (before_field
, Qboundary
))
556 /* Skip a `boundary' field. */
557 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
560 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
562 *beg
= NILP (p
) ? BEGV
: XFASTINT (p
);
569 /* POS is at the edge of a field, and we should consider it as
570 the end of the previous field. */
571 *end
= XFASTINT (pos
);
573 /* Find the next field boundary. */
575 if (!NILP (merge_at_boundary
) && EQ (after_field
, Qboundary
))
576 /* Skip a `boundary' field. */
577 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
580 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
582 *end
= NILP (pos
) ? ZV
: XFASTINT (pos
);
588 DEFUN ("delete-field", Fdelete_field
, Sdelete_field
, 0, 1, 0,
589 doc
: /* Delete the field surrounding POS.
590 A field is a region of text with the same `field' property.
591 If POS is nil, the value of point is used for POS. */)
595 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
597 del_range (beg
, end
);
601 DEFUN ("field-string", Ffield_string
, Sfield_string
, 0, 1, 0,
602 doc
: /* Return the contents of the field surrounding POS as a string.
603 A field is a region of text with the same `field' property.
604 If POS is nil, the value of point is used for POS. */)
608 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
609 return make_buffer_string (beg
, end
, 1);
612 DEFUN ("field-string-no-properties", Ffield_string_no_properties
, Sfield_string_no_properties
, 0, 1, 0,
613 doc
: /* Return the contents of the field around POS, without text properties.
614 A field is a region of text with the same `field' property.
615 If POS is nil, the value of point is used for POS. */)
619 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
620 return make_buffer_string (beg
, end
, 0);
623 DEFUN ("field-beginning", Ffield_beginning
, Sfield_beginning
, 0, 3, 0,
624 doc
: /* Return the beginning of the field surrounding POS.
625 A field is a region of text with the same `field' property.
626 If POS is nil, the value of point is used for POS.
627 If ESCAPE-FROM-EDGE is non-nil and POS is at the beginning of its
628 field, then the beginning of the *previous* field is returned.
629 If LIMIT is non-nil, it is a buffer position; if the beginning of the field
630 is before LIMIT, then LIMIT will be returned instead. */)
631 (Lisp_Object pos
, Lisp_Object escape_from_edge
, Lisp_Object limit
)
634 find_field (pos
, escape_from_edge
, limit
, &beg
, Qnil
, 0);
635 return make_number (beg
);
638 DEFUN ("field-end", Ffield_end
, Sfield_end
, 0, 3, 0,
639 doc
: /* Return the end of the field surrounding POS.
640 A field is a region of text with the same `field' property.
641 If POS is nil, the value of point is used for POS.
642 If ESCAPE-FROM-EDGE is non-nil and POS is at the end of its field,
643 then the end of the *following* field is returned.
644 If LIMIT is non-nil, it is a buffer position; if the end of the field
645 is after LIMIT, then LIMIT will be returned instead. */)
646 (Lisp_Object pos
, Lisp_Object escape_from_edge
, Lisp_Object limit
)
649 find_field (pos
, escape_from_edge
, Qnil
, 0, limit
, &end
);
650 return make_number (end
);
653 DEFUN ("constrain-to-field", Fconstrain_to_field
, Sconstrain_to_field
, 2, 5, 0,
654 doc
: /* Return the position closest to NEW-POS that is in the same field as OLD-POS.
655 A field is a region of text with the same `field' property.
657 If NEW-POS is nil, then use the current point instead, and move point
658 to the resulting constrained position, in addition to returning that
661 If OLD-POS is at the boundary of two fields, then the allowable
662 positions for NEW-POS depends on the value of the optional argument
663 ESCAPE-FROM-EDGE: If ESCAPE-FROM-EDGE is nil, then NEW-POS is
664 constrained to the field that has the same `field' char-property
665 as any new characters inserted at OLD-POS, whereas if ESCAPE-FROM-EDGE
666 is non-nil, NEW-POS is constrained to the union of the two adjacent
667 fields. Additionally, if two fields are separated by another field with
668 the special value `boundary', then any point within this special field is
669 also considered to be `on the boundary'.
671 If the optional argument ONLY-IN-LINE is non-nil and constraining
672 NEW-POS would move it to a different line, NEW-POS is returned
673 unconstrained. This useful for commands that move by line, like
674 \\[next-line] or \\[beginning-of-line], which should generally respect field boundaries
675 only in the case where they can still move to the right line.
677 If the optional argument INHIBIT-CAPTURE-PROPERTY is non-nil, and OLD-POS has
678 a non-nil property of that name, then any field boundaries are ignored.
680 Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */)
681 (Lisp_Object new_pos
, Lisp_Object old_pos
, Lisp_Object escape_from_edge
, Lisp_Object only_in_line
, Lisp_Object inhibit_capture_property
)
683 /* If non-zero, then the original point, before re-positioning. */
684 EMACS_INT orig_point
= 0;
686 Lisp_Object prev_old
, prev_new
;
689 /* Use the current point, and afterwards, set it. */
692 XSETFASTINT (new_pos
, PT
);
695 CHECK_NUMBER_COERCE_MARKER (new_pos
);
696 CHECK_NUMBER_COERCE_MARKER (old_pos
);
698 fwd
= (XFASTINT (new_pos
) > XFASTINT (old_pos
));
700 prev_old
= make_number (XFASTINT (old_pos
) - 1);
701 prev_new
= make_number (XFASTINT (new_pos
) - 1);
703 if (NILP (Vinhibit_field_text_motion
)
704 && !EQ (new_pos
, old_pos
)
705 && (!NILP (Fget_char_property (new_pos
, Qfield
, Qnil
))
706 || !NILP (Fget_char_property (old_pos
, Qfield
, Qnil
))
707 /* To recognize field boundaries, we must also look at the
708 previous positions; we could use `get_pos_property'
709 instead, but in itself that would fail inside non-sticky
710 fields (like comint prompts). */
711 || (XFASTINT (new_pos
) > BEGV
712 && !NILP (Fget_char_property (prev_new
, Qfield
, Qnil
)))
713 || (XFASTINT (old_pos
) > BEGV
714 && !NILP (Fget_char_property (prev_old
, Qfield
, Qnil
))))
715 && (NILP (inhibit_capture_property
)
716 /* Field boundaries are again a problem; but now we must
717 decide the case exactly, so we need to call
718 `get_pos_property' as well. */
719 || (NILP (get_pos_property (old_pos
, inhibit_capture_property
, Qnil
))
720 && (XFASTINT (old_pos
) <= BEGV
721 || NILP (Fget_char_property (old_pos
, inhibit_capture_property
, Qnil
))
722 || NILP (Fget_char_property (prev_old
, inhibit_capture_property
, Qnil
))))))
723 /* It is possible that NEW_POS is not within the same field as
724 OLD_POS; try to move NEW_POS so that it is. */
727 Lisp_Object field_bound
;
730 field_bound
= Ffield_end (old_pos
, escape_from_edge
, new_pos
);
732 field_bound
= Ffield_beginning (old_pos
, escape_from_edge
, new_pos
);
734 if (/* See if ESCAPE_FROM_EDGE caused FIELD_BOUND to jump to the
735 other side of NEW_POS, which would mean that NEW_POS is
736 already acceptable, and it's not necessary to constrain it
738 ((XFASTINT (field_bound
) < XFASTINT (new_pos
)) ? fwd
: !fwd
)
739 /* NEW_POS should be constrained, but only if either
740 ONLY_IN_LINE is nil (in which case any constraint is OK),
741 or NEW_POS and FIELD_BOUND are on the same line (in which
742 case the constraint is OK even if ONLY_IN_LINE is non-nil). */
743 && (NILP (only_in_line
)
744 /* This is the ONLY_IN_LINE case, check that NEW_POS and
745 FIELD_BOUND are on the same line by seeing whether
746 there's an intervening newline or not. */
747 || (scan_buffer ('\n',
748 XFASTINT (new_pos
), XFASTINT (field_bound
),
749 fwd
? -1 : 1, &shortage
, 1),
751 /* Constrain NEW_POS to FIELD_BOUND. */
752 new_pos
= field_bound
;
754 if (orig_point
&& XFASTINT (new_pos
) != orig_point
)
755 /* The NEW_POS argument was originally nil, so automatically set PT. */
756 SET_PT (XFASTINT (new_pos
));
763 DEFUN ("line-beginning-position",
764 Fline_beginning_position
, Sline_beginning_position
, 0, 1, 0,
765 doc
: /* Return the character position of the first character on the current line.
766 With argument N not nil or 1, move forward N - 1 lines first.
767 If scan reaches end of buffer, return that position.
769 The returned position is of the first character in the logical order,
770 i.e. the one that has the smallest character position.
772 This function constrains the returned position to the current field
773 unless that would be on a different line than the original,
774 unconstrained result. If N is nil or 1, and a front-sticky field
775 starts at point, the scan stops as soon as it starts. To ignore field
776 boundaries bind `inhibit-field-text-motion' to t.
778 This function does not move point. */)
781 EMACS_INT orig
, orig_byte
, end
;
782 int count
= SPECPDL_INDEX ();
783 specbind (Qinhibit_point_motion_hooks
, Qt
);
792 Fforward_line (make_number (XINT (n
) - 1));
795 SET_PT_BOTH (orig
, orig_byte
);
797 unbind_to (count
, Qnil
);
799 /* Return END constrained to the current input field. */
800 return Fconstrain_to_field (make_number (end
), make_number (orig
),
801 XINT (n
) != 1 ? Qt
: Qnil
,
805 DEFUN ("line-end-position", Fline_end_position
, Sline_end_position
, 0, 1, 0,
806 doc
: /* Return the character position of the last character on the current line.
807 With argument N not nil or 1, move forward N - 1 lines first.
808 If scan reaches end of buffer, return that position.
810 The returned position is of the last character in the logical order,
811 i.e. the character whose buffer position is the largest one.
813 This function constrains the returned position to the current field
814 unless that would be on a different line than the original,
815 unconstrained result. If N is nil or 1, and a rear-sticky field ends
816 at point, the scan stops as soon as it starts. To ignore field
817 boundaries bind `inhibit-field-text-motion' to t.
819 This function does not move point. */)
830 end_pos
= find_before_next_newline (orig
, 0, XINT (n
) - (XINT (n
) <= 0));
832 /* Return END_POS constrained to the current input field. */
833 return Fconstrain_to_field (make_number (end_pos
), make_number (orig
),
839 save_excursion_save (void)
841 int visible
= (XBUFFER (XWINDOW (selected_window
)->buffer
)
844 return Fcons (Fpoint_marker (),
845 Fcons (Fcopy_marker (BVAR (current_buffer
, mark
), Qnil
),
846 Fcons (visible
? Qt
: Qnil
,
847 Fcons (BVAR (current_buffer
, mark_active
),
852 save_excursion_restore (Lisp_Object info
)
854 Lisp_Object tem
, tem1
, omark
, nmark
;
855 struct gcpro gcpro1
, gcpro2
, gcpro3
;
858 tem
= Fmarker_buffer (XCAR (info
));
859 /* If buffer being returned to is now deleted, avoid error */
860 /* Otherwise could get error here while unwinding to top level
862 /* In that case, Fmarker_buffer returns nil now. */
866 omark
= nmark
= Qnil
;
867 GCPRO3 (info
, omark
, nmark
);
874 unchain_marker (XMARKER (tem
));
879 omark
= Fmarker_position (BVAR (current_buffer
, mark
));
880 Fset_marker (BVAR (current_buffer
, mark
), tem
, Fcurrent_buffer ());
881 nmark
= Fmarker_position (tem
);
882 unchain_marker (XMARKER (tem
));
886 visible_p
= !NILP (XCAR (info
));
888 #if 0 /* We used to make the current buffer visible in the selected window
889 if that was true previously. That avoids some anomalies.
890 But it creates others, and it wasn't documented, and it is simpler
891 and cleaner never to alter the window/buffer connections. */
894 && current_buffer
!= XBUFFER (XWINDOW (selected_window
)->buffer
))
895 Fswitch_to_buffer (Fcurrent_buffer (), Qnil
);
901 tem1
= BVAR (current_buffer
, mark_active
);
902 BVAR (current_buffer
, mark_active
) = tem
;
904 /* If mark is active now, and either was not active
905 or was at a different place, run the activate hook. */
908 if (! EQ (omark
, nmark
))
910 tem
= intern ("activate-mark-hook");
911 Frun_hooks (1, &tem
);
914 /* If mark has ceased to be active, run deactivate hook. */
915 else if (! NILP (tem1
))
917 tem
= intern ("deactivate-mark-hook");
918 Frun_hooks (1, &tem
);
921 /* If buffer was visible in a window, and a different window was
922 selected, and the old selected window is still showing this
923 buffer, restore point in that window. */
926 && !EQ (tem
, selected_window
)
927 && (tem1
= XWINDOW (tem
)->buffer
,
928 (/* Window is live... */
930 /* ...and it shows the current buffer. */
931 && XBUFFER (tem1
) == current_buffer
)))
932 Fset_window_point (tem
, make_number (PT
));
938 DEFUN ("save-excursion", Fsave_excursion
, Ssave_excursion
, 0, UNEVALLED
, 0,
939 doc
: /* Save point, mark, and current buffer; execute BODY; restore those things.
940 Executes BODY just like `progn'.
941 The values of point, mark and the current buffer are restored
942 even in case of abnormal exit (throw or error).
943 The state of activation of the mark is also restored.
945 This construct does not save `deactivate-mark', and therefore
946 functions that change the buffer will still cause deactivation
947 of the mark at the end of the command. To prevent that, bind
948 `deactivate-mark' with `let'.
950 If you only want to save the current buffer but not point nor mark,
951 then just use `save-current-buffer', or even `with-current-buffer'.
953 usage: (save-excursion &rest BODY) */)
956 register Lisp_Object val
;
957 int count
= SPECPDL_INDEX ();
959 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
962 return unbind_to (count
, val
);
965 DEFUN ("save-current-buffer", Fsave_current_buffer
, Ssave_current_buffer
, 0, UNEVALLED
, 0,
966 doc
: /* Save the current buffer; execute BODY; restore the current buffer.
967 Executes BODY just like `progn'.
968 usage: (save-current-buffer &rest BODY) */)
972 int count
= SPECPDL_INDEX ();
974 record_unwind_protect (set_buffer_if_live
, Fcurrent_buffer ());
977 return unbind_to (count
, val
);
980 DEFUN ("buffer-size", Fbufsize
, Sbufsize
, 0, 1, 0,
981 doc
: /* Return the number of characters in the current buffer.
982 If BUFFER, return the number of characters in that buffer instead. */)
986 return make_number (Z
- BEG
);
989 CHECK_BUFFER (buffer
);
990 return make_number (BUF_Z (XBUFFER (buffer
))
991 - BUF_BEG (XBUFFER (buffer
)));
995 DEFUN ("point-min", Fpoint_min
, Spoint_min
, 0, 0, 0,
996 doc
: /* Return the minimum permissible value of point in the current buffer.
997 This is 1, unless narrowing (a buffer restriction) is in effect. */)
1001 XSETFASTINT (temp
, BEGV
);
1005 DEFUN ("point-min-marker", Fpoint_min_marker
, Spoint_min_marker
, 0, 0, 0,
1006 doc
: /* Return a marker to the minimum permissible value of point in this buffer.
1007 This is the beginning, unless narrowing (a buffer restriction) is in effect. */)
1010 return buildmark (BEGV
, BEGV_BYTE
);
1013 DEFUN ("point-max", Fpoint_max
, Spoint_max
, 0, 0, 0,
1014 doc
: /* Return the maximum permissible value of point in the current buffer.
1015 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1016 is in effect, in which case it is less. */)
1020 XSETFASTINT (temp
, ZV
);
1024 DEFUN ("point-max-marker", Fpoint_max_marker
, Spoint_max_marker
, 0, 0, 0,
1025 doc
: /* Return a marker to the maximum permissible value of point in this buffer.
1026 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1027 is in effect, in which case it is less. */)
1030 return buildmark (ZV
, ZV_BYTE
);
1033 DEFUN ("gap-position", Fgap_position
, Sgap_position
, 0, 0, 0,
1034 doc
: /* Return the position of the gap, in the current buffer.
1035 See also `gap-size'. */)
1039 XSETFASTINT (temp
, GPT
);
1043 DEFUN ("gap-size", Fgap_size
, Sgap_size
, 0, 0, 0,
1044 doc
: /* Return the size of the current buffer's gap.
1045 See also `gap-position'. */)
1049 XSETFASTINT (temp
, GAP_SIZE
);
1053 DEFUN ("position-bytes", Fposition_bytes
, Sposition_bytes
, 1, 1, 0,
1054 doc
: /* Return the byte position for character position POSITION.
1055 If POSITION is out of range, the value is nil. */)
1056 (Lisp_Object position
)
1058 CHECK_NUMBER_COERCE_MARKER (position
);
1059 if (XINT (position
) < BEG
|| XINT (position
) > Z
)
1061 return make_number (CHAR_TO_BYTE (XINT (position
)));
1064 DEFUN ("byte-to-position", Fbyte_to_position
, Sbyte_to_position
, 1, 1, 0,
1065 doc
: /* Return the character position for byte position BYTEPOS.
1066 If BYTEPOS is out of range, the value is nil. */)
1067 (Lisp_Object bytepos
)
1069 CHECK_NUMBER (bytepos
);
1070 if (XINT (bytepos
) < BEG_BYTE
|| XINT (bytepos
) > Z_BYTE
)
1072 return make_number (BYTE_TO_CHAR (XINT (bytepos
)));
1075 DEFUN ("following-char", Ffollowing_char
, Sfollowing_char
, 0, 0, 0,
1076 doc
: /* Return the character following point, as a number.
1077 At the end of the buffer or accessible region, return 0. */)
1082 XSETFASTINT (temp
, 0);
1084 XSETFASTINT (temp
, FETCH_CHAR (PT_BYTE
));
1088 DEFUN ("preceding-char", Fprevious_char
, Sprevious_char
, 0, 0, 0,
1089 doc
: /* Return the character preceding point, as a number.
1090 At the beginning of the buffer or accessible region, return 0. */)
1095 XSETFASTINT (temp
, 0);
1096 else if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
1098 EMACS_INT pos
= PT_BYTE
;
1100 XSETFASTINT (temp
, FETCH_CHAR (pos
));
1103 XSETFASTINT (temp
, FETCH_BYTE (PT_BYTE
- 1));
1107 DEFUN ("bobp", Fbobp
, Sbobp
, 0, 0, 0,
1108 doc
: /* Return t if point is at the beginning of the buffer.
1109 If the buffer is narrowed, this means the beginning of the narrowed part. */)
1117 DEFUN ("eobp", Feobp
, Seobp
, 0, 0, 0,
1118 doc
: /* Return t if point is at the end of the buffer.
1119 If the buffer is narrowed, this means the end of the narrowed part. */)
1127 DEFUN ("bolp", Fbolp
, Sbolp
, 0, 0, 0,
1128 doc
: /* Return t if point is at the beginning of a line. */)
1131 if (PT
== BEGV
|| FETCH_BYTE (PT_BYTE
- 1) == '\n')
1136 DEFUN ("eolp", Feolp
, Seolp
, 0, 0, 0,
1137 doc
: /* Return t if point is at the end of a line.
1138 `End of a line' includes point being at the end of the buffer. */)
1141 if (PT
== ZV
|| FETCH_BYTE (PT_BYTE
) == '\n')
1146 DEFUN ("char-after", Fchar_after
, Schar_after
, 0, 1, 0,
1147 doc
: /* Return character in current buffer at position POS.
1148 POS is an integer or a marker and defaults to point.
1149 If POS is out of range, the value is nil. */)
1152 register EMACS_INT pos_byte
;
1157 XSETFASTINT (pos
, PT
);
1162 pos_byte
= marker_byte_position (pos
);
1163 if (pos_byte
< BEGV_BYTE
|| pos_byte
>= ZV_BYTE
)
1168 CHECK_NUMBER_COERCE_MARKER (pos
);
1169 if (XINT (pos
) < BEGV
|| XINT (pos
) >= ZV
)
1172 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1175 return make_number (FETCH_CHAR (pos_byte
));
1178 DEFUN ("char-before", Fchar_before
, Schar_before
, 0, 1, 0,
1179 doc
: /* Return character in current buffer preceding position POS.
1180 POS is an integer or a marker and defaults to point.
1181 If POS is out of range, the value is nil. */)
1184 register Lisp_Object val
;
1185 register EMACS_INT pos_byte
;
1190 XSETFASTINT (pos
, PT
);
1195 pos_byte
= marker_byte_position (pos
);
1197 if (pos_byte
<= BEGV_BYTE
|| pos_byte
> ZV_BYTE
)
1202 CHECK_NUMBER_COERCE_MARKER (pos
);
1204 if (XINT (pos
) <= BEGV
|| XINT (pos
) > ZV
)
1207 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1210 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
1213 XSETFASTINT (val
, FETCH_CHAR (pos_byte
));
1218 XSETFASTINT (val
, FETCH_BYTE (pos_byte
));
1223 DEFUN ("user-login-name", Fuser_login_name
, Suser_login_name
, 0, 1, 0,
1224 doc
: /* Return the name under which the user logged in, as a string.
1225 This is based on the effective uid, not the real uid.
1226 Also, if the environment variables LOGNAME or USER are set,
1227 that determines the value of this function.
1229 If optional argument UID is an integer or a float, return the login name
1230 of the user with that uid, or nil if there is no such user. */)
1236 /* Set up the user name info if we didn't do it before.
1237 (That can happen if Emacs is dumpable
1238 but you decide to run `temacs -l loadup' and not dump. */
1239 if (INTEGERP (Vuser_login_name
))
1243 return Vuser_login_name
;
1245 id
= XFLOATINT (uid
);
1249 return (pw
? build_string (pw
->pw_name
) : Qnil
);
1252 DEFUN ("user-real-login-name", Fuser_real_login_name
, Suser_real_login_name
,
1254 doc
: /* Return the name of the user's real uid, as a string.
1255 This ignores the environment variables LOGNAME and USER, so it differs from
1256 `user-login-name' when running under `su'. */)
1259 /* Set up the user name info if we didn't do it before.
1260 (That can happen if Emacs is dumpable
1261 but you decide to run `temacs -l loadup' and not dump. */
1262 if (INTEGERP (Vuser_login_name
))
1264 return Vuser_real_login_name
;
1267 DEFUN ("user-uid", Fuser_uid
, Suser_uid
, 0, 0, 0,
1268 doc
: /* Return the effective uid of Emacs.
1269 Value is an integer or a float, depending on the value. */)
1272 /* Assignment to EMACS_INT stops GCC whining about limited range of
1274 EMACS_INT euid
= geteuid ();
1276 /* Make sure we don't produce a negative UID due to signed integer
1279 return make_float (geteuid ());
1280 return make_fixnum_or_float (euid
);
1283 DEFUN ("user-real-uid", Fuser_real_uid
, Suser_real_uid
, 0, 0, 0,
1284 doc
: /* Return the real uid of Emacs.
1285 Value is an integer or a float, depending on the value. */)
1288 /* Assignment to EMACS_INT stops GCC whining about limited range of
1290 EMACS_INT uid
= getuid ();
1292 /* Make sure we don't produce a negative UID due to signed integer
1295 return make_float (getuid ());
1296 return make_fixnum_or_float (uid
);
1299 DEFUN ("user-full-name", Fuser_full_name
, Suser_full_name
, 0, 1, 0,
1300 doc
: /* Return the full name of the user logged in, as a string.
1301 If the full name corresponding to Emacs's userid is not known,
1304 If optional argument UID is an integer or float, return the full name
1305 of the user with that uid, or nil if there is no such user.
1306 If UID is a string, return the full name of the user with that login
1307 name, or nil if there is no such user. */)
1311 register char *p
, *q
;
1315 return Vuser_full_name
;
1316 else if (NUMBERP (uid
))
1318 uid_t u
= XFLOATINT (uid
);
1323 else if (STRINGP (uid
))
1326 pw
= getpwnam (SSDATA (uid
));
1330 error ("Invalid UID specification");
1336 /* Chop off everything after the first comma. */
1337 q
= strchr (p
, ',');
1338 full
= make_string (p
, q
? q
- p
: strlen (p
));
1340 #ifdef AMPERSAND_FULL_NAME
1342 q
= strchr (p
, '&');
1343 /* Substitute the login name for the &, upcasing the first character. */
1349 login
= Fuser_login_name (make_number (pw
->pw_uid
));
1350 r
= (char *) alloca (strlen (p
) + SCHARS (login
) + 1);
1351 memcpy (r
, p
, q
- p
);
1353 strcat (r
, SSDATA (login
));
1354 r
[q
- p
] = upcase ((unsigned char) r
[q
- p
]);
1356 full
= build_string (r
);
1358 #endif /* AMPERSAND_FULL_NAME */
1363 DEFUN ("system-name", Fsystem_name
, Ssystem_name
, 0, 0, 0,
1364 doc
: /* Return the host name of the machine you are running on, as a string. */)
1367 return Vsystem_name
;
1371 get_system_name (void)
1373 if (STRINGP (Vsystem_name
))
1374 return SSDATA (Vsystem_name
);
1379 DEFUN ("emacs-pid", Femacs_pid
, Semacs_pid
, 0, 0, 0,
1380 doc
: /* Return the process ID of Emacs, as an integer. */)
1383 return make_number (getpid ());
1389 # define TIME_T_MIN TYPE_MINIMUM (time_t)
1392 # define TIME_T_MAX TYPE_MAXIMUM (time_t)
1395 /* Report that a time value is out of range for Emacs. */
1397 time_overflow (void)
1399 error ("Specified time is not representable");
1402 /* Return the upper part of the time T (everything but the bottom 16 bits),
1403 making sure that it is representable. */
1407 time_t hi
= t
>> 16;
1409 /* Check for overflow, helping the compiler for common cases where
1410 no runtime check is needed, and taking care not to convert
1411 negative numbers to unsigned before comparing them. */
1412 if (! ((! TYPE_SIGNED (time_t)
1413 || MOST_NEGATIVE_FIXNUM
<= TIME_T_MIN
>> 16
1414 || MOST_NEGATIVE_FIXNUM
<= hi
)
1415 && (TIME_T_MAX
>> 16 <= MOST_POSITIVE_FIXNUM
1416 || hi
<= MOST_POSITIVE_FIXNUM
)))
1422 /* Return the bottom 16 bits of the time T. */
1426 return t
& ((1 << 16) - 1);
1429 DEFUN ("current-time", Fcurrent_time
, Scurrent_time
, 0, 0, 0,
1430 doc
: /* Return the current time, as the number of seconds since 1970-01-01 00:00:00.
1431 The time is returned as a list of three integers. The first has the
1432 most significant 16 bits of the seconds, while the second has the
1433 least significant 16 bits. The third integer gives the microsecond
1436 The microsecond count is zero on systems that do not provide
1437 resolution finer than a second. */)
1443 return list3 (make_number (hi_time (EMACS_SECS (t
))),
1444 make_number (lo_time (EMACS_SECS (t
))),
1445 make_number (EMACS_USECS (t
)));
1448 DEFUN ("get-internal-run-time", Fget_internal_run_time
, Sget_internal_run_time
,
1450 doc
: /* Return the current run time used by Emacs.
1451 The time is returned as a list of three integers. The first has the
1452 most significant 16 bits of the seconds, while the second has the
1453 least significant 16 bits. The third integer gives the microsecond
1456 On systems that can't determine the run time, `get-internal-run-time'
1457 does the same thing as `current-time'. The microsecond count is zero
1458 on systems that do not provide resolution finer than a second. */)
1461 #ifdef HAVE_GETRUSAGE
1462 struct rusage usage
;
1466 if (getrusage (RUSAGE_SELF
, &usage
) < 0)
1467 /* This shouldn't happen. What action is appropriate? */
1470 /* Sum up user time and system time. */
1471 secs
= usage
.ru_utime
.tv_sec
+ usage
.ru_stime
.tv_sec
;
1472 usecs
= usage
.ru_utime
.tv_usec
+ usage
.ru_stime
.tv_usec
;
1473 if (usecs
>= 1000000)
1479 return list3 (make_number (hi_time (secs
)),
1480 make_number (lo_time (secs
)),
1481 make_number (usecs
));
1482 #else /* ! HAVE_GETRUSAGE */
1484 return w32_get_internal_run_time ();
1485 #else /* ! WINDOWSNT */
1486 return Fcurrent_time ();
1487 #endif /* WINDOWSNT */
1488 #endif /* HAVE_GETRUSAGE */
1492 /* Make a Lisp list that represents the time T. */
1494 make_time (time_t t
)
1496 return list2 (make_number (hi_time (t
)),
1497 make_number (lo_time (t
)));
1500 /* Decode a Lisp list SPECIFIED_TIME that represents a time.
1501 If SPECIFIED_TIME is nil, use the current time.
1502 Set *RESULT to seconds since the Epoch.
1503 If USEC is not null, set *USEC to the microseconds component.
1504 Return nonzero if successful. */
1506 lisp_time_argument (Lisp_Object specified_time
, time_t *result
, int *usec
)
1508 if (NILP (specified_time
))
1515 *usec
= EMACS_USECS (t
);
1516 *result
= EMACS_SECS (t
);
1520 return time (result
) != -1;
1524 Lisp_Object high
, low
;
1526 high
= Fcar (specified_time
);
1527 CHECK_NUMBER (high
);
1528 low
= Fcdr (specified_time
);
1533 Lisp_Object usec_l
= Fcdr (low
);
1535 usec_l
= Fcar (usec_l
);
1540 CHECK_NUMBER (usec_l
);
1541 *usec
= XINT (usec_l
);
1551 /* Check for overflow, helping the compiler for common cases
1552 where no runtime check is needed, and taking care not to
1553 convert negative numbers to unsigned before comparing them. */
1554 if (! ((TYPE_SIGNED (time_t)
1555 ? (TIME_T_MIN
>> 16 <= MOST_NEGATIVE_FIXNUM
1556 || TIME_T_MIN
>> 16 <= hi
)
1558 && (MOST_POSITIVE_FIXNUM
<= TIME_T_MAX
>> 16
1559 || hi
<= TIME_T_MAX
>> 16)))
1562 *result
= (hi
<< 16) + (XINT (low
) & 0xffff);
1567 DEFUN ("float-time", Ffloat_time
, Sfloat_time
, 0, 1, 0,
1568 doc
: /* Return the current time, as a float number of seconds since the epoch.
1569 If SPECIFIED-TIME is given, it is the time to convert to float
1570 instead of the current time. The argument should have the form
1571 (HIGH LOW) or (HIGH LOW USEC). Thus, you can use times obtained from
1572 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
1573 have the form (HIGH . LOW), but this is considered obsolete.
1575 WARNING: Since the result is floating point, it may not be exact.
1576 If precise time stamps are required, use either `current-time',
1577 or (if you need time as a string) `format-time-string'. */)
1578 (Lisp_Object specified_time
)
1583 if (! lisp_time_argument (specified_time
, &sec
, &usec
))
1584 error ("Invalid time specification");
1586 return make_float ((sec
* 1e6
+ usec
) / 1e6
);
1589 /* Write information into buffer S of size MAXSIZE, according to the
1590 FORMAT of length FORMAT_LEN, using time information taken from *TP.
1591 Default to Universal Time if UT is nonzero, local time otherwise.
1592 Use NS as the number of nanoseconds in the %N directive.
1593 Return the number of bytes written, not including the terminating
1594 '\0'. If S is NULL, nothing will be written anywhere; so to
1595 determine how many bytes would be written, use NULL for S and
1596 ((size_t) -1) for MAXSIZE.
1598 This function behaves like nstrftime, except it allows null
1599 bytes in FORMAT and it does not support nanoseconds. */
1601 emacs_nmemftime (char *s
, size_t maxsize
, const char *format
,
1602 size_t format_len
, const struct tm
*tp
, int ut
, int ns
)
1606 /* Loop through all the null-terminated strings in the format
1607 argument. Normally there's just one null-terminated string, but
1608 there can be arbitrarily many, concatenated together, if the
1609 format contains '\0' bytes. nstrftime stops at the first
1610 '\0' byte so we must invoke it separately for each such string. */
1619 result
= nstrftime (s
, maxsize
, format
, tp
, ut
, ns
);
1623 if (result
== 0 && s
[0] != '\0')
1628 maxsize
-= result
+ 1;
1630 len
= strlen (format
);
1631 if (len
== format_len
)
1635 format_len
-= len
+ 1;
1639 DEFUN ("format-time-string", Fformat_time_string
, Sformat_time_string
, 1, 3, 0,
1640 doc
: /* Use FORMAT-STRING to format the time TIME, or now if omitted.
1641 TIME is specified as (HIGH LOW . IGNORED), as returned by
1642 `current-time' or `file-attributes'. The obsolete form (HIGH . LOW)
1643 is also still accepted.
1644 The third, optional, argument UNIVERSAL, if non-nil, means describe TIME
1645 as Universal Time; nil means describe TIME in the local time zone.
1646 The value is a copy of FORMAT-STRING, but with certain constructs replaced
1647 by text that describes the specified date and time in TIME:
1649 %Y is the year, %y within the century, %C the century.
1650 %G is the year corresponding to the ISO week, %g within the century.
1651 %m is the numeric month.
1652 %b and %h are the locale's abbreviated month name, %B the full name.
1653 %d is the day of the month, zero-padded, %e is blank-padded.
1654 %u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.
1655 %a is the locale's abbreviated name of the day of week, %A the full name.
1656 %U is the week number starting on Sunday, %W starting on Monday,
1657 %V according to ISO 8601.
1658 %j is the day of the year.
1660 %H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H
1661 only blank-padded, %l is like %I blank-padded.
1662 %p is the locale's equivalent of either AM or PM.
1665 %N is the nanosecond, %6N the microsecond, %3N the millisecond, etc.
1666 %Z is the time zone name, %z is the numeric form.
1667 %s is the number of seconds since 1970-01-01 00:00:00 +0000.
1669 %c is the locale's date and time format.
1670 %x is the locale's "preferred" date format.
1671 %D is like "%m/%d/%y".
1673 %R is like "%H:%M", %T is like "%H:%M:%S", %r is like "%I:%M:%S %p".
1674 %X is the locale's "preferred" time format.
1676 Finally, %n is a newline, %t is a tab, %% is a literal %.
1678 Certain flags and modifiers are available with some format controls.
1679 The flags are `_', `-', `^' and `#'. For certain characters X,
1680 %_X is like %X, but padded with blanks; %-X is like %X,
1681 but without padding. %^X is like %X, but with all textual
1682 characters up-cased; %#X is like %X, but with letter-case of
1683 all textual characters reversed.
1684 %NX (where N stands for an integer) is like %X,
1685 but takes up at least N (a number) positions.
1686 The modifiers are `E' and `O'. For certain characters X,
1687 %EX is a locale's alternative version of %X;
1688 %OX is like %X, but uses the locale's number symbols.
1690 For example, to produce full ISO 8601 format, use "%Y-%m-%dT%T%z".
1692 usage: (format-time-string FORMAT-STRING &optional TIME UNIVERSAL) */)
1693 (Lisp_Object format_string
, Lisp_Object timeval
, Lisp_Object universal
)
1698 CHECK_STRING (format_string
);
1699 format_string
= code_convert_string_norecord (format_string
,
1700 Vlocale_coding_system
, 1);
1701 return format_time_string (SSDATA (format_string
), SBYTES (format_string
),
1702 timeval
, ! NILP (universal
), &t
, &tm
);
1706 format_time_string (char const *format
, ptrdiff_t formatlen
,
1707 Lisp_Object timeval
, int ut
, time_t *tval
, struct tm
*tmp
)
1711 size_t size
= sizeof buffer
;
1713 Lisp_Object bufstring
;
1719 if (! (lisp_time_argument (timeval
, tval
, &usec
)
1720 && 0 <= usec
&& usec
< 1000000))
1721 error ("Invalid time specification");
1728 synchronize_system_time_locale ();
1730 tm
= ut
? gmtime (tval
) : localtime (tval
);
1739 len
= emacs_nmemftime (buf
, size
, format
, formatlen
, tm
, ut
, ns
);
1740 if ((0 < len
&& len
< size
) || (len
== 0 && buf
[0] == '\0'))
1743 /* Buffer was too small, so make it bigger and try again. */
1744 len
= emacs_nmemftime (NULL
, SIZE_MAX
, format
, formatlen
, tm
, ut
, ns
);
1746 if (STRING_BYTES_BOUND
<= len
)
1749 SAFE_ALLOCA (buf
, char *, size
);
1753 bufstring
= make_unibyte_string (buf
, len
);
1755 return code_convert_string_norecord (bufstring
, Vlocale_coding_system
, 0);
1758 DEFUN ("decode-time", Fdecode_time
, Sdecode_time
, 0, 1, 0,
1759 doc
: /* Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST ZONE).
1760 The optional SPECIFIED-TIME should be a list of (HIGH LOW . IGNORED),
1761 as from `current-time' and `file-attributes', or nil to use the
1762 current time. The obsolete form (HIGH . LOW) is also still accepted.
1763 The list has the following nine members: SEC is an integer between 0
1764 and 60; SEC is 60 for a leap second, which only some operating systems
1765 support. MINUTE is an integer between 0 and 59. HOUR is an integer
1766 between 0 and 23. DAY is an integer between 1 and 31. MONTH is an
1767 integer between 1 and 12. YEAR is an integer indicating the
1768 four-digit year. DOW is the day of week, an integer between 0 and 6,
1769 where 0 is Sunday. DST is t if daylight saving time is in effect,
1770 otherwise nil. ZONE is an integer indicating the number of seconds
1771 east of Greenwich. (Note that Common Lisp has different meanings for
1773 (Lisp_Object specified_time
)
1777 struct tm
*decoded_time
;
1778 Lisp_Object list_args
[9];
1780 if (! lisp_time_argument (specified_time
, &time_spec
, NULL
))
1781 error ("Invalid time specification");
1784 decoded_time
= localtime (&time_spec
);
1785 /* Make a copy, in case a signal handler modifies TZ or the struct. */
1787 save_tm
= *decoded_time
;
1790 && MOST_NEGATIVE_FIXNUM
- TM_YEAR_BASE
<= save_tm
.tm_year
1791 && save_tm
.tm_year
<= MOST_POSITIVE_FIXNUM
- TM_YEAR_BASE
))
1793 XSETFASTINT (list_args
[0], save_tm
.tm_sec
);
1794 XSETFASTINT (list_args
[1], save_tm
.tm_min
);
1795 XSETFASTINT (list_args
[2], save_tm
.tm_hour
);
1796 XSETFASTINT (list_args
[3], save_tm
.tm_mday
);
1797 XSETFASTINT (list_args
[4], save_tm
.tm_mon
+ 1);
1798 /* On 64-bit machines an int is narrower than EMACS_INT, thus the
1799 cast below avoids overflow in int arithmetics. */
1800 XSETINT (list_args
[5], TM_YEAR_BASE
+ (EMACS_INT
) save_tm
.tm_year
);
1801 XSETFASTINT (list_args
[6], save_tm
.tm_wday
);
1802 list_args
[7] = save_tm
.tm_isdst
? Qt
: Qnil
;
1805 decoded_time
= gmtime (&time_spec
);
1806 if (decoded_time
== 0)
1807 list_args
[8] = Qnil
;
1809 XSETINT (list_args
[8], tm_diff (&save_tm
, decoded_time
));
1811 return Flist (9, list_args
);
1814 /* Return OBJ - OFFSET, checking that OBJ is a valid fixnum and that
1815 the result is representable as an int. Assume OFFSET is small and
1818 check_tm_member (Lisp_Object obj
, int offset
)
1823 if (! (INT_MIN
+ offset
<= n
&& n
- offset
<= INT_MAX
))
1828 DEFUN ("encode-time", Fencode_time
, Sencode_time
, 6, MANY
, 0,
1829 doc
: /* Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.
1830 This is the reverse operation of `decode-time', which see.
1831 ZONE defaults to the current time zone rule. This can
1832 be a string or t (as from `set-time-zone-rule'), or it can be a list
1833 \(as from `current-time-zone') or an integer (as from `decode-time')
1834 applied without consideration for daylight saving time.
1836 You can pass more than 7 arguments; then the first six arguments
1837 are used as SECOND through YEAR, and the *last* argument is used as ZONE.
1838 The intervening arguments are ignored.
1839 This feature lets (apply 'encode-time (decode-time ...)) work.
1841 Out-of-range values for SECOND, MINUTE, HOUR, DAY, or MONTH are allowed;
1842 for example, a DAY of 0 means the day preceding the given month.
1843 Year numbers less than 100 are treated just like other year numbers.
1844 If you want them to stand for years in this century, you must do that yourself.
1846 Years before 1970 are not guaranteed to work. On some systems,
1847 year values as low as 1901 do work.
1849 usage: (encode-time SECOND MINUTE HOUR DAY MONTH YEAR &optional ZONE) */)
1850 (ptrdiff_t nargs
, Lisp_Object
*args
)
1854 Lisp_Object zone
= (nargs
> 6 ? args
[nargs
- 1] : Qnil
);
1856 tm
.tm_sec
= check_tm_member (args
[0], 0);
1857 tm
.tm_min
= check_tm_member (args
[1], 0);
1858 tm
.tm_hour
= check_tm_member (args
[2], 0);
1859 tm
.tm_mday
= check_tm_member (args
[3], 0);
1860 tm
.tm_mon
= check_tm_member (args
[4], 1);
1861 tm
.tm_year
= check_tm_member (args
[5], TM_YEAR_BASE
);
1869 value
= mktime (&tm
);
1875 const char *tzstring
;
1876 char **oldenv
= environ
, **newenv
;
1880 else if (STRINGP (zone
))
1881 tzstring
= SSDATA (zone
);
1882 else if (INTEGERP (zone
))
1884 int abszone
= eabs (XINT (zone
));
1885 sprintf (tzbuf
, "XXX%s%d:%02d:%02d", "-" + (XINT (zone
) < 0),
1886 abszone
/ (60*60), (abszone
/60) % 60, abszone
% 60);
1890 error ("Invalid time zone specification");
1894 /* Set TZ before calling mktime; merely adjusting mktime's returned
1895 value doesn't suffice, since that would mishandle leap seconds. */
1896 set_time_zone_rule (tzstring
);
1898 value
= mktime (&tm
);
1900 /* Restore TZ to previous value. */
1903 #ifdef LOCALTIME_CACHE
1911 if (value
== (time_t) -1)
1914 return make_time (value
);
1917 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
, 0, 1, 0,
1918 doc
: /* Return the current local time, as a human-readable string.
1919 Programs can use this function to decode a time,
1920 since the number of columns in each field is fixed
1921 if the year is in the range 1000-9999.
1922 The format is `Sun Sep 16 01:03:52 1973'.
1923 However, see also the functions `decode-time' and `format-time-string'
1924 which provide a much more powerful and general facility.
1926 If SPECIFIED-TIME is given, it is a time to format instead of the
1927 current time. The argument should have the form (HIGH LOW . IGNORED).
1928 Thus, you can use times obtained from `current-time' and from
1929 `file-attributes'. SPECIFIED-TIME can also have the form (HIGH . LOW),
1930 but this is considered obsolete. */)
1931 (Lisp_Object specified_time
)
1935 char buf
[sizeof "Mon Apr 30 12:49:17 " + INT_STRLEN_BOUND (int) + 1];
1936 int len
IF_LINT (= 0);
1938 if (! lisp_time_argument (specified_time
, &value
, NULL
))
1939 error ("Invalid time specification");
1941 /* Convert to a string in ctime format, except without the trailing
1942 newline, and without the 4-digit year limit. Don't use asctime
1943 or ctime, as they might dump core if the year is outside the
1944 range -999 .. 9999. */
1946 tm
= localtime (&value
);
1949 static char const wday_name
[][4] =
1950 { "Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat" };
1951 static char const mon_name
[][4] =
1952 { "Jan", "Feb", "Mar", "Apr", "May", "Jun",
1953 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" };
1954 printmax_t year_base
= TM_YEAR_BASE
;
1956 len
= sprintf (buf
, "%s %s%3d %02d:%02d:%02d %"pMd
,
1957 wday_name
[tm
->tm_wday
], mon_name
[tm
->tm_mon
], tm
->tm_mday
,
1958 tm
->tm_hour
, tm
->tm_min
, tm
->tm_sec
,
1959 tm
->tm_year
+ year_base
);
1965 return make_unibyte_string (buf
, len
);
1968 /* Yield A - B, measured in seconds.
1969 This function is copied from the GNU C Library. */
1971 tm_diff (struct tm
*a
, struct tm
*b
)
1973 /* Compute intervening leap days correctly even if year is negative.
1974 Take care to avoid int overflow in leap day calculations,
1975 but it's OK to assume that A and B are close to each other. */
1976 int a4
= (a
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (a
->tm_year
& 3);
1977 int b4
= (b
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (b
->tm_year
& 3);
1978 int a100
= a4
/ 25 - (a4
% 25 < 0);
1979 int b100
= b4
/ 25 - (b4
% 25 < 0);
1980 int a400
= a100
>> 2;
1981 int b400
= b100
>> 2;
1982 int intervening_leap_days
= (a4
- b4
) - (a100
- b100
) + (a400
- b400
);
1983 int years
= a
->tm_year
- b
->tm_year
;
1984 int days
= (365 * years
+ intervening_leap_days
1985 + (a
->tm_yday
- b
->tm_yday
));
1986 return (60 * (60 * (24 * days
+ (a
->tm_hour
- b
->tm_hour
))
1987 + (a
->tm_min
- b
->tm_min
))
1988 + (a
->tm_sec
- b
->tm_sec
));
1991 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 1, 0,
1992 doc
: /* Return the offset and name for the local time zone.
1993 This returns a list of the form (OFFSET NAME).
1994 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).
1995 A negative value means west of Greenwich.
1996 NAME is a string giving the name of the time zone.
1997 If SPECIFIED-TIME is given, the time zone offset is determined from it
1998 instead of using the current time. The argument should have the form
1999 (HIGH LOW . IGNORED). Thus, you can use times obtained from
2000 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
2001 have the form (HIGH . LOW), but this is considered obsolete.
2003 Some operating systems cannot provide all this information to Emacs;
2004 in this case, `current-time-zone' returns a list containing nil for
2005 the data it can't find. */)
2006 (Lisp_Object specified_time
)
2012 Lisp_Object zone_offset
, zone_name
;
2015 zone_name
= format_time_string ("%Z", sizeof "%Z" - 1, specified_time
,
2016 0, &value
, &localtm
);
2018 t
= gmtime (&value
);
2020 offset
= tm_diff (&localtm
, t
);
2025 zone_offset
= make_number (offset
);
2026 if (SCHARS (zone_name
) == 0)
2028 /* No local time zone name is available; use "+-NNNN" instead. */
2029 int m
= offset
/ 60;
2030 int am
= offset
< 0 ? - m
: m
;
2031 char buf
[sizeof "+00" + INT_STRLEN_BOUND (int)];
2032 sprintf (buf
, "%c%02d%02d", (offset
< 0 ? '-' : '+'), am
/60, am
%60);
2033 zone_name
= build_string (buf
);
2037 return list2 (zone_offset
, zone_name
);
2040 /* This holds the value of `environ' produced by the previous
2041 call to Fset_time_zone_rule, or 0 if Fset_time_zone_rule
2042 has never been called. */
2043 static char **environbuf
;
2045 /* This holds the startup value of the TZ environment variable so it
2046 can be restored if the user calls set-time-zone-rule with a nil
2048 static char *initial_tz
;
2050 DEFUN ("set-time-zone-rule", Fset_time_zone_rule
, Sset_time_zone_rule
, 1, 1, 0,
2051 doc
: /* Set the local time zone using TZ, a string specifying a time zone rule.
2052 If TZ is nil, use implementation-defined default time zone information.
2053 If TZ is t, use Universal Time.
2055 Instead of calling this function, you typically want (setenv "TZ" TZ).
2056 That changes both the environment of the Emacs process and the
2057 variable `process-environment', whereas `set-time-zone-rule' affects
2058 only the former. */)
2061 const char *tzstring
;
2062 char **old_environbuf
;
2064 if (! (NILP (tz
) || EQ (tz
, Qt
)))
2069 /* When called for the first time, save the original TZ. */
2070 old_environbuf
= environbuf
;
2071 if (!old_environbuf
)
2072 initial_tz
= (char *) getenv ("TZ");
2075 tzstring
= initial_tz
;
2076 else if (EQ (tz
, Qt
))
2079 tzstring
= SSDATA (tz
);
2081 set_time_zone_rule (tzstring
);
2082 environbuf
= environ
;
2086 xfree (old_environbuf
);
2090 #ifdef LOCALTIME_CACHE
2092 /* These two values are known to load tz files in buggy implementations,
2093 i.e. Solaris 1 executables running under either Solaris 1 or Solaris 2.
2094 Their values shouldn't matter in non-buggy implementations.
2095 We don't use string literals for these strings,
2096 since if a string in the environment is in readonly
2097 storage, it runs afoul of bugs in SVR4 and Solaris 2.3.
2098 See Sun bugs 1113095 and 1114114, ``Timezone routines
2099 improperly modify environment''. */
2101 static char set_time_zone_rule_tz1
[] = "TZ=GMT+0";
2102 static char set_time_zone_rule_tz2
[] = "TZ=GMT+1";
2106 /* Set the local time zone rule to TZSTRING.
2107 This allocates memory into `environ', which it is the caller's
2108 responsibility to free. */
2111 set_time_zone_rule (const char *tzstring
)
2114 char **from
, **to
, **newenv
;
2116 /* Make the ENVIRON vector longer with room for TZSTRING. */
2117 for (from
= environ
; *from
; from
++)
2119 envptrs
= from
- environ
+ 2;
2120 newenv
= to
= (char **) xmalloc (envptrs
* sizeof (char *)
2121 + (tzstring
? strlen (tzstring
) + 4 : 0));
2123 /* Add TZSTRING to the end of environ, as a value for TZ. */
2126 char *t
= (char *) (to
+ envptrs
);
2128 strcat (t
, tzstring
);
2132 /* Copy the old environ vector elements into NEWENV,
2133 but don't copy the TZ variable.
2134 So we have only one definition of TZ, which came from TZSTRING. */
2135 for (from
= environ
; *from
; from
++)
2136 if (strncmp (*from
, "TZ=", 3) != 0)
2142 /* If we do have a TZSTRING, NEWENV points to the vector slot where
2143 the TZ variable is stored. If we do not have a TZSTRING,
2144 TO points to the vector slot which has the terminating null. */
2146 #ifdef LOCALTIME_CACHE
2148 /* In SunOS 4.1.3_U1 and 4.1.4, if TZ has a value like
2149 "US/Pacific" that loads a tz file, then changes to a value like
2150 "XXX0" that does not load a tz file, and then changes back to
2151 its original value, the last change is (incorrectly) ignored.
2152 Also, if TZ changes twice in succession to values that do
2153 not load a tz file, tzset can dump core (see Sun bug#1225179).
2154 The following code works around these bugs. */
2158 /* Temporarily set TZ to a value that loads a tz file
2159 and that differs from tzstring. */
2161 *newenv
= (strcmp (tzstring
, set_time_zone_rule_tz1
+ 3) == 0
2162 ? set_time_zone_rule_tz2
: set_time_zone_rule_tz1
);
2168 /* The implied tzstring is unknown, so temporarily set TZ to
2169 two different values that each load a tz file. */
2170 *to
= set_time_zone_rule_tz1
;
2173 *to
= set_time_zone_rule_tz2
;
2178 /* Now TZ has the desired value, and tzset can be invoked safely. */
2185 /* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC
2186 (if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a
2187 type of object is Lisp_String). INHERIT is passed to
2188 INSERT_FROM_STRING_FUNC as the last argument. */
2191 general_insert_function (void (*insert_func
)
2192 (const char *, EMACS_INT
),
2193 void (*insert_from_string_func
)
2194 (Lisp_Object
, EMACS_INT
, EMACS_INT
,
2195 EMACS_INT
, EMACS_INT
, int),
2196 int inherit
, ptrdiff_t nargs
, Lisp_Object
*args
)
2199 register Lisp_Object val
;
2201 for (argnum
= 0; argnum
< nargs
; argnum
++)
2204 if (CHARACTERP (val
))
2206 int c
= XFASTINT (val
);
2207 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2210 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2211 len
= CHAR_STRING (c
, str
);
2214 str
[0] = ASCII_CHAR_P (c
) ? c
: multibyte_char_to_unibyte (c
);
2217 (*insert_func
) ((char *) str
, len
);
2219 else if (STRINGP (val
))
2221 (*insert_from_string_func
) (val
, 0, 0,
2227 wrong_type_argument (Qchar_or_string_p
, val
);
2232 insert1 (Lisp_Object arg
)
2238 /* Callers passing one argument to Finsert need not gcpro the
2239 argument "array", since the only element of the array will
2240 not be used after calling insert or insert_from_string, so
2241 we don't care if it gets trashed. */
2243 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
2244 doc
: /* Insert the arguments, either strings or characters, at point.
2245 Point and before-insertion markers move forward to end up
2246 after the inserted text.
2247 Any other markers at the point of insertion remain before the text.
2249 If the current buffer is multibyte, unibyte strings are converted
2250 to multibyte for insertion (see `string-make-multibyte').
2251 If the current buffer is unibyte, multibyte strings are converted
2252 to unibyte for insertion (see `string-make-unibyte').
2254 When operating on binary data, it may be necessary to preserve the
2255 original bytes of a unibyte string when inserting it into a multibyte
2256 buffer; to accomplish this, apply `string-as-multibyte' to the string
2257 and insert the result.
2259 usage: (insert &rest ARGS) */)
2260 (ptrdiff_t nargs
, Lisp_Object
*args
)
2262 general_insert_function (insert
, insert_from_string
, 0, nargs
, args
);
2266 DEFUN ("insert-and-inherit", Finsert_and_inherit
, Sinsert_and_inherit
,
2268 doc
: /* Insert the arguments at point, inheriting properties from adjoining text.
2269 Point and before-insertion markers move forward to end up
2270 after the inserted text.
2271 Any other markers at the point of insertion remain before the text.
2273 If the current buffer is multibyte, unibyte strings are converted
2274 to multibyte for insertion (see `unibyte-char-to-multibyte').
2275 If the current buffer is unibyte, multibyte strings are converted
2276 to unibyte for insertion.
2278 usage: (insert-and-inherit &rest ARGS) */)
2279 (ptrdiff_t nargs
, Lisp_Object
*args
)
2281 general_insert_function (insert_and_inherit
, insert_from_string
, 1,
2286 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
2287 doc
: /* Insert strings or characters at point, relocating markers after the text.
2288 Point and markers move forward to end up after the inserted text.
2290 If the current buffer is multibyte, unibyte strings are converted
2291 to multibyte for insertion (see `unibyte-char-to-multibyte').
2292 If the current buffer is unibyte, multibyte strings are converted
2293 to unibyte for insertion.
2295 usage: (insert-before-markers &rest ARGS) */)
2296 (ptrdiff_t nargs
, Lisp_Object
*args
)
2298 general_insert_function (insert_before_markers
,
2299 insert_from_string_before_markers
, 0,
2304 DEFUN ("insert-before-markers-and-inherit", Finsert_and_inherit_before_markers
,
2305 Sinsert_and_inherit_before_markers
, 0, MANY
, 0,
2306 doc
: /* Insert text at point, relocating markers and inheriting properties.
2307 Point and markers move forward to end up after the inserted text.
2309 If the current buffer is multibyte, unibyte strings are converted
2310 to multibyte for insertion (see `unibyte-char-to-multibyte').
2311 If the current buffer is unibyte, multibyte strings are converted
2312 to unibyte for insertion.
2314 usage: (insert-before-markers-and-inherit &rest ARGS) */)
2315 (ptrdiff_t nargs
, Lisp_Object
*args
)
2317 general_insert_function (insert_before_markers_and_inherit
,
2318 insert_from_string_before_markers
, 1,
2323 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 2, 3, 0,
2324 doc
: /* Insert COUNT copies of CHARACTER.
2325 Point, and before-insertion markers, are relocated as in the function `insert'.
2326 The optional third arg INHERIT, if non-nil, says to inherit text properties
2327 from adjoining text, if those properties are sticky. */)
2328 (Lisp_Object character
, Lisp_Object count
, Lisp_Object inherit
)
2331 register EMACS_INT n
;
2333 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2336 CHECK_CHARACTER (character
);
2337 CHECK_NUMBER (count
);
2338 c
= XFASTINT (character
);
2340 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2341 len
= CHAR_STRING (c
, str
);
2343 str
[0] = c
, len
= 1;
2344 if (XINT (count
) <= 0)
2346 if (BUF_BYTES_MAX
/ len
< XINT (count
))
2348 n
= XINT (count
) * len
;
2349 stringlen
= min (n
, sizeof string
- sizeof string
% len
);
2350 for (i
= 0; i
< stringlen
; i
++)
2351 string
[i
] = str
[i
% len
];
2352 while (n
> stringlen
)
2355 if (!NILP (inherit
))
2356 insert_and_inherit (string
, stringlen
);
2358 insert (string
, stringlen
);
2361 if (!NILP (inherit
))
2362 insert_and_inherit (string
, n
);
2368 DEFUN ("insert-byte", Finsert_byte
, Sinsert_byte
, 2, 3, 0,
2369 doc
: /* Insert COUNT (second arg) copies of BYTE (first arg).
2370 Both arguments are required.
2371 BYTE is a number of the range 0..255.
2373 If BYTE is 128..255 and the current buffer is multibyte, the
2374 corresponding eight-bit character is inserted.
2376 Point, and before-insertion markers, are relocated as in the function `insert'.
2377 The optional third arg INHERIT, if non-nil, says to inherit text properties
2378 from adjoining text, if those properties are sticky. */)
2379 (Lisp_Object byte
, Lisp_Object count
, Lisp_Object inherit
)
2381 CHECK_NUMBER (byte
);
2382 if (XINT (byte
) < 0 || XINT (byte
) > 255)
2383 args_out_of_range_3 (byte
, make_number (0), make_number (255));
2384 if (XINT (byte
) >= 128
2385 && ! NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2386 XSETFASTINT (byte
, BYTE8_TO_CHAR (XINT (byte
)));
2387 return Finsert_char (byte
, count
, inherit
);
2391 /* Making strings from buffer contents. */
2393 /* Return a Lisp_String containing the text of the current buffer from
2394 START to END. If text properties are in use and the current buffer
2395 has properties in the range specified, the resulting string will also
2396 have them, if PROPS is nonzero.
2398 We don't want to use plain old make_string here, because it calls
2399 make_uninit_string, which can cause the buffer arena to be
2400 compacted. make_string has no way of knowing that the data has
2401 been moved, and thus copies the wrong data into the string. This
2402 doesn't effect most of the other users of make_string, so it should
2403 be left as is. But we should use this function when conjuring
2404 buffer substrings. */
2407 make_buffer_string (EMACS_INT start
, EMACS_INT end
, int props
)
2409 EMACS_INT start_byte
= CHAR_TO_BYTE (start
);
2410 EMACS_INT end_byte
= CHAR_TO_BYTE (end
);
2412 return make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
);
2415 /* Return a Lisp_String containing the text of the current buffer from
2416 START / START_BYTE to END / END_BYTE.
2418 If text properties are in use and the current buffer
2419 has properties in the range specified, the resulting string will also
2420 have them, if PROPS is nonzero.
2422 We don't want to use plain old make_string here, because it calls
2423 make_uninit_string, which can cause the buffer arena to be
2424 compacted. make_string has no way of knowing that the data has
2425 been moved, and thus copies the wrong data into the string. This
2426 doesn't effect most of the other users of make_string, so it should
2427 be left as is. But we should use this function when conjuring
2428 buffer substrings. */
2431 make_buffer_string_both (EMACS_INT start
, EMACS_INT start_byte
,
2432 EMACS_INT end
, EMACS_INT end_byte
, int props
)
2434 Lisp_Object result
, tem
, tem1
;
2436 if (start
< GPT
&& GPT
< end
)
2439 if (! NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2440 result
= make_uninit_multibyte_string (end
- start
, end_byte
- start_byte
);
2442 result
= make_uninit_string (end
- start
);
2443 memcpy (SDATA (result
), BYTE_POS_ADDR (start_byte
), end_byte
- start_byte
);
2445 /* If desired, update and copy the text properties. */
2448 update_buffer_properties (start
, end
);
2450 tem
= Fnext_property_change (make_number (start
), Qnil
, make_number (end
));
2451 tem1
= Ftext_properties_at (make_number (start
), Qnil
);
2453 if (XINT (tem
) != end
|| !NILP (tem1
))
2454 copy_intervals_to_string (result
, current_buffer
, start
,
2461 /* Call Vbuffer_access_fontify_functions for the range START ... END
2462 in the current buffer, if necessary. */
2465 update_buffer_properties (EMACS_INT start
, EMACS_INT end
)
2467 /* If this buffer has some access functions,
2468 call them, specifying the range of the buffer being accessed. */
2469 if (!NILP (Vbuffer_access_fontify_functions
))
2471 Lisp_Object args
[3];
2474 args
[0] = Qbuffer_access_fontify_functions
;
2475 XSETINT (args
[1], start
);
2476 XSETINT (args
[2], end
);
2478 /* But don't call them if we can tell that the work
2479 has already been done. */
2480 if (!NILP (Vbuffer_access_fontified_property
))
2482 tem
= Ftext_property_any (args
[1], args
[2],
2483 Vbuffer_access_fontified_property
,
2486 Frun_hook_with_args (3, args
);
2489 Frun_hook_with_args (3, args
);
2493 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
2494 doc
: /* Return the contents of part of the current buffer as a string.
2495 The two arguments START and END are character positions;
2496 they can be in either order.
2497 The string returned is multibyte if the buffer is multibyte.
2499 This function copies the text properties of that part of the buffer
2500 into the result string; if you don't want the text properties,
2501 use `buffer-substring-no-properties' instead. */)
2502 (Lisp_Object start
, Lisp_Object end
)
2504 register EMACS_INT b
, e
;
2506 validate_region (&start
, &end
);
2510 return make_buffer_string (b
, e
, 1);
2513 DEFUN ("buffer-substring-no-properties", Fbuffer_substring_no_properties
,
2514 Sbuffer_substring_no_properties
, 2, 2, 0,
2515 doc
: /* Return the characters of part of the buffer, without the text properties.
2516 The two arguments START and END are character positions;
2517 they can be in either order. */)
2518 (Lisp_Object start
, Lisp_Object end
)
2520 register EMACS_INT b
, e
;
2522 validate_region (&start
, &end
);
2526 return make_buffer_string (b
, e
, 0);
2529 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
2530 doc
: /* Return the contents of the current buffer as a string.
2531 If narrowing is in effect, this function returns only the visible part
2535 return make_buffer_string (BEGV
, ZV
, 1);
2538 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
2540 doc
: /* Insert before point a substring of the contents of BUFFER.
2541 BUFFER may be a buffer or a buffer name.
2542 Arguments START and END are character positions specifying the substring.
2543 They default to the values of (point-min) and (point-max) in BUFFER. */)
2544 (Lisp_Object buffer
, Lisp_Object start
, Lisp_Object end
)
2546 register EMACS_INT b
, e
, temp
;
2547 register struct buffer
*bp
, *obuf
;
2550 buf
= Fget_buffer (buffer
);
2554 if (NILP (BVAR (bp
, name
)))
2555 error ("Selecting deleted buffer");
2561 CHECK_NUMBER_COERCE_MARKER (start
);
2568 CHECK_NUMBER_COERCE_MARKER (end
);
2573 temp
= b
, b
= e
, e
= temp
;
2575 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
2576 args_out_of_range (start
, end
);
2578 obuf
= current_buffer
;
2579 set_buffer_internal_1 (bp
);
2580 update_buffer_properties (b
, e
);
2581 set_buffer_internal_1 (obuf
);
2583 insert_from_buffer (bp
, b
, e
- b
, 0);
2587 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
2589 doc
: /* Compare two substrings of two buffers; return result as number.
2590 the value is -N if first string is less after N-1 chars,
2591 +N if first string is greater after N-1 chars, or 0 if strings match.
2592 Each substring is represented as three arguments: BUFFER, START and END.
2593 That makes six args in all, three for each substring.
2595 The value of `case-fold-search' in the current buffer
2596 determines whether case is significant or ignored. */)
2597 (Lisp_Object buffer1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object buffer2
, Lisp_Object start2
, Lisp_Object end2
)
2599 register EMACS_INT begp1
, endp1
, begp2
, endp2
, temp
;
2600 register struct buffer
*bp1
, *bp2
;
2601 register Lisp_Object trt
2602 = (!NILP (BVAR (current_buffer
, case_fold_search
))
2603 ? BVAR (current_buffer
, case_canon_table
) : Qnil
);
2604 EMACS_INT chars
= 0;
2605 EMACS_INT i1
, i2
, i1_byte
, i2_byte
;
2607 /* Find the first buffer and its substring. */
2610 bp1
= current_buffer
;
2614 buf1
= Fget_buffer (buffer1
);
2617 bp1
= XBUFFER (buf1
);
2618 if (NILP (BVAR (bp1
, name
)))
2619 error ("Selecting deleted buffer");
2623 begp1
= BUF_BEGV (bp1
);
2626 CHECK_NUMBER_COERCE_MARKER (start1
);
2627 begp1
= XINT (start1
);
2630 endp1
= BUF_ZV (bp1
);
2633 CHECK_NUMBER_COERCE_MARKER (end1
);
2634 endp1
= XINT (end1
);
2638 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
2640 if (!(BUF_BEGV (bp1
) <= begp1
2642 && endp1
<= BUF_ZV (bp1
)))
2643 args_out_of_range (start1
, end1
);
2645 /* Likewise for second substring. */
2648 bp2
= current_buffer
;
2652 buf2
= Fget_buffer (buffer2
);
2655 bp2
= XBUFFER (buf2
);
2656 if (NILP (BVAR (bp2
, name
)))
2657 error ("Selecting deleted buffer");
2661 begp2
= BUF_BEGV (bp2
);
2664 CHECK_NUMBER_COERCE_MARKER (start2
);
2665 begp2
= XINT (start2
);
2668 endp2
= BUF_ZV (bp2
);
2671 CHECK_NUMBER_COERCE_MARKER (end2
);
2672 endp2
= XINT (end2
);
2676 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
2678 if (!(BUF_BEGV (bp2
) <= begp2
2680 && endp2
<= BUF_ZV (bp2
)))
2681 args_out_of_range (start2
, end2
);
2685 i1_byte
= buf_charpos_to_bytepos (bp1
, i1
);
2686 i2_byte
= buf_charpos_to_bytepos (bp2
, i2
);
2688 while (i1
< endp1
&& i2
< endp2
)
2690 /* When we find a mismatch, we must compare the
2691 characters, not just the bytes. */
2696 if (! NILP (BVAR (bp1
, enable_multibyte_characters
)))
2698 c1
= BUF_FETCH_MULTIBYTE_CHAR (bp1
, i1_byte
);
2699 BUF_INC_POS (bp1
, i1_byte
);
2704 c1
= BUF_FETCH_BYTE (bp1
, i1
);
2705 MAKE_CHAR_MULTIBYTE (c1
);
2709 if (! NILP (BVAR (bp2
, enable_multibyte_characters
)))
2711 c2
= BUF_FETCH_MULTIBYTE_CHAR (bp2
, i2_byte
);
2712 BUF_INC_POS (bp2
, i2_byte
);
2717 c2
= BUF_FETCH_BYTE (bp2
, i2
);
2718 MAKE_CHAR_MULTIBYTE (c2
);
2724 c1
= CHAR_TABLE_TRANSLATE (trt
, c1
);
2725 c2
= CHAR_TABLE_TRANSLATE (trt
, c2
);
2728 return make_number (- 1 - chars
);
2730 return make_number (chars
+ 1);
2735 /* The strings match as far as they go.
2736 If one is shorter, that one is less. */
2737 if (chars
< endp1
- begp1
)
2738 return make_number (chars
+ 1);
2739 else if (chars
< endp2
- begp2
)
2740 return make_number (- chars
- 1);
2742 /* Same length too => they are equal. */
2743 return make_number (0);
2747 subst_char_in_region_unwind (Lisp_Object arg
)
2749 return BVAR (current_buffer
, undo_list
) = arg
;
2753 subst_char_in_region_unwind_1 (Lisp_Object arg
)
2755 return BVAR (current_buffer
, filename
) = arg
;
2758 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
2759 Ssubst_char_in_region
, 4, 5, 0,
2760 doc
: /* From START to END, replace FROMCHAR with TOCHAR each time it occurs.
2761 If optional arg NOUNDO is non-nil, don't record this change for undo
2762 and don't mark the buffer as really changed.
2763 Both characters must have the same length of multi-byte form. */)
2764 (Lisp_Object start
, Lisp_Object end
, Lisp_Object fromchar
, Lisp_Object tochar
, Lisp_Object noundo
)
2766 register EMACS_INT pos
, pos_byte
, stop
, i
, len
, end_byte
;
2767 /* Keep track of the first change in the buffer:
2768 if 0 we haven't found it yet.
2769 if < 0 we've found it and we've run the before-change-function.
2770 if > 0 we've actually performed it and the value is its position. */
2771 EMACS_INT changed
= 0;
2772 unsigned char fromstr
[MAX_MULTIBYTE_LENGTH
], tostr
[MAX_MULTIBYTE_LENGTH
];
2774 int count
= SPECPDL_INDEX ();
2775 #define COMBINING_NO 0
2776 #define COMBINING_BEFORE 1
2777 #define COMBINING_AFTER 2
2778 #define COMBINING_BOTH (COMBINING_BEFORE | COMBINING_AFTER)
2779 int maybe_byte_combining
= COMBINING_NO
;
2780 EMACS_INT last_changed
= 0;
2781 int multibyte_p
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
2786 validate_region (&start
, &end
);
2787 CHECK_CHARACTER (fromchar
);
2788 CHECK_CHARACTER (tochar
);
2789 fromc
= XFASTINT (fromchar
);
2790 toc
= XFASTINT (tochar
);
2794 len
= CHAR_STRING (fromc
, fromstr
);
2795 if (CHAR_STRING (toc
, tostr
) != len
)
2796 error ("Characters in `subst-char-in-region' have different byte-lengths");
2797 if (!ASCII_BYTE_P (*tostr
))
2799 /* If *TOSTR is in the range 0x80..0x9F and TOCHAR is not a
2800 complete multibyte character, it may be combined with the
2801 after bytes. If it is in the range 0xA0..0xFF, it may be
2802 combined with the before and after bytes. */
2803 if (!CHAR_HEAD_P (*tostr
))
2804 maybe_byte_combining
= COMBINING_BOTH
;
2805 else if (BYTES_BY_CHAR_HEAD (*tostr
) > len
)
2806 maybe_byte_combining
= COMBINING_AFTER
;
2817 pos_byte
= CHAR_TO_BYTE (pos
);
2818 stop
= CHAR_TO_BYTE (XINT (end
));
2821 /* If we don't want undo, turn off putting stuff on the list.
2822 That's faster than getting rid of things,
2823 and it prevents even the entry for a first change.
2824 Also inhibit locking the file. */
2825 if (!changed
&& !NILP (noundo
))
2827 record_unwind_protect (subst_char_in_region_unwind
,
2828 BVAR (current_buffer
, undo_list
));
2829 BVAR (current_buffer
, undo_list
) = Qt
;
2830 /* Don't do file-locking. */
2831 record_unwind_protect (subst_char_in_region_unwind_1
,
2832 BVAR (current_buffer
, filename
));
2833 BVAR (current_buffer
, filename
) = Qnil
;
2836 if (pos_byte
< GPT_BYTE
)
2837 stop
= min (stop
, GPT_BYTE
);
2840 EMACS_INT pos_byte_next
= pos_byte
;
2842 if (pos_byte
>= stop
)
2844 if (pos_byte
>= end_byte
) break;
2847 p
= BYTE_POS_ADDR (pos_byte
);
2849 INC_POS (pos_byte_next
);
2852 if (pos_byte_next
- pos_byte
== len
2853 && p
[0] == fromstr
[0]
2855 || (p
[1] == fromstr
[1]
2856 && (len
== 2 || (p
[2] == fromstr
[2]
2857 && (len
== 3 || p
[3] == fromstr
[3]))))))
2860 /* We've already seen this and run the before-change-function;
2861 this time we only need to record the actual position. */
2866 modify_region (current_buffer
, pos
, XINT (end
), 0);
2868 if (! NILP (noundo
))
2870 if (MODIFF
- 1 == SAVE_MODIFF
)
2872 if (MODIFF
- 1 == BUF_AUTOSAVE_MODIFF (current_buffer
))
2873 BUF_AUTOSAVE_MODIFF (current_buffer
)++;
2876 /* The before-change-function may have moved the gap
2877 or even modified the buffer so we should start over. */
2881 /* Take care of the case where the new character
2882 combines with neighboring bytes. */
2883 if (maybe_byte_combining
2884 && (maybe_byte_combining
== COMBINING_AFTER
2885 ? (pos_byte_next
< Z_BYTE
2886 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2887 : ((pos_byte_next
< Z_BYTE
2888 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2889 || (pos_byte
> BEG_BYTE
2890 && ! ASCII_BYTE_P (FETCH_BYTE (pos_byte
- 1))))))
2892 Lisp_Object tem
, string
;
2894 struct gcpro gcpro1
;
2896 tem
= BVAR (current_buffer
, undo_list
);
2899 /* Make a multibyte string containing this single character. */
2900 string
= make_multibyte_string ((char *) tostr
, 1, len
);
2901 /* replace_range is less efficient, because it moves the gap,
2902 but it handles combining correctly. */
2903 replace_range (pos
, pos
+ 1, string
,
2905 pos_byte_next
= CHAR_TO_BYTE (pos
);
2906 if (pos_byte_next
> pos_byte
)
2907 /* Before combining happened. We should not increment
2908 POS. So, to cancel the later increment of POS,
2912 INC_POS (pos_byte_next
);
2914 if (! NILP (noundo
))
2915 BVAR (current_buffer
, undo_list
) = tem
;
2922 record_change (pos
, 1);
2923 for (i
= 0; i
< len
; i
++) *p
++ = tostr
[i
];
2925 last_changed
= pos
+ 1;
2927 pos_byte
= pos_byte_next
;
2933 signal_after_change (changed
,
2934 last_changed
- changed
, last_changed
- changed
);
2935 update_compositions (changed
, last_changed
, CHECK_ALL
);
2938 unbind_to (count
, Qnil
);
2943 static Lisp_Object
check_translation (EMACS_INT
, EMACS_INT
, EMACS_INT
,
2946 /* Helper function for Ftranslate_region_internal.
2948 Check if a character sequence at POS (POS_BYTE) matches an element
2949 of VAL. VAL is a list (([FROM-CHAR ...] . TO) ...). If a matching
2950 element is found, return it. Otherwise return Qnil. */
2953 check_translation (EMACS_INT pos
, EMACS_INT pos_byte
, EMACS_INT end
,
2956 int buf_size
= 16, buf_used
= 0;
2957 int *buf
= alloca (sizeof (int) * buf_size
);
2959 for (; CONSP (val
); val
= XCDR (val
))
2968 if (! VECTORP (elt
))
2971 if (len
<= end
- pos
)
2973 for (i
= 0; i
< len
; i
++)
2977 unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
2980 if (buf_used
== buf_size
)
2985 newbuf
= alloca (sizeof (int) * buf_size
);
2986 memcpy (newbuf
, buf
, sizeof (int) * buf_used
);
2989 buf
[buf_used
++] = STRING_CHAR_AND_LENGTH (p
, len1
);
2992 if (XINT (AREF (elt
, i
)) != buf
[i
])
3003 DEFUN ("translate-region-internal", Ftranslate_region_internal
,
3004 Stranslate_region_internal
, 3, 3, 0,
3005 doc
: /* Internal use only.
3006 From START to END, translate characters according to TABLE.
3007 TABLE is a string or a char-table; the Nth character in it is the
3008 mapping for the character with code N.
3009 It returns the number of characters changed. */)
3010 (Lisp_Object start
, Lisp_Object end
, register Lisp_Object table
)
3012 register unsigned char *tt
; /* Trans table. */
3013 register int nc
; /* New character. */
3014 int cnt
; /* Number of changes made. */
3015 EMACS_INT size
; /* Size of translate table. */
3016 EMACS_INT pos
, pos_byte
, end_pos
;
3017 int multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3018 int string_multibyte
IF_LINT (= 0);
3020 validate_region (&start
, &end
);
3021 if (CHAR_TABLE_P (table
))
3023 if (! EQ (XCHAR_TABLE (table
)->purpose
, Qtranslation_table
))
3024 error ("Not a translation table");
3030 CHECK_STRING (table
);
3032 if (! multibyte
&& (SCHARS (table
) < SBYTES (table
)))
3033 table
= string_make_unibyte (table
);
3034 string_multibyte
= SCHARS (table
) < SBYTES (table
);
3035 size
= SBYTES (table
);
3040 pos_byte
= CHAR_TO_BYTE (pos
);
3041 end_pos
= XINT (end
);
3042 modify_region (current_buffer
, pos
, end_pos
, 0);
3045 for (; pos
< end_pos
; )
3047 register unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
3048 unsigned char *str
, buf
[MAX_MULTIBYTE_LENGTH
];
3054 oc
= STRING_CHAR_AND_LENGTH (p
, len
);
3061 /* Reload as signal_after_change in last iteration may GC. */
3063 if (string_multibyte
)
3065 str
= tt
+ string_char_to_byte (table
, oc
);
3066 nc
= STRING_CHAR_AND_LENGTH (str
, str_len
);
3071 if (! ASCII_BYTE_P (nc
) && multibyte
)
3073 str_len
= BYTE8_STRING (nc
, buf
);
3086 val
= CHAR_TABLE_REF (table
, oc
);
3087 if (CHARACTERP (val
))
3089 nc
= XFASTINT (val
);
3090 str_len
= CHAR_STRING (nc
, buf
);
3093 else if (VECTORP (val
) || (CONSP (val
)))
3095 /* VAL is [TO_CHAR ...] or (([FROM-CHAR ...] . TO) ...)
3096 where TO is TO-CHAR or [TO-CHAR ...]. */
3101 if (nc
!= oc
&& nc
>= 0)
3103 /* Simple one char to one char translation. */
3108 /* This is less efficient, because it moves the gap,
3109 but it should handle multibyte characters correctly. */
3110 string
= make_multibyte_string ((char *) str
, 1, str_len
);
3111 replace_range (pos
, pos
+ 1, string
, 1, 0, 1);
3116 record_change (pos
, 1);
3117 while (str_len
-- > 0)
3119 signal_after_change (pos
, 1, 1);
3120 update_compositions (pos
, pos
+ 1, CHECK_BORDER
);
3130 val
= check_translation (pos
, pos_byte
, end_pos
, val
);
3137 /* VAL is ([FROM-CHAR ...] . TO). */
3138 len
= ASIZE (XCAR (val
));
3146 string
= Fconcat (1, &val
);
3150 string
= Fmake_string (make_number (1), val
);
3152 replace_range (pos
, pos
+ len
, string
, 1, 0, 1);
3153 pos_byte
+= SBYTES (string
);
3154 pos
+= SCHARS (string
);
3155 cnt
+= SCHARS (string
);
3156 end_pos
+= SCHARS (string
) - len
;
3164 return make_number (cnt
);
3167 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
3168 doc
: /* Delete the text between START and END.
3169 If called interactively, delete the region between point and mark.
3170 This command deletes buffer text without modifying the kill ring. */)
3171 (Lisp_Object start
, Lisp_Object end
)
3173 validate_region (&start
, &end
);
3174 del_range (XINT (start
), XINT (end
));
3178 DEFUN ("delete-and-extract-region", Fdelete_and_extract_region
,
3179 Sdelete_and_extract_region
, 2, 2, 0,
3180 doc
: /* Delete the text between START and END and return it. */)
3181 (Lisp_Object start
, Lisp_Object end
)
3183 validate_region (&start
, &end
);
3184 if (XINT (start
) == XINT (end
))
3185 return empty_unibyte_string
;
3186 return del_range_1 (XINT (start
), XINT (end
), 1, 1);
3189 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
3190 doc
: /* Remove restrictions (narrowing) from current buffer.
3191 This allows the buffer's full text to be seen and edited. */)
3194 if (BEG
!= BEGV
|| Z
!= ZV
)
3195 current_buffer
->clip_changed
= 1;
3197 BEGV_BYTE
= BEG_BYTE
;
3198 SET_BUF_ZV_BOTH (current_buffer
, Z
, Z_BYTE
);
3199 /* Changing the buffer bounds invalidates any recorded current column. */
3200 invalidate_current_column ();
3204 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
3205 doc
: /* Restrict editing in this buffer to the current region.
3206 The rest of the text becomes temporarily invisible and untouchable
3207 but is not deleted; if you save the buffer in a file, the invisible
3208 text is included in the file. \\[widen] makes all visible again.
3209 See also `save-restriction'.
3211 When calling from a program, pass two arguments; positions (integers
3212 or markers) bounding the text that should remain visible. */)
3213 (register Lisp_Object start
, Lisp_Object end
)
3215 CHECK_NUMBER_COERCE_MARKER (start
);
3216 CHECK_NUMBER_COERCE_MARKER (end
);
3218 if (XINT (start
) > XINT (end
))
3221 tem
= start
; start
= end
; end
= tem
;
3224 if (!(BEG
<= XINT (start
) && XINT (start
) <= XINT (end
) && XINT (end
) <= Z
))
3225 args_out_of_range (start
, end
);
3227 if (BEGV
!= XFASTINT (start
) || ZV
!= XFASTINT (end
))
3228 current_buffer
->clip_changed
= 1;
3230 SET_BUF_BEGV (current_buffer
, XFASTINT (start
));
3231 SET_BUF_ZV (current_buffer
, XFASTINT (end
));
3232 if (PT
< XFASTINT (start
))
3233 SET_PT (XFASTINT (start
));
3234 if (PT
> XFASTINT (end
))
3235 SET_PT (XFASTINT (end
));
3236 /* Changing the buffer bounds invalidates any recorded current column. */
3237 invalidate_current_column ();
3242 save_restriction_save (void)
3244 if (BEGV
== BEG
&& ZV
== Z
)
3245 /* The common case that the buffer isn't narrowed.
3246 We return just the buffer object, which save_restriction_restore
3247 recognizes as meaning `no restriction'. */
3248 return Fcurrent_buffer ();
3250 /* We have to save a restriction, so return a pair of markers, one
3251 for the beginning and one for the end. */
3253 Lisp_Object beg
, end
;
3255 beg
= buildmark (BEGV
, BEGV_BYTE
);
3256 end
= buildmark (ZV
, ZV_BYTE
);
3258 /* END must move forward if text is inserted at its exact location. */
3259 XMARKER (end
)->insertion_type
= 1;
3261 return Fcons (beg
, end
);
3266 save_restriction_restore (Lisp_Object data
)
3268 struct buffer
*cur
= NULL
;
3269 struct buffer
*buf
= (CONSP (data
)
3270 ? XMARKER (XCAR (data
))->buffer
3273 if (buf
&& buf
!= current_buffer
&& !NILP (BVAR (buf
, pt_marker
)))
3274 { /* If `buf' uses markers to keep track of PT, BEGV, and ZV (as
3275 is the case if it is or has an indirect buffer), then make
3276 sure it is current before we update BEGV, so
3277 set_buffer_internal takes care of managing those markers. */
3278 cur
= current_buffer
;
3279 set_buffer_internal (buf
);
3283 /* A pair of marks bounding a saved restriction. */
3285 struct Lisp_Marker
*beg
= XMARKER (XCAR (data
));
3286 struct Lisp_Marker
*end
= XMARKER (XCDR (data
));
3287 eassert (buf
== end
->buffer
);
3289 if (buf
/* Verify marker still points to a buffer. */
3290 && (beg
->charpos
!= BUF_BEGV (buf
) || end
->charpos
!= BUF_ZV (buf
)))
3291 /* The restriction has changed from the saved one, so restore
3292 the saved restriction. */
3294 EMACS_INT pt
= BUF_PT (buf
);
3296 SET_BUF_BEGV_BOTH (buf
, beg
->charpos
, beg
->bytepos
);
3297 SET_BUF_ZV_BOTH (buf
, end
->charpos
, end
->bytepos
);
3299 if (pt
< beg
->charpos
|| pt
> end
->charpos
)
3300 /* The point is outside the new visible range, move it inside. */
3301 SET_BUF_PT_BOTH (buf
,
3302 clip_to_bounds (beg
->charpos
, pt
, end
->charpos
),
3303 clip_to_bounds (beg
->bytepos
, BUF_PT_BYTE (buf
),
3306 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3310 /* A buffer, which means that there was no old restriction. */
3312 if (buf
/* Verify marker still points to a buffer. */
3313 && (BUF_BEGV (buf
) != BUF_BEG (buf
) || BUF_ZV (buf
) != BUF_Z (buf
)))
3314 /* The buffer has been narrowed, get rid of the narrowing. */
3316 SET_BUF_BEGV_BOTH (buf
, BUF_BEG (buf
), BUF_BEG_BYTE (buf
));
3317 SET_BUF_ZV_BOTH (buf
, BUF_Z (buf
), BUF_Z_BYTE (buf
));
3319 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3323 /* Changing the buffer bounds invalidates any recorded current column. */
3324 invalidate_current_column ();
3327 set_buffer_internal (cur
);
3332 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
3333 doc
: /* Execute BODY, saving and restoring current buffer's restrictions.
3334 The buffer's restrictions make parts of the beginning and end invisible.
3335 \(They are set up with `narrow-to-region' and eliminated with `widen'.)
3336 This special form, `save-restriction', saves the current buffer's restrictions
3337 when it is entered, and restores them when it is exited.
3338 So any `narrow-to-region' within BODY lasts only until the end of the form.
3339 The old restrictions settings are restored
3340 even in case of abnormal exit (throw or error).
3342 The value returned is the value of the last form in BODY.
3344 Note: if you are using both `save-excursion' and `save-restriction',
3345 use `save-excursion' outermost:
3346 (save-excursion (save-restriction ...))
3348 usage: (save-restriction &rest BODY) */)
3351 register Lisp_Object val
;
3352 int count
= SPECPDL_INDEX ();
3354 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
3355 val
= Fprogn (body
);
3356 return unbind_to (count
, val
);
3359 /* Buffer for the most recent text displayed by Fmessage_box. */
3360 static char *message_text
;
3362 /* Allocated length of that buffer. */
3363 static ptrdiff_t message_length
;
3365 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
3366 doc
: /* Display a message at the bottom of the screen.
3367 The message also goes into the `*Messages*' buffer.
3368 \(In keyboard macros, that's all it does.)
3371 The first argument is a format control string, and the rest are data
3372 to be formatted under control of the string. See `format' for details.
3374 Note: Use (message "%s" VALUE) to print the value of expressions and
3375 variables to avoid accidentally interpreting `%' as format specifiers.
3377 If the first argument is nil or the empty string, the function clears
3378 any existing message; this lets the minibuffer contents show. See
3379 also `current-message'.
3381 usage: (message FORMAT-STRING &rest ARGS) */)
3382 (ptrdiff_t nargs
, Lisp_Object
*args
)
3385 || (STRINGP (args
[0])
3386 && SBYTES (args
[0]) == 0))
3393 register Lisp_Object val
;
3394 val
= Fformat (nargs
, args
);
3395 message3 (val
, SBYTES (val
), STRING_MULTIBYTE (val
));
3400 DEFUN ("message-box", Fmessage_box
, Smessage_box
, 1, MANY
, 0,
3401 doc
: /* Display a message, in a dialog box if possible.
3402 If a dialog box is not available, use the echo area.
3403 The first argument is a format control string, and the rest are data
3404 to be formatted under control of the string. See `format' for details.
3406 If the first argument is nil or the empty string, clear any existing
3407 message; let the minibuffer contents show.
3409 usage: (message-box FORMAT-STRING &rest ARGS) */)
3410 (ptrdiff_t nargs
, Lisp_Object
*args
)
3419 register Lisp_Object val
;
3420 val
= Fformat (nargs
, args
);
3422 /* The MS-DOS frames support popup menus even though they are
3423 not FRAME_WINDOW_P. */
3424 if (FRAME_WINDOW_P (XFRAME (selected_frame
))
3425 || FRAME_MSDOS_P (XFRAME (selected_frame
)))
3427 Lisp_Object pane
, menu
;
3428 struct gcpro gcpro1
;
3429 pane
= Fcons (Fcons (build_string ("OK"), Qt
), Qnil
);
3431 menu
= Fcons (val
, pane
);
3432 Fx_popup_dialog (Qt
, menu
, Qt
);
3436 #endif /* HAVE_MENUS */
3437 /* Copy the data so that it won't move when we GC. */
3440 message_text
= (char *)xmalloc (80);
3441 message_length
= 80;
3443 if (SBYTES (val
) > message_length
)
3445 message_text
= (char *) xrealloc (message_text
, SBYTES (val
));
3446 message_length
= SBYTES (val
);
3448 memcpy (message_text
, SDATA (val
), SBYTES (val
));
3449 message2 (message_text
, SBYTES (val
),
3450 STRING_MULTIBYTE (val
));
3455 DEFUN ("message-or-box", Fmessage_or_box
, Smessage_or_box
, 1, MANY
, 0,
3456 doc
: /* Display a message in a dialog box or in the echo area.
3457 If this command was invoked with the mouse, use a dialog box if
3458 `use-dialog-box' is non-nil.
3459 Otherwise, use the echo area.
3460 The first argument is a format control string, and the rest are data
3461 to be formatted under control of the string. See `format' for details.
3463 If the first argument is nil or the empty string, clear any existing
3464 message; let the minibuffer contents show.
3466 usage: (message-or-box FORMAT-STRING &rest ARGS) */)
3467 (ptrdiff_t nargs
, Lisp_Object
*args
)
3470 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3472 return Fmessage_box (nargs
, args
);
3474 return Fmessage (nargs
, args
);
3477 DEFUN ("current-message", Fcurrent_message
, Scurrent_message
, 0, 0, 0,
3478 doc
: /* Return the string currently displayed in the echo area, or nil if none. */)
3481 return current_message ();
3485 DEFUN ("propertize", Fpropertize
, Spropertize
, 1, MANY
, 0,
3486 doc
: /* Return a copy of STRING with text properties added.
3487 First argument is the string to copy.
3488 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
3489 properties to add to the result.
3490 usage: (propertize STRING &rest PROPERTIES) */)
3491 (ptrdiff_t nargs
, Lisp_Object
*args
)
3493 Lisp_Object properties
, string
;
3494 struct gcpro gcpro1
, gcpro2
;
3497 /* Number of args must be odd. */
3498 if ((nargs
& 1) == 0)
3499 error ("Wrong number of arguments");
3501 properties
= string
= Qnil
;
3502 GCPRO2 (properties
, string
);
3504 /* First argument must be a string. */
3505 CHECK_STRING (args
[0]);
3506 string
= Fcopy_sequence (args
[0]);
3508 for (i
= 1; i
< nargs
; i
+= 2)
3509 properties
= Fcons (args
[i
], Fcons (args
[i
+ 1], properties
));
3511 Fadd_text_properties (make_number (0),
3512 make_number (SCHARS (string
)),
3513 properties
, string
);
3514 RETURN_UNGCPRO (string
);
3517 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
3518 doc
: /* Format a string out of a format-string and arguments.
3519 The first argument is a format control string.
3520 The other arguments are substituted into it to make the result, a string.
3522 The format control string may contain %-sequences meaning to substitute
3523 the next available argument:
3525 %s means print a string argument. Actually, prints any object, with `princ'.
3526 %d means print as number in decimal (%o octal, %x hex).
3527 %X is like %x, but uses upper case.
3528 %e means print a number in exponential notation.
3529 %f means print a number in decimal-point notation.
3530 %g means print a number in exponential notation
3531 or decimal-point notation, whichever uses fewer characters.
3532 %c means print a number as a single character.
3533 %S means print any object as an s-expression (using `prin1').
3535 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.
3536 Use %% to put a single % into the output.
3538 A %-sequence may contain optional flag, width, and precision
3539 specifiers, as follows:
3541 %<flags><width><precision>character
3543 where flags is [+ #-0]+, width is [0-9]+, and precision is .[0-9]+
3545 The + flag character inserts a + before any positive number, while a
3546 space inserts a space before any positive number; these flags only
3547 affect %d, %e, %f, and %g sequences, and the + flag takes precedence.
3548 The # flag means to use an alternate display form for %o, %x, %X, %e,
3549 %f, and %g sequences. The - and 0 flags affect the width specifier,
3552 The width specifier supplies a lower limit for the length of the
3553 printed representation. The padding, if any, normally goes on the
3554 left, but it goes on the right if the - flag is present. The padding
3555 character is normally a space, but it is 0 if the 0 flag is present.
3556 The 0 flag is ignored if the - flag is present, or the format sequence
3557 is something other than %d, %e, %f, and %g.
3559 For %e, %f, and %g sequences, the number after the "." in the
3560 precision specifier says how many decimal places to show; if zero, the
3561 decimal point itself is omitted. For %s and %S, the precision
3562 specifier truncates the string to the given width.
3564 usage: (format STRING &rest OBJECTS) */)
3565 (ptrdiff_t nargs
, Lisp_Object
*args
)
3567 ptrdiff_t n
; /* The number of the next arg to substitute */
3568 char initial_buffer
[4000];
3569 char *buf
= initial_buffer
;
3570 EMACS_INT bufsize
= sizeof initial_buffer
;
3571 EMACS_INT max_bufsize
= STRING_BYTES_BOUND
+ 1;
3573 Lisp_Object buf_save_value
IF_LINT (= {0});
3574 register char *format
, *end
, *format_start
;
3575 EMACS_INT formatlen
, nchars
;
3576 /* Nonzero if the format is multibyte. */
3577 int multibyte_format
= 0;
3578 /* Nonzero if the output should be a multibyte string,
3579 which is true if any of the inputs is one. */
3581 /* When we make a multibyte string, we must pay attention to the
3582 byte combining problem, i.e., a byte may be combined with a
3583 multibyte character of the previous string. This flag tells if we
3584 must consider such a situation or not. */
3585 int maybe_combine_byte
;
3587 int arg_intervals
= 0;
3590 /* discarded[I] is 1 if byte I of the format
3591 string was not copied into the output.
3592 It is 2 if byte I was not the first byte of its character. */
3595 /* Each element records, for one argument,
3596 the start and end bytepos in the output string,
3597 whether the argument has been converted to string (e.g., due to "%S"),
3598 and whether the argument is a string with intervals.
3599 info[0] is unused. Unused elements have -1 for start. */
3602 EMACS_INT start
, end
;
3603 int converted_to_string
;
3607 /* It should not be necessary to GCPRO ARGS, because
3608 the caller in the interpreter should take care of that. */
3610 CHECK_STRING (args
[0]);
3611 format_start
= SSDATA (args
[0]);
3612 formatlen
= SBYTES (args
[0]);
3614 /* Allocate the info and discarded tables. */
3617 if ((SIZE_MAX
- formatlen
) / sizeof (struct info
) <= nargs
)
3618 memory_full (SIZE_MAX
);
3619 SAFE_ALLOCA (info
, struct info
*, (nargs
+ 1) * sizeof *info
+ formatlen
);
3620 discarded
= (char *) &info
[nargs
+ 1];
3621 for (i
= 0; i
< nargs
+ 1; i
++)
3624 info
[i
].intervals
= info
[i
].converted_to_string
= 0;
3626 memset (discarded
, 0, formatlen
);
3629 /* Try to determine whether the result should be multibyte.
3630 This is not always right; sometimes the result needs to be multibyte
3631 because of an object that we will pass through prin1,
3632 and in that case, we won't know it here. */
3633 multibyte_format
= STRING_MULTIBYTE (args
[0]);
3634 multibyte
= multibyte_format
;
3635 for (n
= 1; !multibyte
&& n
< nargs
; n
++)
3636 if (STRINGP (args
[n
]) && STRING_MULTIBYTE (args
[n
]))
3639 /* If we start out planning a unibyte result,
3640 then discover it has to be multibyte, we jump back to retry. */
3647 /* Scan the format and store result in BUF. */
3648 format
= format_start
;
3649 end
= format
+ formatlen
;
3650 maybe_combine_byte
= 0;
3652 while (format
!= end
)
3654 /* The values of N and FORMAT when the loop body is entered. */
3656 char *format0
= format
;
3658 /* Bytes needed to represent the output of this conversion. */
3659 EMACS_INT convbytes
;
3663 /* General format specifications look like
3665 '%' [flags] [field-width] [precision] format
3670 field-width ::= [0-9]+
3671 precision ::= '.' [0-9]*
3673 If a field-width is specified, it specifies to which width
3674 the output should be padded with blanks, if the output
3675 string is shorter than field-width.
3677 If precision is specified, it specifies the number of
3678 digits to print after the '.' for floats, or the max.
3679 number of chars to print from a string. */
3686 EMACS_INT field_width
;
3687 int precision_given
;
3688 uintmax_t precision
= UINTMAX_MAX
;
3696 case '-': minus_flag
= 1; continue;
3697 case '+': plus_flag
= 1; continue;
3698 case ' ': space_flag
= 1; continue;
3699 case '#': sharp_flag
= 1; continue;
3700 case '0': zero_flag
= 1; continue;
3705 /* Ignore flags when sprintf ignores them. */
3706 space_flag
&= ~ plus_flag
;
3707 zero_flag
&= ~ minus_flag
;
3710 uintmax_t w
= strtoumax (format
, &num_end
, 10);
3711 if (max_bufsize
<= w
)
3715 precision_given
= *num_end
== '.';
3716 if (precision_given
)
3717 precision
= strtoumax (num_end
+ 1, &num_end
, 10);
3721 error ("Format string ends in middle of format specifier");
3723 memset (&discarded
[format0
- format_start
], 1, format
- format0
);
3724 conversion
= *format
;
3725 if (conversion
== '%')
3727 discarded
[format
- format_start
] = 1;
3732 error ("Not enough arguments for format string");
3734 /* For 'S', prin1 the argument, and then treat like 's'.
3735 For 's', princ any argument that is not a string or
3736 symbol. But don't do this conversion twice, which might
3737 happen after retrying. */
3738 if ((conversion
== 'S'
3739 || (conversion
== 's'
3740 && ! STRINGP (args
[n
]) && ! SYMBOLP (args
[n
]))))
3742 if (! info
[n
].converted_to_string
)
3744 Lisp_Object noescape
= conversion
== 'S' ? Qnil
: Qt
;
3745 args
[n
] = Fprin1_to_string (args
[n
], noescape
);
3746 info
[n
].converted_to_string
= 1;
3747 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
3755 else if (conversion
== 'c')
3757 if (FLOATP (args
[n
]))
3759 double d
= XFLOAT_DATA (args
[n
]);
3760 args
[n
] = make_number (FIXNUM_OVERFLOW_P (d
) ? -1 : d
);
3763 if (INTEGERP (args
[n
]) && ! ASCII_CHAR_P (XINT (args
[n
])))
3770 args
[n
] = Fchar_to_string (args
[n
]);
3771 info
[n
].converted_to_string
= 1;
3774 if (info
[n
].converted_to_string
)
3779 if (SYMBOLP (args
[n
]))
3781 args
[n
] = SYMBOL_NAME (args
[n
]);
3782 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
3789 if (conversion
== 's')
3791 /* handle case (precision[n] >= 0) */
3793 EMACS_INT width
, padding
, nbytes
;
3794 EMACS_INT nchars_string
;
3796 EMACS_INT prec
= -1;
3797 if (precision_given
&& precision
<= TYPE_MAXIMUM (EMACS_INT
))
3800 /* lisp_string_width ignores a precision of 0, but GNU
3801 libc functions print 0 characters when the precision
3802 is 0. Imitate libc behavior here. Changing
3803 lisp_string_width is the right thing, and will be
3804 done, but meanwhile we work with it. */
3807 width
= nchars_string
= nbytes
= 0;
3811 width
= lisp_string_width (args
[n
], prec
, &nch
, &nby
);
3814 nchars_string
= SCHARS (args
[n
]);
3815 nbytes
= SBYTES (args
[n
]);
3819 nchars_string
= nch
;
3825 if (convbytes
&& multibyte
&& ! STRING_MULTIBYTE (args
[n
]))
3826 convbytes
= count_size_as_multibyte (SDATA (args
[n
]), nbytes
);
3828 padding
= width
< field_width
? field_width
- width
: 0;
3830 if (max_bufsize
- padding
<= convbytes
)
3832 convbytes
+= padding
;
3833 if (convbytes
<= buf
+ bufsize
- p
)
3837 memset (p
, ' ', padding
);
3844 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3845 && STRING_MULTIBYTE (args
[n
])
3846 && !CHAR_HEAD_P (SREF (args
[n
], 0)))
3847 maybe_combine_byte
= 1;
3849 p
+= copy_text (SDATA (args
[n
]), (unsigned char *) p
,
3851 STRING_MULTIBYTE (args
[n
]), multibyte
);
3853 info
[n
].start
= nchars
;
3854 nchars
+= nchars_string
;
3855 info
[n
].end
= nchars
;
3859 memset (p
, ' ', padding
);
3864 /* If this argument has text properties, record where
3865 in the result string it appears. */
3866 if (STRING_INTERVALS (args
[n
]))
3867 info
[n
].intervals
= arg_intervals
= 1;
3872 else if (! (conversion
== 'c' || conversion
== 'd'
3873 || conversion
== 'e' || conversion
== 'f'
3874 || conversion
== 'g' || conversion
== 'i'
3875 || conversion
== 'o' || conversion
== 'x'
3876 || conversion
== 'X'))
3877 error ("Invalid format operation %%%c",
3878 STRING_CHAR ((unsigned char *) format
- 1));
3879 else if (! (INTEGERP (args
[n
]) || FLOATP (args
[n
])))
3880 error ("Format specifier doesn't match argument type");
3885 /* Maximum precision for a %f conversion such that the
3886 trailing output digit might be nonzero. Any precision
3887 larger than this will not yield useful information. */
3888 USEFUL_PRECISION_MAX
=
3890 * (FLT_RADIX
== 2 || FLT_RADIX
== 10 ? 1
3891 : FLT_RADIX
== 16 ? 4
3894 /* Maximum number of bytes generated by any format, if
3895 precision is no more than USEFUL_PRECISION_MAX.
3896 On all practical hosts, %f is the worst case. */
3898 sizeof "-." + (DBL_MAX_10_EXP
+ 1) + USEFUL_PRECISION_MAX
,
3900 /* Length of pM (that is, of pMd without the
3902 pMlen
= sizeof pMd
- 2
3904 verify (0 < USEFUL_PRECISION_MAX
);
3907 EMACS_INT padding
, sprintf_bytes
;
3908 uintmax_t excess_precision
, numwidth
;
3909 uintmax_t leading_zeros
= 0, trailing_zeros
= 0;
3911 char sprintf_buf
[SPRINTF_BUFSIZE
];
3913 /* Copy of conversion specification, modified somewhat.
3914 At most three flags F can be specified at once. */
3915 char convspec
[sizeof "%FFF.*d" + pMlen
];
3917 /* Avoid undefined behavior in underlying sprintf. */
3918 if (conversion
== 'd' || conversion
== 'i')
3921 /* Create the copy of the conversion specification, with
3922 any width and precision removed, with ".*" inserted,
3923 and with pM inserted for integer formats. */
3927 *f
= '-'; f
+= minus_flag
;
3928 *f
= '+'; f
+= plus_flag
;
3929 *f
= ' '; f
+= space_flag
;
3930 *f
= '#'; f
+= sharp_flag
;
3931 *f
= '0'; f
+= zero_flag
;
3934 if (conversion
== 'd' || conversion
== 'i'
3935 || conversion
== 'o' || conversion
== 'x'
3936 || conversion
== 'X')
3938 memcpy (f
, pMd
, pMlen
);
3940 zero_flag
&= ~ precision_given
;
3947 if (precision_given
)
3948 prec
= min (precision
, USEFUL_PRECISION_MAX
);
3950 /* Use sprintf to format this number into sprintf_buf. Omit
3951 padding and excess precision, though, because sprintf limits
3952 output length to INT_MAX.
3954 There are four types of conversion: double, unsigned
3955 char (passed as int), wide signed int, and wide
3956 unsigned int. Treat them separately because the
3957 sprintf ABI is sensitive to which type is passed. Be
3958 careful about integer overflow, NaNs, infinities, and
3959 conversions; for example, the min and max macros are
3960 not suitable here. */
3961 if (conversion
== 'e' || conversion
== 'f' || conversion
== 'g')
3963 double x
= (INTEGERP (args
[n
])
3965 : XFLOAT_DATA (args
[n
]));
3966 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
3968 else if (conversion
== 'c')
3970 /* Don't use sprintf here, as it might mishandle prec. */
3971 sprintf_buf
[0] = XINT (args
[n
]);
3972 sprintf_bytes
= prec
!= 0;
3974 else if (conversion
== 'd')
3976 /* For float, maybe we should use "%1.0f"
3977 instead so it also works for values outside
3978 the integer range. */
3980 if (INTEGERP (args
[n
]))
3984 double d
= XFLOAT_DATA (args
[n
]);
3987 x
= TYPE_MINIMUM (printmax_t
);
3993 x
= TYPE_MAXIMUM (printmax_t
);
3998 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4002 /* Don't sign-extend for octal or hex printing. */
4004 if (INTEGERP (args
[n
]))
4005 x
= XUINT (args
[n
]);
4008 double d
= XFLOAT_DATA (args
[n
]);
4013 x
= TYPE_MAXIMUM (uprintmax_t
);
4018 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4021 /* Now the length of the formatted item is known, except it omits
4022 padding and excess precision. Deal with excess precision
4023 first. This happens only when the format specifies
4024 ridiculously large precision. */
4025 excess_precision
= precision
- prec
;
4026 if (excess_precision
)
4028 if (conversion
== 'e' || conversion
== 'f'
4029 || conversion
== 'g')
4031 if ((conversion
== 'g' && ! sharp_flag
)
4032 || ! ('0' <= sprintf_buf
[sprintf_bytes
- 1]
4033 && sprintf_buf
[sprintf_bytes
- 1] <= '9'))
4034 excess_precision
= 0;
4037 if (conversion
== 'g')
4039 char *dot
= strchr (sprintf_buf
, '.');
4041 excess_precision
= 0;
4044 trailing_zeros
= excess_precision
;
4047 leading_zeros
= excess_precision
;
4050 /* Compute the total bytes needed for this item, including
4051 excess precision and padding. */
4052 numwidth
= sprintf_bytes
+ excess_precision
;
4053 padding
= numwidth
< field_width
? field_width
- numwidth
: 0;
4054 if (max_bufsize
- sprintf_bytes
<= excess_precision
4055 || max_bufsize
- padding
<= numwidth
)
4057 convbytes
= numwidth
+ padding
;
4059 if (convbytes
<= buf
+ bufsize
- p
)
4061 /* Copy the formatted item from sprintf_buf into buf,
4062 inserting padding and excess-precision zeros. */
4064 char *src
= sprintf_buf
;
4066 int exponent_bytes
= 0;
4067 int signedp
= src0
== '-' || src0
== '+' || src0
== ' ';
4068 int significand_bytes
;
4070 && ((src
[signedp
] >= '0' && src
[signedp
] <= '9')
4071 || (src
[signedp
] >= 'a' && src
[signedp
] <= 'f')
4072 || (src
[signedp
] >= 'A' && src
[signedp
] <= 'F')))
4074 leading_zeros
+= padding
;
4078 if (excess_precision
4079 && (conversion
== 'e' || conversion
== 'g'))
4081 char *e
= strchr (src
, 'e');
4083 exponent_bytes
= src
+ sprintf_bytes
- e
;
4088 memset (p
, ' ', padding
);
4096 memset (p
, '0', leading_zeros
);
4098 significand_bytes
= sprintf_bytes
- signedp
- exponent_bytes
;
4099 memcpy (p
, src
, significand_bytes
);
4100 p
+= significand_bytes
;
4101 src
+= significand_bytes
;
4102 memset (p
, '0', trailing_zeros
);
4103 p
+= trailing_zeros
;
4104 memcpy (p
, src
, exponent_bytes
);
4105 p
+= exponent_bytes
;
4107 info
[n
].start
= nchars
;
4108 nchars
+= leading_zeros
+ sprintf_bytes
+ trailing_zeros
;
4109 info
[n
].end
= nchars
;
4113 memset (p
, ' ', padding
);
4125 /* Copy a single character from format to buf. */
4128 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
4130 if (multibyte_format
)
4132 /* Copy a whole multibyte character. */
4134 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
4135 && !CHAR_HEAD_P (*format
))
4136 maybe_combine_byte
= 1;
4140 while (! CHAR_HEAD_P (*format
));
4142 convbytes
= format
- src
;
4143 memset (&discarded
[src
+ 1 - format_start
], 2, convbytes
- 1);
4147 unsigned char uc
= *format
++;
4148 if (! multibyte
|| ASCII_BYTE_P (uc
))
4152 int c
= BYTE8_TO_CHAR (uc
);
4153 convbytes
= CHAR_STRING (c
, str
);
4158 if (convbytes
<= buf
+ bufsize
- p
)
4160 memcpy (p
, src
, convbytes
);
4167 /* There wasn't enough room to store this conversion or single
4168 character. CONVBYTES says how much room is needed. Allocate
4169 enough room (and then some) and do it again. */
4171 ptrdiff_t used
= p
- buf
;
4173 if (max_bufsize
- used
< convbytes
)
4175 bufsize
= used
+ convbytes
;
4176 bufsize
= bufsize
< max_bufsize
/ 2 ? bufsize
* 2 : max_bufsize
;
4178 if (buf
== initial_buffer
)
4180 buf
= xmalloc (bufsize
);
4182 buf_save_value
= make_save_value (buf
, 0);
4183 record_unwind_protect (safe_alloca_unwind
, buf_save_value
);
4184 memcpy (buf
, initial_buffer
, used
);
4187 XSAVE_VALUE (buf_save_value
)->pointer
= buf
= xrealloc (buf
, bufsize
);
4196 if (bufsize
< p
- buf
)
4199 if (maybe_combine_byte
)
4200 nchars
= multibyte_chars_in_text ((unsigned char *) buf
, p
- buf
);
4201 val
= make_specified_string (buf
, nchars
, p
- buf
, multibyte
);
4203 /* If we allocated BUF with malloc, free it too. */
4206 /* If the format string has text properties, or any of the string
4207 arguments has text properties, set up text properties of the
4210 if (STRING_INTERVALS (args
[0]) || arg_intervals
)
4212 Lisp_Object len
, new_len
, props
;
4213 struct gcpro gcpro1
;
4215 /* Add text properties from the format string. */
4216 len
= make_number (SCHARS (args
[0]));
4217 props
= text_property_list (args
[0], make_number (0), len
, Qnil
);
4222 EMACS_INT bytepos
= 0, position
= 0, translated
= 0;
4226 /* Adjust the bounds of each text property
4227 to the proper start and end in the output string. */
4229 /* Put the positions in PROPS in increasing order, so that
4230 we can do (effectively) one scan through the position
4231 space of the format string. */
4232 props
= Fnreverse (props
);
4234 /* BYTEPOS is the byte position in the format string,
4235 POSITION is the untranslated char position in it,
4236 TRANSLATED is the translated char position in BUF,
4237 and ARGN is the number of the next arg we will come to. */
4238 for (list
= props
; CONSP (list
); list
= XCDR (list
))
4245 /* First adjust the property start position. */
4246 pos
= XINT (XCAR (item
));
4248 /* Advance BYTEPOS, POSITION, TRANSLATED and ARGN
4249 up to this position. */
4250 for (; position
< pos
; bytepos
++)
4252 if (! discarded
[bytepos
])
4253 position
++, translated
++;
4254 else if (discarded
[bytepos
] == 1)
4257 if (translated
== info
[argn
].start
)
4259 translated
+= info
[argn
].end
- info
[argn
].start
;
4265 XSETCAR (item
, make_number (translated
));
4267 /* Likewise adjust the property end position. */
4268 pos
= XINT (XCAR (XCDR (item
)));
4270 for (; position
< pos
; bytepos
++)
4272 if (! discarded
[bytepos
])
4273 position
++, translated
++;
4274 else if (discarded
[bytepos
] == 1)
4277 if (translated
== info
[argn
].start
)
4279 translated
+= info
[argn
].end
- info
[argn
].start
;
4285 XSETCAR (XCDR (item
), make_number (translated
));
4288 add_text_properties_from_list (val
, props
, make_number (0));
4291 /* Add text properties from arguments. */
4293 for (n
= 1; n
< nargs
; ++n
)
4294 if (info
[n
].intervals
)
4296 len
= make_number (SCHARS (args
[n
]));
4297 new_len
= make_number (info
[n
].end
- info
[n
].start
);
4298 props
= text_property_list (args
[n
], make_number (0), len
, Qnil
);
4299 props
= extend_property_ranges (props
, new_len
);
4300 /* If successive arguments have properties, be sure that
4301 the value of `composition' property be the copy. */
4302 if (n
> 1 && info
[n
- 1].end
)
4303 make_composition_value_copy (props
);
4304 add_text_properties_from_list (val
, props
,
4305 make_number (info
[n
].start
));
4315 format2 (const char *string1
, Lisp_Object arg0
, Lisp_Object arg1
)
4317 Lisp_Object args
[3];
4318 args
[0] = build_string (string1
);
4321 return Fformat (3, args
);
4324 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
4325 doc
: /* Return t if two characters match, optionally ignoring case.
4326 Both arguments must be characters (i.e. integers).
4327 Case is ignored if `case-fold-search' is non-nil in the current buffer. */)
4328 (register Lisp_Object c1
, Lisp_Object c2
)
4331 /* Check they're chars, not just integers, otherwise we could get array
4332 bounds violations in downcase. */
4333 CHECK_CHARACTER (c1
);
4334 CHECK_CHARACTER (c2
);
4336 if (XINT (c1
) == XINT (c2
))
4338 if (NILP (BVAR (current_buffer
, case_fold_search
)))
4342 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
))
4343 && ! ASCII_CHAR_P (i1
))
4345 MAKE_CHAR_MULTIBYTE (i1
);
4348 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
))
4349 && ! ASCII_CHAR_P (i2
))
4351 MAKE_CHAR_MULTIBYTE (i2
);
4353 return (downcase (i1
) == downcase (i2
) ? Qt
: Qnil
);
4356 /* Transpose the markers in two regions of the current buffer, and
4357 adjust the ones between them if necessary (i.e.: if the regions
4360 START1, END1 are the character positions of the first region.
4361 START1_BYTE, END1_BYTE are the byte positions.
4362 START2, END2 are the character positions of the second region.
4363 START2_BYTE, END2_BYTE are the byte positions.
4365 Traverses the entire marker list of the buffer to do so, adding an
4366 appropriate amount to some, subtracting from some, and leaving the
4367 rest untouched. Most of this is copied from adjust_markers in insdel.c.
4369 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
4372 transpose_markers (EMACS_INT start1
, EMACS_INT end1
,
4373 EMACS_INT start2
, EMACS_INT end2
,
4374 EMACS_INT start1_byte
, EMACS_INT end1_byte
,
4375 EMACS_INT start2_byte
, EMACS_INT end2_byte
)
4377 register EMACS_INT amt1
, amt1_byte
, amt2
, amt2_byte
, diff
, diff_byte
, mpos
;
4378 register struct Lisp_Marker
*marker
;
4380 /* Update point as if it were a marker. */
4384 TEMP_SET_PT_BOTH (PT
+ (end2
- end1
),
4385 PT_BYTE
+ (end2_byte
- end1_byte
));
4386 else if (PT
< start2
)
4387 TEMP_SET_PT_BOTH (PT
+ (end2
- start2
) - (end1
- start1
),
4388 (PT_BYTE
+ (end2_byte
- start2_byte
)
4389 - (end1_byte
- start1_byte
)));
4391 TEMP_SET_PT_BOTH (PT
- (start2
- start1
),
4392 PT_BYTE
- (start2_byte
- start1_byte
));
4394 /* We used to adjust the endpoints here to account for the gap, but that
4395 isn't good enough. Even if we assume the caller has tried to move the
4396 gap out of our way, it might still be at start1 exactly, for example;
4397 and that places it `inside' the interval, for our purposes. The amount
4398 of adjustment is nontrivial if there's a `denormalized' marker whose
4399 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
4400 the dirty work to Fmarker_position, below. */
4402 /* The difference between the region's lengths */
4403 diff
= (end2
- start2
) - (end1
- start1
);
4404 diff_byte
= (end2_byte
- start2_byte
) - (end1_byte
- start1_byte
);
4406 /* For shifting each marker in a region by the length of the other
4407 region plus the distance between the regions. */
4408 amt1
= (end2
- start2
) + (start2
- end1
);
4409 amt2
= (end1
- start1
) + (start2
- end1
);
4410 amt1_byte
= (end2_byte
- start2_byte
) + (start2_byte
- end1_byte
);
4411 amt2_byte
= (end1_byte
- start1_byte
) + (start2_byte
- end1_byte
);
4413 for (marker
= BUF_MARKERS (current_buffer
); marker
; marker
= marker
->next
)
4415 mpos
= marker
->bytepos
;
4416 if (mpos
>= start1_byte
&& mpos
< end2_byte
)
4418 if (mpos
< end1_byte
)
4420 else if (mpos
< start2_byte
)
4424 marker
->bytepos
= mpos
;
4426 mpos
= marker
->charpos
;
4427 if (mpos
>= start1
&& mpos
< end2
)
4431 else if (mpos
< start2
)
4436 marker
->charpos
= mpos
;
4440 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
4441 doc
: /* Transpose region STARTR1 to ENDR1 with STARTR2 to ENDR2.
4442 The regions should not be overlapping, because the size of the buffer is
4443 never changed in a transposition.
4445 Optional fifth arg LEAVE-MARKERS, if non-nil, means don't update
4446 any markers that happen to be located in the regions.
4448 Transposing beyond buffer boundaries is an error. */)
4449 (Lisp_Object startr1
, Lisp_Object endr1
, Lisp_Object startr2
, Lisp_Object endr2
, Lisp_Object leave_markers
)
4451 register EMACS_INT start1
, end1
, start2
, end2
;
4452 EMACS_INT start1_byte
, start2_byte
, len1_byte
, len2_byte
;
4453 EMACS_INT gap
, len1
, len_mid
, len2
;
4454 unsigned char *start1_addr
, *start2_addr
, *temp
;
4456 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
, tmp_interval3
;
4459 XSETBUFFER (buf
, current_buffer
);
4460 cur_intv
= BUF_INTERVALS (current_buffer
);
4462 validate_region (&startr1
, &endr1
);
4463 validate_region (&startr2
, &endr2
);
4465 start1
= XFASTINT (startr1
);
4466 end1
= XFASTINT (endr1
);
4467 start2
= XFASTINT (startr2
);
4468 end2
= XFASTINT (endr2
);
4471 /* Swap the regions if they're reversed. */
4474 register EMACS_INT glumph
= start1
;
4482 len1
= end1
- start1
;
4483 len2
= end2
- start2
;
4486 error ("Transposed regions overlap");
4487 /* Nothing to change for adjacent regions with one being empty */
4488 else if ((start1
== end1
|| start2
== end2
) && end1
== start2
)
4491 /* The possibilities are:
4492 1. Adjacent (contiguous) regions, or separate but equal regions
4493 (no, really equal, in this case!), or
4494 2. Separate regions of unequal size.
4496 The worst case is usually No. 2. It means that (aside from
4497 potential need for getting the gap out of the way), there also
4498 needs to be a shifting of the text between the two regions. So
4499 if they are spread far apart, we are that much slower... sigh. */
4501 /* It must be pointed out that the really studly thing to do would
4502 be not to move the gap at all, but to leave it in place and work
4503 around it if necessary. This would be extremely efficient,
4504 especially considering that people are likely to do
4505 transpositions near where they are working interactively, which
4506 is exactly where the gap would be found. However, such code
4507 would be much harder to write and to read. So, if you are
4508 reading this comment and are feeling squirrely, by all means have
4509 a go! I just didn't feel like doing it, so I will simply move
4510 the gap the minimum distance to get it out of the way, and then
4511 deal with an unbroken array. */
4513 /* Make sure the gap won't interfere, by moving it out of the text
4514 we will operate on. */
4515 if (start1
< gap
&& gap
< end2
)
4517 if (gap
- start1
< end2
- gap
)
4523 start1_byte
= CHAR_TO_BYTE (start1
);
4524 start2_byte
= CHAR_TO_BYTE (start2
);
4525 len1_byte
= CHAR_TO_BYTE (end1
) - start1_byte
;
4526 len2_byte
= CHAR_TO_BYTE (end2
) - start2_byte
;
4528 #ifdef BYTE_COMBINING_DEBUG
4531 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4532 len2_byte
, start1
, start1_byte
)
4533 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4534 len1_byte
, end2
, start2_byte
+ len2_byte
)
4535 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4536 len1_byte
, end2
, start2_byte
+ len2_byte
))
4541 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4542 len2_byte
, start1
, start1_byte
)
4543 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4544 len1_byte
, start2
, start2_byte
)
4545 || count_combining_after (BYTE_POS_ADDR (start2_byte
),
4546 len2_byte
, end1
, start1_byte
+ len1_byte
)
4547 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4548 len1_byte
, end2
, start2_byte
+ len2_byte
))
4553 /* Hmmm... how about checking to see if the gap is large
4554 enough to use as the temporary storage? That would avoid an
4555 allocation... interesting. Later, don't fool with it now. */
4557 /* Working without memmove, for portability (sigh), so must be
4558 careful of overlapping subsections of the array... */
4560 if (end1
== start2
) /* adjacent regions */
4562 modify_region (current_buffer
, start1
, end2
, 0);
4563 record_change (start1
, len1
+ len2
);
4565 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4566 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4567 /* Don't use Fset_text_properties: that can cause GC, which can
4568 clobber objects stored in the tmp_intervals. */
4569 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4570 if (!NULL_INTERVAL_P (tmp_interval3
))
4571 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4573 /* First region smaller than second. */
4574 if (len1_byte
< len2_byte
)
4578 SAFE_ALLOCA (temp
, unsigned char *, len2_byte
);
4580 /* Don't precompute these addresses. We have to compute them
4581 at the last minute, because the relocating allocator might
4582 have moved the buffer around during the xmalloc. */
4583 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4584 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4586 memcpy (temp
, start2_addr
, len2_byte
);
4587 memcpy (start1_addr
+ len2_byte
, start1_addr
, len1_byte
);
4588 memcpy (start1_addr
, temp
, len2_byte
);
4592 /* First region not smaller than second. */
4596 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4597 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4598 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4599 memcpy (temp
, start1_addr
, len1_byte
);
4600 memcpy (start1_addr
, start2_addr
, len2_byte
);
4601 memcpy (start1_addr
+ len2_byte
, temp
, len1_byte
);
4604 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
4605 len1
, current_buffer
, 0);
4606 graft_intervals_into_buffer (tmp_interval2
, start1
,
4607 len2
, current_buffer
, 0);
4608 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4609 update_compositions (start1
+ len2
, end2
, CHECK_TAIL
);
4611 /* Non-adjacent regions, because end1 != start2, bleagh... */
4614 len_mid
= start2_byte
- (start1_byte
+ len1_byte
);
4616 if (len1_byte
== len2_byte
)
4617 /* Regions are same size, though, how nice. */
4621 modify_region (current_buffer
, start1
, end1
, 0);
4622 modify_region (current_buffer
, start2
, end2
, 0);
4623 record_change (start1
, len1
);
4624 record_change (start2
, len2
);
4625 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4626 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4628 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr1
, 0);
4629 if (!NULL_INTERVAL_P (tmp_interval3
))
4630 set_text_properties_1 (startr1
, endr1
, Qnil
, buf
, tmp_interval3
);
4632 tmp_interval3
= validate_interval_range (buf
, &startr2
, &endr2
, 0);
4633 if (!NULL_INTERVAL_P (tmp_interval3
))
4634 set_text_properties_1 (startr2
, endr2
, Qnil
, buf
, tmp_interval3
);
4636 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4637 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4638 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4639 memcpy (temp
, start1_addr
, len1_byte
);
4640 memcpy (start1_addr
, start2_addr
, len2_byte
);
4641 memcpy (start2_addr
, temp
, len1_byte
);
4644 graft_intervals_into_buffer (tmp_interval1
, start2
,
4645 len1
, current_buffer
, 0);
4646 graft_intervals_into_buffer (tmp_interval2
, start1
,
4647 len2
, current_buffer
, 0);
4650 else if (len1_byte
< len2_byte
) /* Second region larger than first */
4651 /* Non-adjacent & unequal size, area between must also be shifted. */
4655 modify_region (current_buffer
, start1
, end2
, 0);
4656 record_change (start1
, (end2
- start1
));
4657 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4658 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4659 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4661 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4662 if (!NULL_INTERVAL_P (tmp_interval3
))
4663 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4665 /* holds region 2 */
4666 SAFE_ALLOCA (temp
, unsigned char *, len2_byte
);
4667 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4668 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4669 memcpy (temp
, start2_addr
, len2_byte
);
4670 memcpy (start1_addr
+ len_mid
+ len2_byte
, start1_addr
, len1_byte
);
4671 memmove (start1_addr
+ len2_byte
, start1_addr
+ len1_byte
, len_mid
);
4672 memcpy (start1_addr
, temp
, len2_byte
);
4675 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4676 len1
, current_buffer
, 0);
4677 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4678 len_mid
, current_buffer
, 0);
4679 graft_intervals_into_buffer (tmp_interval2
, start1
,
4680 len2
, current_buffer
, 0);
4683 /* Second region smaller than first. */
4687 record_change (start1
, (end2
- start1
));
4688 modify_region (current_buffer
, start1
, end2
, 0);
4690 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4691 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4692 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4694 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4695 if (!NULL_INTERVAL_P (tmp_interval3
))
4696 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4698 /* holds region 1 */
4699 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4700 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4701 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4702 memcpy (temp
, start1_addr
, len1_byte
);
4703 memcpy (start1_addr
, start2_addr
, len2_byte
);
4704 memcpy (start1_addr
+ len2_byte
, start1_addr
+ len1_byte
, len_mid
);
4705 memcpy (start1_addr
+ len2_byte
+ len_mid
, temp
, len1_byte
);
4708 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4709 len1
, current_buffer
, 0);
4710 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4711 len_mid
, current_buffer
, 0);
4712 graft_intervals_into_buffer (tmp_interval2
, start1
,
4713 len2
, current_buffer
, 0);
4716 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4717 update_compositions (end2
- len1
, end2
, CHECK_BORDER
);
4720 /* When doing multiple transpositions, it might be nice
4721 to optimize this. Perhaps the markers in any one buffer
4722 should be organized in some sorted data tree. */
4723 if (NILP (leave_markers
))
4725 transpose_markers (start1
, end1
, start2
, end2
,
4726 start1_byte
, start1_byte
+ len1_byte
,
4727 start2_byte
, start2_byte
+ len2_byte
);
4728 fix_start_end_in_overlays (start1
, end2
);
4731 signal_after_change (start1
, end2
- start1
, end2
- start1
);
4737 syms_of_editfns (void)
4742 DEFSYM (Qbuffer_access_fontify_functions
, "buffer-access-fontify-functions");
4744 DEFVAR_LISP ("inhibit-field-text-motion", Vinhibit_field_text_motion
,
4745 doc
: /* Non-nil means text motion commands don't notice fields. */);
4746 Vinhibit_field_text_motion
= Qnil
;
4748 DEFVAR_LISP ("buffer-access-fontify-functions",
4749 Vbuffer_access_fontify_functions
,
4750 doc
: /* List of functions called by `buffer-substring' to fontify if necessary.
4751 Each function is called with two arguments which specify the range
4752 of the buffer being accessed. */);
4753 Vbuffer_access_fontify_functions
= Qnil
;
4757 obuf
= Fcurrent_buffer ();
4758 /* Do this here, because init_buffer_once is too early--it won't work. */
4759 Fset_buffer (Vprin1_to_string_buffer
);
4760 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
4761 Fset (Fmake_local_variable (intern_c_string ("buffer-access-fontify-functions")),
4766 DEFVAR_LISP ("buffer-access-fontified-property",
4767 Vbuffer_access_fontified_property
,
4768 doc
: /* Property which (if non-nil) indicates text has been fontified.
4769 `buffer-substring' need not call the `buffer-access-fontify-functions'
4770 functions if all the text being accessed has this property. */);
4771 Vbuffer_access_fontified_property
= Qnil
;
4773 DEFVAR_LISP ("system-name", Vsystem_name
,
4774 doc
: /* The host name of the machine Emacs is running on. */);
4776 DEFVAR_LISP ("user-full-name", Vuser_full_name
,
4777 doc
: /* The full name of the user logged in. */);
4779 DEFVAR_LISP ("user-login-name", Vuser_login_name
,
4780 doc
: /* The user's name, taken from environment variables if possible. */);
4782 DEFVAR_LISP ("user-real-login-name", Vuser_real_login_name
,
4783 doc
: /* The user's name, based upon the real uid only. */);
4785 DEFVAR_LISP ("operating-system-release", Voperating_system_release
,
4786 doc
: /* The release of the operating system Emacs is running on. */);
4788 defsubr (&Spropertize
);
4789 defsubr (&Schar_equal
);
4790 defsubr (&Sgoto_char
);
4791 defsubr (&Sstring_to_char
);
4792 defsubr (&Schar_to_string
);
4793 defsubr (&Sbyte_to_string
);
4794 defsubr (&Sbuffer_substring
);
4795 defsubr (&Sbuffer_substring_no_properties
);
4796 defsubr (&Sbuffer_string
);
4798 defsubr (&Spoint_marker
);
4799 defsubr (&Smark_marker
);
4801 defsubr (&Sregion_beginning
);
4802 defsubr (&Sregion_end
);
4804 DEFSYM (Qfield
, "field");
4805 DEFSYM (Qboundary
, "boundary");
4806 defsubr (&Sfield_beginning
);
4807 defsubr (&Sfield_end
);
4808 defsubr (&Sfield_string
);
4809 defsubr (&Sfield_string_no_properties
);
4810 defsubr (&Sdelete_field
);
4811 defsubr (&Sconstrain_to_field
);
4813 defsubr (&Sline_beginning_position
);
4814 defsubr (&Sline_end_position
);
4816 /* defsubr (&Smark); */
4817 /* defsubr (&Sset_mark); */
4818 defsubr (&Ssave_excursion
);
4819 defsubr (&Ssave_current_buffer
);
4821 defsubr (&Sbufsize
);
4822 defsubr (&Spoint_max
);
4823 defsubr (&Spoint_min
);
4824 defsubr (&Spoint_min_marker
);
4825 defsubr (&Spoint_max_marker
);
4826 defsubr (&Sgap_position
);
4827 defsubr (&Sgap_size
);
4828 defsubr (&Sposition_bytes
);
4829 defsubr (&Sbyte_to_position
);
4835 defsubr (&Sfollowing_char
);
4836 defsubr (&Sprevious_char
);
4837 defsubr (&Schar_after
);
4838 defsubr (&Schar_before
);
4840 defsubr (&Sinsert_before_markers
);
4841 defsubr (&Sinsert_and_inherit
);
4842 defsubr (&Sinsert_and_inherit_before_markers
);
4843 defsubr (&Sinsert_char
);
4844 defsubr (&Sinsert_byte
);
4846 defsubr (&Suser_login_name
);
4847 defsubr (&Suser_real_login_name
);
4848 defsubr (&Suser_uid
);
4849 defsubr (&Suser_real_uid
);
4850 defsubr (&Suser_full_name
);
4851 defsubr (&Semacs_pid
);
4852 defsubr (&Scurrent_time
);
4853 defsubr (&Sget_internal_run_time
);
4854 defsubr (&Sformat_time_string
);
4855 defsubr (&Sfloat_time
);
4856 defsubr (&Sdecode_time
);
4857 defsubr (&Sencode_time
);
4858 defsubr (&Scurrent_time_string
);
4859 defsubr (&Scurrent_time_zone
);
4860 defsubr (&Sset_time_zone_rule
);
4861 defsubr (&Ssystem_name
);
4862 defsubr (&Smessage
);
4863 defsubr (&Smessage_box
);
4864 defsubr (&Smessage_or_box
);
4865 defsubr (&Scurrent_message
);
4868 defsubr (&Sinsert_buffer_substring
);
4869 defsubr (&Scompare_buffer_substrings
);
4870 defsubr (&Ssubst_char_in_region
);
4871 defsubr (&Stranslate_region_internal
);
4872 defsubr (&Sdelete_region
);
4873 defsubr (&Sdelete_and_extract_region
);
4875 defsubr (&Snarrow_to_region
);
4876 defsubr (&Ssave_restriction
);
4877 defsubr (&Stranspose_regions
);