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"
66 #ifndef USER_FULL_NAME
67 #define USER_FULL_NAME pw->pw_gecos
71 extern char **environ
;
74 #define TM_YEAR_BASE 1900
76 /* Nonzero if TM_YEAR is a struct tm's tm_year value that causes
77 asctime to have well-defined behavior. */
78 #ifndef TM_YEAR_IN_ASCTIME_RANGE
79 # define TM_YEAR_IN_ASCTIME_RANGE(tm_year) \
80 (1000 - TM_YEAR_BASE <= (tm_year) && (tm_year) <= 9999 - TM_YEAR_BASE)
84 extern Lisp_Object
w32_get_internal_run_time (void);
87 static void time_overflow (void) NO_RETURN
;
88 static Lisp_Object
format_time_string (char const *, ptrdiff_t, Lisp_Object
,
89 int, time_t *, struct tm
*);
90 static int tm_diff (struct tm
*, struct tm
*);
91 static void update_buffer_properties (EMACS_INT
, EMACS_INT
);
93 static Lisp_Object Qbuffer_access_fontify_functions
;
94 static Lisp_Object
Fuser_full_name (Lisp_Object
);
96 /* Symbol for the text property used to mark fields. */
100 /* A special value for Qfield properties. */
102 static Lisp_Object Qboundary
;
108 const char *user_name
;
110 struct passwd
*pw
; /* password entry for the current user */
113 /* Set up system_name even when dumping. */
117 /* Don't bother with this on initial start when just dumping out */
120 #endif /* not CANNOT_DUMP */
122 pw
= getpwuid (getuid ());
124 /* We let the real user name default to "root" because that's quite
125 accurate on MSDOG and because it lets Emacs find the init file.
126 (The DVX libraries override the Djgpp libraries here.) */
127 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "root");
129 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "unknown");
132 /* Get the effective user name, by consulting environment variables,
133 or the effective uid if those are unset. */
134 user_name
= getenv ("LOGNAME");
137 user_name
= getenv ("USERNAME"); /* it's USERNAME on NT */
138 #else /* WINDOWSNT */
139 user_name
= getenv ("USER");
140 #endif /* WINDOWSNT */
143 pw
= getpwuid (geteuid ());
144 user_name
= pw
? pw
->pw_name
: "unknown";
146 Vuser_login_name
= build_string (user_name
);
148 /* If the user name claimed in the environment vars differs from
149 the real uid, use the claimed name to find the full name. */
150 tem
= Fstring_equal (Vuser_login_name
, Vuser_real_login_name
);
151 Vuser_full_name
= Fuser_full_name (NILP (tem
)? make_number (geteuid ())
156 Vuser_full_name
= build_string (p
);
157 else if (NILP (Vuser_full_name
))
158 Vuser_full_name
= build_string ("unknown");
160 #ifdef HAVE_SYS_UTSNAME_H
164 Voperating_system_release
= build_string (uts
.release
);
167 Voperating_system_release
= Qnil
;
171 DEFUN ("char-to-string", Fchar_to_string
, Schar_to_string
, 1, 1, 0,
172 doc
: /* Convert arg CHAR to a string containing that character.
173 usage: (char-to-string CHAR) */)
174 (Lisp_Object character
)
177 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
179 CHECK_CHARACTER (character
);
180 c
= XFASTINT (character
);
182 len
= CHAR_STRING (c
, str
);
183 return make_string_from_bytes ((char *) str
, 1, len
);
186 DEFUN ("byte-to-string", Fbyte_to_string
, Sbyte_to_string
, 1, 1, 0,
187 doc
: /* Convert arg BYTE to a unibyte string containing that byte. */)
192 if (XINT (byte
) < 0 || XINT (byte
) > 255)
193 error ("Invalid byte");
195 return make_string_from_bytes ((char *) &b
, 1, 1);
198 DEFUN ("string-to-char", Fstring_to_char
, Sstring_to_char
, 1, 1, 0,
199 doc
: /* Return the first character in STRING. */)
200 (register Lisp_Object string
)
202 register Lisp_Object val
;
203 CHECK_STRING (string
);
206 if (STRING_MULTIBYTE (string
))
207 XSETFASTINT (val
, STRING_CHAR (SDATA (string
)));
209 XSETFASTINT (val
, SREF (string
, 0));
212 XSETFASTINT (val
, 0);
217 buildmark (EMACS_INT charpos
, EMACS_INT bytepos
)
219 register Lisp_Object mark
;
220 mark
= Fmake_marker ();
221 set_marker_both (mark
, Qnil
, charpos
, bytepos
);
225 DEFUN ("point", Fpoint
, Spoint
, 0, 0, 0,
226 doc
: /* Return value of point, as an integer.
227 Beginning of buffer is position (point-min). */)
231 XSETFASTINT (temp
, PT
);
235 DEFUN ("point-marker", Fpoint_marker
, Spoint_marker
, 0, 0, 0,
236 doc
: /* Return value of point, as a marker object. */)
239 return buildmark (PT
, PT_BYTE
);
243 clip_to_bounds (EMACS_INT lower
, EMACS_INT num
, EMACS_INT upper
)
247 else if (num
> upper
)
253 DEFUN ("goto-char", Fgoto_char
, Sgoto_char
, 1, 1, "NGoto char: ",
254 doc
: /* Set point to POSITION, a number or marker.
255 Beginning of buffer is position (point-min), end is (point-max).
257 The return value is POSITION. */)
258 (register Lisp_Object position
)
262 if (MARKERP (position
)
263 && current_buffer
== XMARKER (position
)->buffer
)
265 pos
= marker_position (position
);
267 SET_PT_BOTH (BEGV
, BEGV_BYTE
);
269 SET_PT_BOTH (ZV
, ZV_BYTE
);
271 SET_PT_BOTH (pos
, marker_byte_position (position
));
276 CHECK_NUMBER_COERCE_MARKER (position
);
278 pos
= clip_to_bounds (BEGV
, XINT (position
), ZV
);
284 /* Return the start or end position of the region.
285 BEGINNINGP non-zero means return the start.
286 If there is no region active, signal an error. */
289 region_limit (int beginningp
)
293 if (!NILP (Vtransient_mark_mode
)
294 && NILP (Vmark_even_if_inactive
)
295 && NILP (BVAR (current_buffer
, mark_active
)))
296 xsignal0 (Qmark_inactive
);
298 m
= Fmarker_position (BVAR (current_buffer
, mark
));
300 error ("The mark is not set now, so there is no region");
302 if ((PT
< XFASTINT (m
)) == (beginningp
!= 0))
303 m
= make_number (PT
);
307 DEFUN ("region-beginning", Fregion_beginning
, Sregion_beginning
, 0, 0, 0,
308 doc
: /* Return the integer value of point or mark, whichever is smaller. */)
311 return region_limit (1);
314 DEFUN ("region-end", Fregion_end
, Sregion_end
, 0, 0, 0,
315 doc
: /* Return the integer value of point or mark, whichever is larger. */)
318 return region_limit (0);
321 DEFUN ("mark-marker", Fmark_marker
, Smark_marker
, 0, 0, 0,
322 doc
: /* Return this buffer's mark, as a marker object.
323 Watch out! Moving this marker changes the mark position.
324 If you set the marker not to point anywhere, the buffer will have no mark. */)
327 return BVAR (current_buffer
, mark
);
331 /* Find all the overlays in the current buffer that touch position POS.
332 Return the number found, and store them in a vector in VEC
336 overlays_around (EMACS_INT pos
, Lisp_Object
*vec
, ptrdiff_t len
)
338 Lisp_Object overlay
, start
, end
;
339 struct Lisp_Overlay
*tail
;
340 EMACS_INT startpos
, endpos
;
343 for (tail
= current_buffer
->overlays_before
; tail
; tail
= tail
->next
)
345 XSETMISC (overlay
, tail
);
347 end
= OVERLAY_END (overlay
);
348 endpos
= OVERLAY_POSITION (end
);
351 start
= OVERLAY_START (overlay
);
352 startpos
= OVERLAY_POSITION (start
);
357 /* Keep counting overlays even if we can't return them all. */
362 for (tail
= current_buffer
->overlays_after
; tail
; tail
= tail
->next
)
364 XSETMISC (overlay
, tail
);
366 start
= OVERLAY_START (overlay
);
367 startpos
= OVERLAY_POSITION (start
);
370 end
= OVERLAY_END (overlay
);
371 endpos
= OVERLAY_POSITION (end
);
383 /* Return the value of property PROP, in OBJECT at POSITION.
384 It's the value of PROP that a char inserted at POSITION would get.
385 OBJECT is optional and defaults to the current buffer.
386 If OBJECT is a buffer, then overlay properties are considered as well as
388 If OBJECT is a window, then that window's buffer is used, but
389 window-specific overlays are considered only if they are associated
392 get_pos_property (Lisp_Object position
, register Lisp_Object prop
, Lisp_Object object
)
394 CHECK_NUMBER_COERCE_MARKER (position
);
397 XSETBUFFER (object
, current_buffer
);
398 else if (WINDOWP (object
))
399 object
= XWINDOW (object
)->buffer
;
401 if (!BUFFERP (object
))
402 /* pos-property only makes sense in buffers right now, since strings
403 have no overlays and no notion of insertion for which stickiness
405 return Fget_text_property (position
, prop
, object
);
408 EMACS_INT posn
= XINT (position
);
410 Lisp_Object
*overlay_vec
, tem
;
411 struct buffer
*obuf
= current_buffer
;
413 set_buffer_temp (XBUFFER (object
));
415 /* First try with room for 40 overlays. */
417 overlay_vec
= (Lisp_Object
*) alloca (noverlays
* sizeof (Lisp_Object
));
418 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
420 /* If there are more than 40,
421 make enough space for all, and try again. */
424 overlay_vec
= (Lisp_Object
*) alloca (noverlays
* sizeof (Lisp_Object
));
425 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
427 noverlays
= sort_overlays (overlay_vec
, noverlays
, NULL
);
429 set_buffer_temp (obuf
);
431 /* Now check the overlays in order of decreasing priority. */
432 while (--noverlays
>= 0)
434 Lisp_Object ol
= overlay_vec
[noverlays
];
435 tem
= Foverlay_get (ol
, prop
);
438 /* Check the overlay is indeed active at point. */
439 Lisp_Object start
= OVERLAY_START (ol
), finish
= OVERLAY_END (ol
);
440 if ((OVERLAY_POSITION (start
) == posn
441 && XMARKER (start
)->insertion_type
== 1)
442 || (OVERLAY_POSITION (finish
) == posn
443 && XMARKER (finish
)->insertion_type
== 0))
444 ; /* The overlay will not cover a char inserted at point. */
452 { /* Now check the text properties. */
453 int stickiness
= text_property_stickiness (prop
, position
, object
);
455 return Fget_text_property (position
, prop
, object
);
456 else if (stickiness
< 0
457 && XINT (position
) > BUF_BEGV (XBUFFER (object
)))
458 return Fget_text_property (make_number (XINT (position
) - 1),
466 /* Find the field surrounding POS in *BEG and *END. If POS is nil,
467 the value of point is used instead. If BEG or END is null,
468 means don't store the beginning or end of the field.
470 BEG_LIMIT and END_LIMIT serve to limit the ranged of the returned
471 results; they do not effect boundary behavior.
473 If MERGE_AT_BOUNDARY is nonzero, then if POS is at the very first
474 position of a field, then the beginning of the previous field is
475 returned instead of the beginning of POS's field (since the end of a
476 field is actually also the beginning of the next input field, this
477 behavior is sometimes useful). Additionally in the MERGE_AT_BOUNDARY
478 true case, if two fields are separated by a field with the special
479 value `boundary', and POS lies within it, then the two separated
480 fields are considered to be adjacent, and POS between them, when
481 finding the beginning and ending of the "merged" field.
483 Either BEG or END may be 0, in which case the corresponding value
487 find_field (Lisp_Object pos
, Lisp_Object merge_at_boundary
,
488 Lisp_Object beg_limit
,
489 EMACS_INT
*beg
, Lisp_Object end_limit
, EMACS_INT
*end
)
491 /* Fields right before and after the point. */
492 Lisp_Object before_field
, after_field
;
493 /* 1 if POS counts as the start of a field. */
494 int at_field_start
= 0;
495 /* 1 if POS counts as the end of a field. */
496 int at_field_end
= 0;
499 XSETFASTINT (pos
, PT
);
501 CHECK_NUMBER_COERCE_MARKER (pos
);
504 = get_char_property_and_overlay (pos
, Qfield
, Qnil
, NULL
);
506 = (XFASTINT (pos
) > BEGV
507 ? get_char_property_and_overlay (make_number (XINT (pos
) - 1),
509 /* Using nil here would be a more obvious choice, but it would
510 fail when the buffer starts with a non-sticky field. */
513 /* See if we need to handle the case where MERGE_AT_BOUNDARY is nil
514 and POS is at beginning of a field, which can also be interpreted
515 as the end of the previous field. Note that the case where if
516 MERGE_AT_BOUNDARY is non-nil (see function comment) is actually the
517 more natural one; then we avoid treating the beginning of a field
519 if (NILP (merge_at_boundary
))
521 Lisp_Object field
= get_pos_property (pos
, Qfield
, Qnil
);
522 if (!EQ (field
, after_field
))
524 if (!EQ (field
, before_field
))
526 if (NILP (field
) && at_field_start
&& at_field_end
)
527 /* If an inserted char would have a nil field while the surrounding
528 text is non-nil, we're probably not looking at a
529 zero-length field, but instead at a non-nil field that's
530 not intended for editing (such as comint's prompts). */
531 at_field_end
= at_field_start
= 0;
534 /* Note about special `boundary' fields:
536 Consider the case where the point (`.') is between the fields `x' and `y':
540 In this situation, if merge_at_boundary is true, we consider the
541 `x' and `y' fields as forming one big merged field, and so the end
542 of the field is the end of `y'.
544 However, if `x' and `y' are separated by a special `boundary' field
545 (a field with a `field' char-property of 'boundary), then we ignore
546 this special field when merging adjacent fields. Here's the same
547 situation, but with a `boundary' field between the `x' and `y' fields:
551 Here, if point is at the end of `x', the beginning of `y', or
552 anywhere in-between (within the `boundary' field), we merge all
553 three fields and consider the beginning as being the beginning of
554 the `x' field, and the end as being the end of the `y' field. */
559 /* POS is at the edge of a field, and we should consider it as
560 the beginning of the following field. */
561 *beg
= XFASTINT (pos
);
563 /* Find the previous field boundary. */
566 if (!NILP (merge_at_boundary
) && EQ (before_field
, Qboundary
))
567 /* Skip a `boundary' field. */
568 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
571 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
573 *beg
= NILP (p
) ? BEGV
: XFASTINT (p
);
580 /* POS is at the edge of a field, and we should consider it as
581 the end of the previous field. */
582 *end
= XFASTINT (pos
);
584 /* Find the next field boundary. */
586 if (!NILP (merge_at_boundary
) && EQ (after_field
, Qboundary
))
587 /* Skip a `boundary' field. */
588 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
591 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
593 *end
= NILP (pos
) ? ZV
: XFASTINT (pos
);
599 DEFUN ("delete-field", Fdelete_field
, Sdelete_field
, 0, 1, 0,
600 doc
: /* Delete the field surrounding POS.
601 A field is a region of text with the same `field' property.
602 If POS is nil, the value of point is used for POS. */)
606 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
608 del_range (beg
, end
);
612 DEFUN ("field-string", Ffield_string
, Sfield_string
, 0, 1, 0,
613 doc
: /* Return the contents of the field surrounding POS as a string.
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
, 1);
623 DEFUN ("field-string-no-properties", Ffield_string_no_properties
, Sfield_string_no_properties
, 0, 1, 0,
624 doc
: /* Return the contents of the field around POS, without text properties.
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. */)
630 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
631 return make_buffer_string (beg
, end
, 0);
634 DEFUN ("field-beginning", Ffield_beginning
, Sfield_beginning
, 0, 3, 0,
635 doc
: /* Return the beginning of the field surrounding POS.
636 A field is a region of text with the same `field' property.
637 If POS is nil, the value of point is used for POS.
638 If ESCAPE-FROM-EDGE is non-nil and POS is at the beginning of its
639 field, then the beginning of the *previous* field is returned.
640 If LIMIT is non-nil, it is a buffer position; if the beginning of the field
641 is before LIMIT, then LIMIT will be returned instead. */)
642 (Lisp_Object pos
, Lisp_Object escape_from_edge
, Lisp_Object limit
)
645 find_field (pos
, escape_from_edge
, limit
, &beg
, Qnil
, 0);
646 return make_number (beg
);
649 DEFUN ("field-end", Ffield_end
, Sfield_end
, 0, 3, 0,
650 doc
: /* Return the end of the field surrounding POS.
651 A field is a region of text with the same `field' property.
652 If POS is nil, the value of point is used for POS.
653 If ESCAPE-FROM-EDGE is non-nil and POS is at the end of its field,
654 then the end of the *following* field is returned.
655 If LIMIT is non-nil, it is a buffer position; if the end of the field
656 is after LIMIT, then LIMIT will be returned instead. */)
657 (Lisp_Object pos
, Lisp_Object escape_from_edge
, Lisp_Object limit
)
660 find_field (pos
, escape_from_edge
, Qnil
, 0, limit
, &end
);
661 return make_number (end
);
664 DEFUN ("constrain-to-field", Fconstrain_to_field
, Sconstrain_to_field
, 2, 5, 0,
665 doc
: /* Return the position closest to NEW-POS that is in the same field as OLD-POS.
666 A field is a region of text with the same `field' property.
668 If NEW-POS is nil, then use the current point instead, and move point
669 to the resulting constrained position, in addition to returning that
672 If OLD-POS is at the boundary of two fields, then the allowable
673 positions for NEW-POS depends on the value of the optional argument
674 ESCAPE-FROM-EDGE: If ESCAPE-FROM-EDGE is nil, then NEW-POS is
675 constrained to the field that has the same `field' char-property
676 as any new characters inserted at OLD-POS, whereas if ESCAPE-FROM-EDGE
677 is non-nil, NEW-POS is constrained to the union of the two adjacent
678 fields. Additionally, if two fields are separated by another field with
679 the special value `boundary', then any point within this special field is
680 also considered to be `on the boundary'.
682 If the optional argument ONLY-IN-LINE is non-nil and constraining
683 NEW-POS would move it to a different line, NEW-POS is returned
684 unconstrained. This useful for commands that move by line, like
685 \\[next-line] or \\[beginning-of-line], which should generally respect field boundaries
686 only in the case where they can still move to the right line.
688 If the optional argument INHIBIT-CAPTURE-PROPERTY is non-nil, and OLD-POS has
689 a non-nil property of that name, then any field boundaries are ignored.
691 Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */)
692 (Lisp_Object new_pos
, Lisp_Object old_pos
, Lisp_Object escape_from_edge
, Lisp_Object only_in_line
, Lisp_Object inhibit_capture_property
)
694 /* If non-zero, then the original point, before re-positioning. */
695 EMACS_INT orig_point
= 0;
697 Lisp_Object prev_old
, prev_new
;
700 /* Use the current point, and afterwards, set it. */
703 XSETFASTINT (new_pos
, PT
);
706 CHECK_NUMBER_COERCE_MARKER (new_pos
);
707 CHECK_NUMBER_COERCE_MARKER (old_pos
);
709 fwd
= (XFASTINT (new_pos
) > XFASTINT (old_pos
));
711 prev_old
= make_number (XFASTINT (old_pos
) - 1);
712 prev_new
= make_number (XFASTINT (new_pos
) - 1);
714 if (NILP (Vinhibit_field_text_motion
)
715 && !EQ (new_pos
, old_pos
)
716 && (!NILP (Fget_char_property (new_pos
, Qfield
, Qnil
))
717 || !NILP (Fget_char_property (old_pos
, Qfield
, Qnil
))
718 /* To recognize field boundaries, we must also look at the
719 previous positions; we could use `get_pos_property'
720 instead, but in itself that would fail inside non-sticky
721 fields (like comint prompts). */
722 || (XFASTINT (new_pos
) > BEGV
723 && !NILP (Fget_char_property (prev_new
, Qfield
, Qnil
)))
724 || (XFASTINT (old_pos
) > BEGV
725 && !NILP (Fget_char_property (prev_old
, Qfield
, Qnil
))))
726 && (NILP (inhibit_capture_property
)
727 /* Field boundaries are again a problem; but now we must
728 decide the case exactly, so we need to call
729 `get_pos_property' as well. */
730 || (NILP (get_pos_property (old_pos
, inhibit_capture_property
, Qnil
))
731 && (XFASTINT (old_pos
) <= BEGV
732 || NILP (Fget_char_property (old_pos
, inhibit_capture_property
, Qnil
))
733 || NILP (Fget_char_property (prev_old
, inhibit_capture_property
, Qnil
))))))
734 /* It is possible that NEW_POS is not within the same field as
735 OLD_POS; try to move NEW_POS so that it is. */
738 Lisp_Object field_bound
;
741 field_bound
= Ffield_end (old_pos
, escape_from_edge
, new_pos
);
743 field_bound
= Ffield_beginning (old_pos
, escape_from_edge
, new_pos
);
745 if (/* See if ESCAPE_FROM_EDGE caused FIELD_BOUND to jump to the
746 other side of NEW_POS, which would mean that NEW_POS is
747 already acceptable, and it's not necessary to constrain it
749 ((XFASTINT (field_bound
) < XFASTINT (new_pos
)) ? fwd
: !fwd
)
750 /* NEW_POS should be constrained, but only if either
751 ONLY_IN_LINE is nil (in which case any constraint is OK),
752 or NEW_POS and FIELD_BOUND are on the same line (in which
753 case the constraint is OK even if ONLY_IN_LINE is non-nil). */
754 && (NILP (only_in_line
)
755 /* This is the ONLY_IN_LINE case, check that NEW_POS and
756 FIELD_BOUND are on the same line by seeing whether
757 there's an intervening newline or not. */
758 || (scan_buffer ('\n',
759 XFASTINT (new_pos
), XFASTINT (field_bound
),
760 fwd
? -1 : 1, &shortage
, 1),
762 /* Constrain NEW_POS to FIELD_BOUND. */
763 new_pos
= field_bound
;
765 if (orig_point
&& XFASTINT (new_pos
) != orig_point
)
766 /* The NEW_POS argument was originally nil, so automatically set PT. */
767 SET_PT (XFASTINT (new_pos
));
774 DEFUN ("line-beginning-position",
775 Fline_beginning_position
, Sline_beginning_position
, 0, 1, 0,
776 doc
: /* Return the character position of the first character on the current line.
777 With argument N not nil or 1, move forward N - 1 lines first.
778 If scan reaches end of buffer, return that position.
780 The returned position is of the first character in the logical order,
781 i.e. the one that has the smallest character position.
783 This function constrains the returned position to the current field
784 unless that would be on a different line than the original,
785 unconstrained result. If N is nil or 1, and a front-sticky field
786 starts at point, the scan stops as soon as it starts. To ignore field
787 boundaries bind `inhibit-field-text-motion' to t.
789 This function does not move point. */)
792 EMACS_INT orig
, orig_byte
, end
;
793 int count
= SPECPDL_INDEX ();
794 specbind (Qinhibit_point_motion_hooks
, Qt
);
803 Fforward_line (make_number (XINT (n
) - 1));
806 SET_PT_BOTH (orig
, orig_byte
);
808 unbind_to (count
, Qnil
);
810 /* Return END constrained to the current input field. */
811 return Fconstrain_to_field (make_number (end
), make_number (orig
),
812 XINT (n
) != 1 ? Qt
: Qnil
,
816 DEFUN ("line-end-position", Fline_end_position
, Sline_end_position
, 0, 1, 0,
817 doc
: /* Return the character position of the last character on the current line.
818 With argument N not nil or 1, move forward N - 1 lines first.
819 If scan reaches end of buffer, return that position.
821 The returned position is of the last character in the logical order,
822 i.e. the character whose buffer position is the largest one.
824 This function constrains the returned position to the current field
825 unless that would be on a different line than the original,
826 unconstrained result. If N is nil or 1, and a rear-sticky field ends
827 at point, the scan stops as soon as it starts. To ignore field
828 boundaries bind `inhibit-field-text-motion' to t.
830 This function does not move point. */)
841 end_pos
= find_before_next_newline (orig
, 0, XINT (n
) - (XINT (n
) <= 0));
843 /* Return END_POS constrained to the current input field. */
844 return Fconstrain_to_field (make_number (end_pos
), make_number (orig
),
850 save_excursion_save (void)
852 int visible
= (XBUFFER (XWINDOW (selected_window
)->buffer
)
855 return Fcons (Fpoint_marker (),
856 Fcons (Fcopy_marker (BVAR (current_buffer
, mark
), Qnil
),
857 Fcons (visible
? Qt
: Qnil
,
858 Fcons (BVAR (current_buffer
, mark_active
),
863 save_excursion_restore (Lisp_Object info
)
865 Lisp_Object tem
, tem1
, omark
, nmark
;
866 struct gcpro gcpro1
, gcpro2
, gcpro3
;
869 tem
= Fmarker_buffer (XCAR (info
));
870 /* If buffer being returned to is now deleted, avoid error */
871 /* Otherwise could get error here while unwinding to top level
873 /* In that case, Fmarker_buffer returns nil now. */
877 omark
= nmark
= Qnil
;
878 GCPRO3 (info
, omark
, nmark
);
885 unchain_marker (XMARKER (tem
));
890 omark
= Fmarker_position (BVAR (current_buffer
, mark
));
891 Fset_marker (BVAR (current_buffer
, mark
), tem
, Fcurrent_buffer ());
892 nmark
= Fmarker_position (tem
);
893 unchain_marker (XMARKER (tem
));
897 visible_p
= !NILP (XCAR (info
));
899 #if 0 /* We used to make the current buffer visible in the selected window
900 if that was true previously. That avoids some anomalies.
901 But it creates others, and it wasn't documented, and it is simpler
902 and cleaner never to alter the window/buffer connections. */
905 && current_buffer
!= XBUFFER (XWINDOW (selected_window
)->buffer
))
906 Fswitch_to_buffer (Fcurrent_buffer (), Qnil
);
912 tem1
= BVAR (current_buffer
, mark_active
);
913 BVAR (current_buffer
, mark_active
) = tem
;
915 /* If mark is active now, and either was not active
916 or was at a different place, run the activate hook. */
919 if (! EQ (omark
, nmark
))
921 tem
= intern ("activate-mark-hook");
922 Frun_hooks (1, &tem
);
925 /* If mark has ceased to be active, run deactivate hook. */
926 else if (! NILP (tem1
))
928 tem
= intern ("deactivate-mark-hook");
929 Frun_hooks (1, &tem
);
932 /* If buffer was visible in a window, and a different window was
933 selected, and the old selected window is still showing this
934 buffer, restore point in that window. */
937 && !EQ (tem
, selected_window
)
938 && (tem1
= XWINDOW (tem
)->buffer
,
939 (/* Window is live... */
941 /* ...and it shows the current buffer. */
942 && XBUFFER (tem1
) == current_buffer
)))
943 Fset_window_point (tem
, make_number (PT
));
949 DEFUN ("save-excursion", Fsave_excursion
, Ssave_excursion
, 0, UNEVALLED
, 0,
950 doc
: /* Save point, mark, and current buffer; execute BODY; restore those things.
951 Executes BODY just like `progn'.
952 The values of point, mark and the current buffer are restored
953 even in case of abnormal exit (throw or error).
954 The state of activation of the mark is also restored.
956 This construct does not save `deactivate-mark', and therefore
957 functions that change the buffer will still cause deactivation
958 of the mark at the end of the command. To prevent that, bind
959 `deactivate-mark' with `let'.
961 If you only want to save the current buffer but not point nor mark,
962 then just use `save-current-buffer', or even `with-current-buffer'.
964 usage: (save-excursion &rest BODY) */)
967 register Lisp_Object val
;
968 int count
= SPECPDL_INDEX ();
970 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
973 return unbind_to (count
, val
);
976 DEFUN ("save-current-buffer", Fsave_current_buffer
, Ssave_current_buffer
, 0, UNEVALLED
, 0,
977 doc
: /* Save the current buffer; execute BODY; restore the current buffer.
978 Executes BODY just like `progn'.
979 usage: (save-current-buffer &rest BODY) */)
983 int count
= SPECPDL_INDEX ();
985 record_unwind_protect (set_buffer_if_live
, Fcurrent_buffer ());
988 return unbind_to (count
, val
);
991 DEFUN ("buffer-size", Fbufsize
, Sbufsize
, 0, 1, 0,
992 doc
: /* Return the number of characters in the current buffer.
993 If BUFFER, return the number of characters in that buffer instead. */)
997 return make_number (Z
- BEG
);
1000 CHECK_BUFFER (buffer
);
1001 return make_number (BUF_Z (XBUFFER (buffer
))
1002 - BUF_BEG (XBUFFER (buffer
)));
1006 DEFUN ("point-min", Fpoint_min
, Spoint_min
, 0, 0, 0,
1007 doc
: /* Return the minimum permissible value of point in the current buffer.
1008 This is 1, unless narrowing (a buffer restriction) is in effect. */)
1012 XSETFASTINT (temp
, BEGV
);
1016 DEFUN ("point-min-marker", Fpoint_min_marker
, Spoint_min_marker
, 0, 0, 0,
1017 doc
: /* Return a marker to the minimum permissible value of point in this buffer.
1018 This is the beginning, unless narrowing (a buffer restriction) is in effect. */)
1021 return buildmark (BEGV
, BEGV_BYTE
);
1024 DEFUN ("point-max", Fpoint_max
, Spoint_max
, 0, 0, 0,
1025 doc
: /* Return the maximum permissible value of point in the current buffer.
1026 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1027 is in effect, in which case it is less. */)
1031 XSETFASTINT (temp
, ZV
);
1035 DEFUN ("point-max-marker", Fpoint_max_marker
, Spoint_max_marker
, 0, 0, 0,
1036 doc
: /* Return a marker to the maximum permissible value of point in this buffer.
1037 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1038 is in effect, in which case it is less. */)
1041 return buildmark (ZV
, ZV_BYTE
);
1044 DEFUN ("gap-position", Fgap_position
, Sgap_position
, 0, 0, 0,
1045 doc
: /* Return the position of the gap, in the current buffer.
1046 See also `gap-size'. */)
1050 XSETFASTINT (temp
, GPT
);
1054 DEFUN ("gap-size", Fgap_size
, Sgap_size
, 0, 0, 0,
1055 doc
: /* Return the size of the current buffer's gap.
1056 See also `gap-position'. */)
1060 XSETFASTINT (temp
, GAP_SIZE
);
1064 DEFUN ("position-bytes", Fposition_bytes
, Sposition_bytes
, 1, 1, 0,
1065 doc
: /* Return the byte position for character position POSITION.
1066 If POSITION is out of range, the value is nil. */)
1067 (Lisp_Object position
)
1069 CHECK_NUMBER_COERCE_MARKER (position
);
1070 if (XINT (position
) < BEG
|| XINT (position
) > Z
)
1072 return make_number (CHAR_TO_BYTE (XINT (position
)));
1075 DEFUN ("byte-to-position", Fbyte_to_position
, Sbyte_to_position
, 1, 1, 0,
1076 doc
: /* Return the character position for byte position BYTEPOS.
1077 If BYTEPOS is out of range, the value is nil. */)
1078 (Lisp_Object bytepos
)
1080 CHECK_NUMBER (bytepos
);
1081 if (XINT (bytepos
) < BEG_BYTE
|| XINT (bytepos
) > Z_BYTE
)
1083 return make_number (BYTE_TO_CHAR (XINT (bytepos
)));
1086 DEFUN ("following-char", Ffollowing_char
, Sfollowing_char
, 0, 0, 0,
1087 doc
: /* Return the character following point, as a number.
1088 At the end of the buffer or accessible region, return 0. */)
1093 XSETFASTINT (temp
, 0);
1095 XSETFASTINT (temp
, FETCH_CHAR (PT_BYTE
));
1099 DEFUN ("preceding-char", Fprevious_char
, Sprevious_char
, 0, 0, 0,
1100 doc
: /* Return the character preceding point, as a number.
1101 At the beginning of the buffer or accessible region, return 0. */)
1106 XSETFASTINT (temp
, 0);
1107 else if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
1109 EMACS_INT pos
= PT_BYTE
;
1111 XSETFASTINT (temp
, FETCH_CHAR (pos
));
1114 XSETFASTINT (temp
, FETCH_BYTE (PT_BYTE
- 1));
1118 DEFUN ("bobp", Fbobp
, Sbobp
, 0, 0, 0,
1119 doc
: /* Return t if point is at the beginning of the buffer.
1120 If the buffer is narrowed, this means the beginning of the narrowed part. */)
1128 DEFUN ("eobp", Feobp
, Seobp
, 0, 0, 0,
1129 doc
: /* Return t if point is at the end of the buffer.
1130 If the buffer is narrowed, this means the end of the narrowed part. */)
1138 DEFUN ("bolp", Fbolp
, Sbolp
, 0, 0, 0,
1139 doc
: /* Return t if point is at the beginning of a line. */)
1142 if (PT
== BEGV
|| FETCH_BYTE (PT_BYTE
- 1) == '\n')
1147 DEFUN ("eolp", Feolp
, Seolp
, 0, 0, 0,
1148 doc
: /* Return t if point is at the end of a line.
1149 `End of a line' includes point being at the end of the buffer. */)
1152 if (PT
== ZV
|| FETCH_BYTE (PT_BYTE
) == '\n')
1157 DEFUN ("char-after", Fchar_after
, Schar_after
, 0, 1, 0,
1158 doc
: /* Return character in current buffer at position POS.
1159 POS is an integer or a marker and defaults to point.
1160 If POS is out of range, the value is nil. */)
1163 register EMACS_INT pos_byte
;
1168 XSETFASTINT (pos
, PT
);
1173 pos_byte
= marker_byte_position (pos
);
1174 if (pos_byte
< BEGV_BYTE
|| pos_byte
>= ZV_BYTE
)
1179 CHECK_NUMBER_COERCE_MARKER (pos
);
1180 if (XINT (pos
) < BEGV
|| XINT (pos
) >= ZV
)
1183 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1186 return make_number (FETCH_CHAR (pos_byte
));
1189 DEFUN ("char-before", Fchar_before
, Schar_before
, 0, 1, 0,
1190 doc
: /* Return character in current buffer preceding position POS.
1191 POS is an integer or a marker and defaults to point.
1192 If POS is out of range, the value is nil. */)
1195 register Lisp_Object val
;
1196 register EMACS_INT pos_byte
;
1201 XSETFASTINT (pos
, PT
);
1206 pos_byte
= marker_byte_position (pos
);
1208 if (pos_byte
<= BEGV_BYTE
|| pos_byte
> ZV_BYTE
)
1213 CHECK_NUMBER_COERCE_MARKER (pos
);
1215 if (XINT (pos
) <= BEGV
|| XINT (pos
) > ZV
)
1218 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1221 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
1224 XSETFASTINT (val
, FETCH_CHAR (pos_byte
));
1229 XSETFASTINT (val
, FETCH_BYTE (pos_byte
));
1234 DEFUN ("user-login-name", Fuser_login_name
, Suser_login_name
, 0, 1, 0,
1235 doc
: /* Return the name under which the user logged in, as a string.
1236 This is based on the effective uid, not the real uid.
1237 Also, if the environment variables LOGNAME or USER are set,
1238 that determines the value of this function.
1240 If optional argument UID is an integer or a float, return the login name
1241 of the user with that uid, or nil if there is no such user. */)
1247 /* Set up the user name info if we didn't do it before.
1248 (That can happen if Emacs is dumpable
1249 but you decide to run `temacs -l loadup' and not dump. */
1250 if (INTEGERP (Vuser_login_name
))
1254 return Vuser_login_name
;
1256 id
= XFLOATINT (uid
);
1260 return (pw
? build_string (pw
->pw_name
) : Qnil
);
1263 DEFUN ("user-real-login-name", Fuser_real_login_name
, Suser_real_login_name
,
1265 doc
: /* Return the name of the user's real uid, as a string.
1266 This ignores the environment variables LOGNAME and USER, so it differs from
1267 `user-login-name' when running under `su'. */)
1270 /* Set up the user name info if we didn't do it before.
1271 (That can happen if Emacs is dumpable
1272 but you decide to run `temacs -l loadup' and not dump. */
1273 if (INTEGERP (Vuser_login_name
))
1275 return Vuser_real_login_name
;
1278 DEFUN ("user-uid", Fuser_uid
, Suser_uid
, 0, 0, 0,
1279 doc
: /* Return the effective uid of Emacs.
1280 Value is an integer or a float, depending on the value. */)
1283 /* Assignment to EMACS_INT stops GCC whining about limited range of
1285 EMACS_INT euid
= geteuid ();
1287 /* Make sure we don't produce a negative UID due to signed integer
1290 return make_float (geteuid ());
1291 return make_fixnum_or_float (euid
);
1294 DEFUN ("user-real-uid", Fuser_real_uid
, Suser_real_uid
, 0, 0, 0,
1295 doc
: /* Return the real uid of Emacs.
1296 Value is an integer or a float, depending on the value. */)
1299 /* Assignment to EMACS_INT stops GCC whining about limited range of
1301 EMACS_INT uid
= getuid ();
1303 /* Make sure we don't produce a negative UID due to signed integer
1306 return make_float (getuid ());
1307 return make_fixnum_or_float (uid
);
1310 DEFUN ("user-full-name", Fuser_full_name
, Suser_full_name
, 0, 1, 0,
1311 doc
: /* Return the full name of the user logged in, as a string.
1312 If the full name corresponding to Emacs's userid is not known,
1315 If optional argument UID is an integer or float, return the full name
1316 of the user with that uid, or nil if there is no such user.
1317 If UID is a string, return the full name of the user with that login
1318 name, or nil if there is no such user. */)
1322 register char *p
, *q
;
1326 return Vuser_full_name
;
1327 else if (NUMBERP (uid
))
1329 uid_t u
= XFLOATINT (uid
);
1334 else if (STRINGP (uid
))
1337 pw
= getpwnam (SSDATA (uid
));
1341 error ("Invalid UID specification");
1347 /* Chop off everything after the first comma. */
1348 q
= strchr (p
, ',');
1349 full
= make_string (p
, q
? q
- p
: strlen (p
));
1351 #ifdef AMPERSAND_FULL_NAME
1353 q
= strchr (p
, '&');
1354 /* Substitute the login name for the &, upcasing the first character. */
1360 login
= Fuser_login_name (make_number (pw
->pw_uid
));
1361 r
= (char *) alloca (strlen (p
) + SCHARS (login
) + 1);
1362 memcpy (r
, p
, q
- p
);
1364 strcat (r
, SSDATA (login
));
1365 r
[q
- p
] = upcase ((unsigned char) r
[q
- p
]);
1367 full
= build_string (r
);
1369 #endif /* AMPERSAND_FULL_NAME */
1374 DEFUN ("system-name", Fsystem_name
, Ssystem_name
, 0, 0, 0,
1375 doc
: /* Return the host name of the machine you are running on, as a string. */)
1378 return Vsystem_name
;
1382 get_system_name (void)
1384 if (STRINGP (Vsystem_name
))
1385 return SSDATA (Vsystem_name
);
1390 DEFUN ("emacs-pid", Femacs_pid
, Semacs_pid
, 0, 0, 0,
1391 doc
: /* Return the process ID of Emacs, as an integer. */)
1394 return make_number (getpid ());
1400 # define TIME_T_MIN TYPE_MINIMUM (time_t)
1403 # define TIME_T_MAX TYPE_MAXIMUM (time_t)
1406 /* Report that a time value is out of range for Emacs. */
1408 time_overflow (void)
1410 error ("Specified time is not representable");
1413 /* Return the upper part of the time T (everything but the bottom 16 bits),
1414 making sure that it is representable. */
1418 time_t hi
= t
>> 16;
1420 /* Check for overflow, helping the compiler for common cases where
1421 no runtime check is needed, and taking care not to convert
1422 negative numbers to unsigned before comparing them. */
1423 if (! ((! TYPE_SIGNED (time_t)
1424 || MOST_NEGATIVE_FIXNUM
<= TIME_T_MIN
>> 16
1425 || MOST_NEGATIVE_FIXNUM
<= hi
)
1426 && (TIME_T_MAX
>> 16 <= MOST_POSITIVE_FIXNUM
1427 || hi
<= MOST_POSITIVE_FIXNUM
)))
1433 /* Return the bottom 16 bits of the time T. */
1437 return t
& ((1 << 16) - 1);
1440 DEFUN ("current-time", Fcurrent_time
, Scurrent_time
, 0, 0, 0,
1441 doc
: /* Return the current time, as the number of seconds since 1970-01-01 00:00:00.
1442 The time is returned as a list of three integers. The first has the
1443 most significant 16 bits of the seconds, while the second has the
1444 least significant 16 bits. The third integer gives the microsecond
1447 The microsecond count is zero on systems that do not provide
1448 resolution finer than a second. */)
1454 return list3 (make_number (hi_time (EMACS_SECS (t
))),
1455 make_number (lo_time (EMACS_SECS (t
))),
1456 make_number (EMACS_USECS (t
)));
1459 DEFUN ("get-internal-run-time", Fget_internal_run_time
, Sget_internal_run_time
,
1461 doc
: /* Return the current run time used by Emacs.
1462 The time is returned as a list of three integers. The first has the
1463 most significant 16 bits of the seconds, while the second has the
1464 least significant 16 bits. The third integer gives the microsecond
1467 On systems that can't determine the run time, `get-internal-run-time'
1468 does the same thing as `current-time'. The microsecond count is zero
1469 on systems that do not provide resolution finer than a second. */)
1472 #ifdef HAVE_GETRUSAGE
1473 struct rusage usage
;
1477 if (getrusage (RUSAGE_SELF
, &usage
) < 0)
1478 /* This shouldn't happen. What action is appropriate? */
1481 /* Sum up user time and system time. */
1482 secs
= usage
.ru_utime
.tv_sec
+ usage
.ru_stime
.tv_sec
;
1483 usecs
= usage
.ru_utime
.tv_usec
+ usage
.ru_stime
.tv_usec
;
1484 if (usecs
>= 1000000)
1490 return list3 (make_number (hi_time (secs
)),
1491 make_number (lo_time (secs
)),
1492 make_number (usecs
));
1493 #else /* ! HAVE_GETRUSAGE */
1495 return w32_get_internal_run_time ();
1496 #else /* ! WINDOWSNT */
1497 return Fcurrent_time ();
1498 #endif /* WINDOWSNT */
1499 #endif /* HAVE_GETRUSAGE */
1503 /* Make a Lisp list that represents the time T. */
1505 make_time (time_t t
)
1507 return list2 (make_number (hi_time (t
)),
1508 make_number (lo_time (t
)));
1511 /* Decode a Lisp list SPECIFIED_TIME that represents a time.
1512 If SPECIFIED_TIME is nil, use the current time.
1513 Set *RESULT to seconds since the Epoch.
1514 If USEC is not null, set *USEC to the microseconds component.
1515 Return nonzero if successful. */
1517 lisp_time_argument (Lisp_Object specified_time
, time_t *result
, int *usec
)
1519 if (NILP (specified_time
))
1526 *usec
= EMACS_USECS (t
);
1527 *result
= EMACS_SECS (t
);
1531 return time (result
) != -1;
1535 Lisp_Object high
, low
;
1537 high
= Fcar (specified_time
);
1538 CHECK_NUMBER (high
);
1539 low
= Fcdr (specified_time
);
1544 Lisp_Object usec_l
= Fcdr (low
);
1546 usec_l
= Fcar (usec_l
);
1551 CHECK_NUMBER (usec_l
);
1552 *usec
= XINT (usec_l
);
1562 /* Check for overflow, helping the compiler for common cases
1563 where no runtime check is needed, and taking care not to
1564 convert negative numbers to unsigned before comparing them. */
1565 if (! ((TYPE_SIGNED (time_t)
1566 ? (TIME_T_MIN
>> 16 <= MOST_NEGATIVE_FIXNUM
1567 || TIME_T_MIN
>> 16 <= hi
)
1569 && (MOST_POSITIVE_FIXNUM
<= TIME_T_MAX
>> 16
1570 || hi
<= TIME_T_MAX
>> 16)))
1573 *result
= (hi
<< 16) + (XINT (low
) & 0xffff);
1578 DEFUN ("float-time", Ffloat_time
, Sfloat_time
, 0, 1, 0,
1579 doc
: /* Return the current time, as a float number of seconds since the epoch.
1580 If SPECIFIED-TIME is given, it is the time to convert to float
1581 instead of the current time. The argument should have the form
1582 (HIGH LOW) or (HIGH LOW USEC). Thus, you can use times obtained from
1583 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
1584 have the form (HIGH . LOW), but this is considered obsolete.
1586 WARNING: Since the result is floating point, it may not be exact.
1587 If precise time stamps are required, use either `current-time',
1588 or (if you need time as a string) `format-time-string'. */)
1589 (Lisp_Object specified_time
)
1594 if (! lisp_time_argument (specified_time
, &sec
, &usec
))
1595 error ("Invalid time specification");
1597 return make_float ((sec
* 1e6
+ usec
) / 1e6
);
1600 /* Write information into buffer S of size MAXSIZE, according to the
1601 FORMAT of length FORMAT_LEN, using time information taken from *TP.
1602 Default to Universal Time if UT is nonzero, local time otherwise.
1603 Use NS as the number of nanoseconds in the %N directive.
1604 Return the number of bytes written, not including the terminating
1605 '\0'. If S is NULL, nothing will be written anywhere; so to
1606 determine how many bytes would be written, use NULL for S and
1607 ((size_t) -1) for MAXSIZE.
1609 This function behaves like nstrftime, except it allows null
1610 bytes in FORMAT and it does not support nanoseconds. */
1612 emacs_nmemftime (char *s
, size_t maxsize
, const char *format
,
1613 size_t format_len
, const struct tm
*tp
, int ut
, int ns
)
1617 /* Loop through all the null-terminated strings in the format
1618 argument. Normally there's just one null-terminated string, but
1619 there can be arbitrarily many, concatenated together, if the
1620 format contains '\0' bytes. nstrftime stops at the first
1621 '\0' byte so we must invoke it separately for each such string. */
1630 result
= nstrftime (s
, maxsize
, format
, tp
, ut
, ns
);
1634 if (result
== 0 && s
[0] != '\0')
1639 maxsize
-= result
+ 1;
1641 len
= strlen (format
);
1642 if (len
== format_len
)
1646 format_len
-= len
+ 1;
1650 DEFUN ("format-time-string", Fformat_time_string
, Sformat_time_string
, 1, 3, 0,
1651 doc
: /* Use FORMAT-STRING to format the time TIME, or now if omitted.
1652 TIME is specified as (HIGH LOW . IGNORED), as returned by
1653 `current-time' or `file-attributes'. The obsolete form (HIGH . LOW)
1654 is also still accepted.
1655 The third, optional, argument UNIVERSAL, if non-nil, means describe TIME
1656 as Universal Time; nil means describe TIME in the local time zone.
1657 The value is a copy of FORMAT-STRING, but with certain constructs replaced
1658 by text that describes the specified date and time in TIME:
1660 %Y is the year, %y within the century, %C the century.
1661 %G is the year corresponding to the ISO week, %g within the century.
1662 %m is the numeric month.
1663 %b and %h are the locale's abbreviated month name, %B the full name.
1664 %d is the day of the month, zero-padded, %e is blank-padded.
1665 %u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.
1666 %a is the locale's abbreviated name of the day of week, %A the full name.
1667 %U is the week number starting on Sunday, %W starting on Monday,
1668 %V according to ISO 8601.
1669 %j is the day of the year.
1671 %H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H
1672 only blank-padded, %l is like %I blank-padded.
1673 %p is the locale's equivalent of either AM or PM.
1676 %N is the nanosecond, %6N the microsecond, %3N the millisecond, etc.
1677 %Z is the time zone name, %z is the numeric form.
1678 %s is the number of seconds since 1970-01-01 00:00:00 +0000.
1680 %c is the locale's date and time format.
1681 %x is the locale's "preferred" date format.
1682 %D is like "%m/%d/%y".
1684 %R is like "%H:%M", %T is like "%H:%M:%S", %r is like "%I:%M:%S %p".
1685 %X is the locale's "preferred" time format.
1687 Finally, %n is a newline, %t is a tab, %% is a literal %.
1689 Certain flags and modifiers are available with some format controls.
1690 The flags are `_', `-', `^' and `#'. For certain characters X,
1691 %_X is like %X, but padded with blanks; %-X is like %X,
1692 but without padding. %^X is like %X, but with all textual
1693 characters up-cased; %#X is like %X, but with letter-case of
1694 all textual characters reversed.
1695 %NX (where N stands for an integer) is like %X,
1696 but takes up at least N (a number) positions.
1697 The modifiers are `E' and `O'. For certain characters X,
1698 %EX is a locale's alternative version of %X;
1699 %OX is like %X, but uses the locale's number symbols.
1701 For example, to produce full ISO 8601 format, use "%Y-%m-%dT%T%z".
1703 usage: (format-time-string FORMAT-STRING &optional TIME UNIVERSAL) */)
1704 (Lisp_Object format_string
, Lisp_Object timeval
, Lisp_Object universal
)
1709 CHECK_STRING (format_string
);
1710 format_string
= code_convert_string_norecord (format_string
,
1711 Vlocale_coding_system
, 1);
1712 return format_time_string (SSDATA (format_string
), SBYTES (format_string
),
1713 timeval
, ! NILP (universal
), &t
, &tm
);
1717 format_time_string (char const *format
, ptrdiff_t formatlen
,
1718 Lisp_Object timeval
, int ut
, time_t *tval
, struct tm
*tmp
)
1722 size_t size
= sizeof buffer
;
1724 Lisp_Object bufstring
;
1730 if (! (lisp_time_argument (timeval
, tval
, &usec
)
1731 && 0 <= usec
&& usec
< 1000000))
1732 error ("Invalid time specification");
1739 synchronize_system_time_locale ();
1741 tm
= ut
? gmtime (tval
) : localtime (tval
);
1750 len
= emacs_nmemftime (buf
, size
, format
, formatlen
, tm
, ut
, ns
);
1751 if ((0 < len
&& len
< size
) || (len
== 0 && buf
[0] == '\0'))
1754 /* Buffer was too small, so make it bigger and try again. */
1755 len
= emacs_nmemftime (NULL
, SIZE_MAX
, format
, formatlen
, tm
, ut
, ns
);
1757 if (STRING_BYTES_BOUND
<= len
)
1760 SAFE_ALLOCA (buf
, char *, size
);
1764 bufstring
= make_unibyte_string (buf
, len
);
1766 return code_convert_string_norecord (bufstring
, Vlocale_coding_system
, 0);
1769 DEFUN ("decode-time", Fdecode_time
, Sdecode_time
, 0, 1, 0,
1770 doc
: /* Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST ZONE).
1771 The optional SPECIFIED-TIME should be a list of (HIGH LOW . IGNORED),
1772 as from `current-time' and `file-attributes', or nil to use the
1773 current time. The obsolete form (HIGH . LOW) is also still accepted.
1774 The list has the following nine members: SEC is an integer between 0
1775 and 60; SEC is 60 for a leap second, which only some operating systems
1776 support. MINUTE is an integer between 0 and 59. HOUR is an integer
1777 between 0 and 23. DAY is an integer between 1 and 31. MONTH is an
1778 integer between 1 and 12. YEAR is an integer indicating the
1779 four-digit year. DOW is the day of week, an integer between 0 and 6,
1780 where 0 is Sunday. DST is t if daylight saving time is in effect,
1781 otherwise nil. ZONE is an integer indicating the number of seconds
1782 east of Greenwich. (Note that Common Lisp has different meanings for
1784 (Lisp_Object specified_time
)
1788 struct tm
*decoded_time
;
1789 Lisp_Object list_args
[9];
1791 if (! lisp_time_argument (specified_time
, &time_spec
, NULL
))
1792 error ("Invalid time specification");
1795 decoded_time
= localtime (&time_spec
);
1796 /* Make a copy, in case a signal handler modifies TZ or the struct. */
1798 save_tm
= *decoded_time
;
1801 && MOST_NEGATIVE_FIXNUM
- TM_YEAR_BASE
<= save_tm
.tm_year
1802 && save_tm
.tm_year
<= MOST_POSITIVE_FIXNUM
- TM_YEAR_BASE
))
1804 XSETFASTINT (list_args
[0], save_tm
.tm_sec
);
1805 XSETFASTINT (list_args
[1], save_tm
.tm_min
);
1806 XSETFASTINT (list_args
[2], save_tm
.tm_hour
);
1807 XSETFASTINT (list_args
[3], save_tm
.tm_mday
);
1808 XSETFASTINT (list_args
[4], save_tm
.tm_mon
+ 1);
1809 /* On 64-bit machines an int is narrower than EMACS_INT, thus the
1810 cast below avoids overflow in int arithmetics. */
1811 XSETINT (list_args
[5], TM_YEAR_BASE
+ (EMACS_INT
) save_tm
.tm_year
);
1812 XSETFASTINT (list_args
[6], save_tm
.tm_wday
);
1813 list_args
[7] = save_tm
.tm_isdst
? Qt
: Qnil
;
1816 decoded_time
= gmtime (&time_spec
);
1817 if (decoded_time
== 0)
1818 list_args
[8] = Qnil
;
1820 XSETINT (list_args
[8], tm_diff (&save_tm
, decoded_time
));
1822 return Flist (9, list_args
);
1825 /* Return OBJ - OFFSET, checking that OBJ is a valid fixnum and that
1826 the result is representable as an int. Assume OFFSET is small and
1829 check_tm_member (Lisp_Object obj
, int offset
)
1834 if (! (INT_MIN
+ offset
<= n
&& n
- offset
<= INT_MAX
))
1839 DEFUN ("encode-time", Fencode_time
, Sencode_time
, 6, MANY
, 0,
1840 doc
: /* Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.
1841 This is the reverse operation of `decode-time', which see.
1842 ZONE defaults to the current time zone rule. This can
1843 be a string or t (as from `set-time-zone-rule'), or it can be a list
1844 \(as from `current-time-zone') or an integer (as from `decode-time')
1845 applied without consideration for daylight saving time.
1847 You can pass more than 7 arguments; then the first six arguments
1848 are used as SECOND through YEAR, and the *last* argument is used as ZONE.
1849 The intervening arguments are ignored.
1850 This feature lets (apply 'encode-time (decode-time ...)) work.
1852 Out-of-range values for SECOND, MINUTE, HOUR, DAY, or MONTH are allowed;
1853 for example, a DAY of 0 means the day preceding the given month.
1854 Year numbers less than 100 are treated just like other year numbers.
1855 If you want them to stand for years in this century, you must do that yourself.
1857 Years before 1970 are not guaranteed to work. On some systems,
1858 year values as low as 1901 do work.
1860 usage: (encode-time SECOND MINUTE HOUR DAY MONTH YEAR &optional ZONE) */)
1861 (ptrdiff_t nargs
, Lisp_Object
*args
)
1865 Lisp_Object zone
= (nargs
> 6 ? args
[nargs
- 1] : Qnil
);
1867 tm
.tm_sec
= check_tm_member (args
[0], 0);
1868 tm
.tm_min
= check_tm_member (args
[1], 0);
1869 tm
.tm_hour
= check_tm_member (args
[2], 0);
1870 tm
.tm_mday
= check_tm_member (args
[3], 0);
1871 tm
.tm_mon
= check_tm_member (args
[4], 1);
1872 tm
.tm_year
= check_tm_member (args
[5], TM_YEAR_BASE
);
1880 value
= mktime (&tm
);
1886 const char *tzstring
;
1887 char **oldenv
= environ
, **newenv
;
1891 else if (STRINGP (zone
))
1892 tzstring
= SSDATA (zone
);
1893 else if (INTEGERP (zone
))
1895 int abszone
= eabs (XINT (zone
));
1896 sprintf (tzbuf
, "XXX%s%d:%02d:%02d", "-" + (XINT (zone
) < 0),
1897 abszone
/ (60*60), (abszone
/60) % 60, abszone
% 60);
1901 error ("Invalid time zone specification");
1905 /* Set TZ before calling mktime; merely adjusting mktime's returned
1906 value doesn't suffice, since that would mishandle leap seconds. */
1907 set_time_zone_rule (tzstring
);
1909 value
= mktime (&tm
);
1911 /* Restore TZ to previous value. */
1914 #ifdef LOCALTIME_CACHE
1922 if (value
== (time_t) -1)
1925 return make_time (value
);
1928 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
, 0, 1, 0,
1929 doc
: /* Return the current local time, as a human-readable string.
1930 Programs can use this function to decode a time,
1931 since the number of columns in each field is fixed
1932 if the year is in the range 1000-9999.
1933 The format is `Sun Sep 16 01:03:52 1973'.
1934 However, see also the functions `decode-time' and `format-time-string'
1935 which provide a much more powerful and general facility.
1937 If SPECIFIED-TIME is given, it is a time to format instead of the
1938 current time. The argument should have the form (HIGH LOW . IGNORED).
1939 Thus, you can use times obtained from `current-time' and from
1940 `file-attributes'. SPECIFIED-TIME can also have the form (HIGH . LOW),
1941 but this is considered obsolete. */)
1942 (Lisp_Object specified_time
)
1947 char buf
[sizeof "Mon Apr 30 12:49:17 2012" - 1];
1949 if (! lisp_time_argument (specified_time
, &value
, NULL
))
1950 error ("Invalid time specification");
1952 /* Convert to a string, checking for out-of-range time stamps.
1953 Omit the trailing newline.
1954 Don't use 'ctime', as that might dump core if VALUE is out of
1957 tm
= localtime (&value
);
1958 if (tm
&& TM_YEAR_IN_ASCTIME_RANGE (tm
->tm_year
))
1962 memcpy (buf
, tem
, sizeof buf
);
1968 return make_unibyte_string (buf
, sizeof buf
);
1971 /* Yield A - B, measured in seconds.
1972 This function is copied from the GNU C Library. */
1974 tm_diff (struct tm
*a
, struct tm
*b
)
1976 /* Compute intervening leap days correctly even if year is negative.
1977 Take care to avoid int overflow in leap day calculations,
1978 but it's OK to assume that A and B are close to each other. */
1979 int a4
= (a
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (a
->tm_year
& 3);
1980 int b4
= (b
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (b
->tm_year
& 3);
1981 int a100
= a4
/ 25 - (a4
% 25 < 0);
1982 int b100
= b4
/ 25 - (b4
% 25 < 0);
1983 int a400
= a100
>> 2;
1984 int b400
= b100
>> 2;
1985 int intervening_leap_days
= (a4
- b4
) - (a100
- b100
) + (a400
- b400
);
1986 int years
= a
->tm_year
- b
->tm_year
;
1987 int days
= (365 * years
+ intervening_leap_days
1988 + (a
->tm_yday
- b
->tm_yday
));
1989 return (60 * (60 * (24 * days
+ (a
->tm_hour
- b
->tm_hour
))
1990 + (a
->tm_min
- b
->tm_min
))
1991 + (a
->tm_sec
- b
->tm_sec
));
1994 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 1, 0,
1995 doc
: /* Return the offset and name for the local time zone.
1996 This returns a list of the form (OFFSET NAME).
1997 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).
1998 A negative value means west of Greenwich.
1999 NAME is a string giving the name of the time zone.
2000 If SPECIFIED-TIME is given, the time zone offset is determined from it
2001 instead of using the current time. The argument should have the form
2002 (HIGH LOW . IGNORED). Thus, you can use times obtained from
2003 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
2004 have the form (HIGH . LOW), but this is considered obsolete.
2006 Some operating systems cannot provide all this information to Emacs;
2007 in this case, `current-time-zone' returns a list containing nil for
2008 the data it can't find. */)
2009 (Lisp_Object specified_time
)
2015 Lisp_Object zone_offset
, zone_name
;
2018 zone_name
= format_time_string ("%Z", sizeof "%Z" - 1, specified_time
,
2019 0, &value
, &localtm
);
2021 t
= gmtime (&value
);
2023 offset
= tm_diff (&localtm
, t
);
2028 zone_offset
= make_number (offset
);
2029 if (SCHARS (zone_name
) == 0)
2031 /* No local time zone name is available; use "+-NNNN" instead. */
2032 int m
= offset
/ 60;
2033 int am
= offset
< 0 ? - m
: m
;
2034 char buf
[sizeof "+00" + INT_STRLEN_BOUND (int)];
2035 sprintf (buf
, "%c%02d%02d", (offset
< 0 ? '-' : '+'), am
/60, am
%60);
2036 zone_name
= build_string (buf
);
2040 return list2 (zone_offset
, zone_name
);
2043 /* This holds the value of `environ' produced by the previous
2044 call to Fset_time_zone_rule, or 0 if Fset_time_zone_rule
2045 has never been called. */
2046 static char **environbuf
;
2048 /* This holds the startup value of the TZ environment variable so it
2049 can be restored if the user calls set-time-zone-rule with a nil
2051 static char *initial_tz
;
2053 DEFUN ("set-time-zone-rule", Fset_time_zone_rule
, Sset_time_zone_rule
, 1, 1, 0,
2054 doc
: /* Set the local time zone using TZ, a string specifying a time zone rule.
2055 If TZ is nil, use implementation-defined default time zone information.
2056 If TZ is t, use Universal Time.
2058 Instead of calling this function, you typically want (setenv "TZ" TZ).
2059 That changes both the environment of the Emacs process and the
2060 variable `process-environment', whereas `set-time-zone-rule' affects
2061 only the former. */)
2064 const char *tzstring
;
2065 char **old_environbuf
;
2067 if (! (NILP (tz
) || EQ (tz
, Qt
)))
2072 /* When called for the first time, save the original TZ. */
2073 old_environbuf
= environbuf
;
2074 if (!old_environbuf
)
2075 initial_tz
= (char *) getenv ("TZ");
2078 tzstring
= initial_tz
;
2079 else if (EQ (tz
, Qt
))
2082 tzstring
= SSDATA (tz
);
2084 set_time_zone_rule (tzstring
);
2085 environbuf
= environ
;
2089 xfree (old_environbuf
);
2093 #ifdef LOCALTIME_CACHE
2095 /* These two values are known to load tz files in buggy implementations,
2096 i.e. Solaris 1 executables running under either Solaris 1 or Solaris 2.
2097 Their values shouldn't matter in non-buggy implementations.
2098 We don't use string literals for these strings,
2099 since if a string in the environment is in readonly
2100 storage, it runs afoul of bugs in SVR4 and Solaris 2.3.
2101 See Sun bugs 1113095 and 1114114, ``Timezone routines
2102 improperly modify environment''. */
2104 static char set_time_zone_rule_tz1
[] = "TZ=GMT+0";
2105 static char set_time_zone_rule_tz2
[] = "TZ=GMT+1";
2109 /* Set the local time zone rule to TZSTRING.
2110 This allocates memory into `environ', which it is the caller's
2111 responsibility to free. */
2114 set_time_zone_rule (const char *tzstring
)
2117 char **from
, **to
, **newenv
;
2119 /* Make the ENVIRON vector longer with room for TZSTRING. */
2120 for (from
= environ
; *from
; from
++)
2122 envptrs
= from
- environ
+ 2;
2123 newenv
= to
= (char **) xmalloc (envptrs
* sizeof (char *)
2124 + (tzstring
? strlen (tzstring
) + 4 : 0));
2126 /* Add TZSTRING to the end of environ, as a value for TZ. */
2129 char *t
= (char *) (to
+ envptrs
);
2131 strcat (t
, tzstring
);
2135 /* Copy the old environ vector elements into NEWENV,
2136 but don't copy the TZ variable.
2137 So we have only one definition of TZ, which came from TZSTRING. */
2138 for (from
= environ
; *from
; from
++)
2139 if (strncmp (*from
, "TZ=", 3) != 0)
2145 /* If we do have a TZSTRING, NEWENV points to the vector slot where
2146 the TZ variable is stored. If we do not have a TZSTRING,
2147 TO points to the vector slot which has the terminating null. */
2149 #ifdef LOCALTIME_CACHE
2151 /* In SunOS 4.1.3_U1 and 4.1.4, if TZ has a value like
2152 "US/Pacific" that loads a tz file, then changes to a value like
2153 "XXX0" that does not load a tz file, and then changes back to
2154 its original value, the last change is (incorrectly) ignored.
2155 Also, if TZ changes twice in succession to values that do
2156 not load a tz file, tzset can dump core (see Sun bug#1225179).
2157 The following code works around these bugs. */
2161 /* Temporarily set TZ to a value that loads a tz file
2162 and that differs from tzstring. */
2164 *newenv
= (strcmp (tzstring
, set_time_zone_rule_tz1
+ 3) == 0
2165 ? set_time_zone_rule_tz2
: set_time_zone_rule_tz1
);
2171 /* The implied tzstring is unknown, so temporarily set TZ to
2172 two different values that each load a tz file. */
2173 *to
= set_time_zone_rule_tz1
;
2176 *to
= set_time_zone_rule_tz2
;
2181 /* Now TZ has the desired value, and tzset can be invoked safely. */
2188 /* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC
2189 (if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a
2190 type of object is Lisp_String). INHERIT is passed to
2191 INSERT_FROM_STRING_FUNC as the last argument. */
2194 general_insert_function (void (*insert_func
)
2195 (const char *, EMACS_INT
),
2196 void (*insert_from_string_func
)
2197 (Lisp_Object
, EMACS_INT
, EMACS_INT
,
2198 EMACS_INT
, EMACS_INT
, int),
2199 int inherit
, ptrdiff_t nargs
, Lisp_Object
*args
)
2202 register Lisp_Object val
;
2204 for (argnum
= 0; argnum
< nargs
; argnum
++)
2207 if (CHARACTERP (val
))
2209 int c
= XFASTINT (val
);
2210 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2213 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2214 len
= CHAR_STRING (c
, str
);
2217 str
[0] = ASCII_CHAR_P (c
) ? c
: multibyte_char_to_unibyte (c
);
2220 (*insert_func
) ((char *) str
, len
);
2222 else if (STRINGP (val
))
2224 (*insert_from_string_func
) (val
, 0, 0,
2230 wrong_type_argument (Qchar_or_string_p
, val
);
2235 insert1 (Lisp_Object arg
)
2241 /* Callers passing one argument to Finsert need not gcpro the
2242 argument "array", since the only element of the array will
2243 not be used after calling insert or insert_from_string, so
2244 we don't care if it gets trashed. */
2246 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
2247 doc
: /* Insert the arguments, either strings or characters, at point.
2248 Point and before-insertion markers move forward to end up
2249 after the inserted text.
2250 Any other markers at the point of insertion remain before the text.
2252 If the current buffer is multibyte, unibyte strings are converted
2253 to multibyte for insertion (see `string-make-multibyte').
2254 If the current buffer is unibyte, multibyte strings are converted
2255 to unibyte for insertion (see `string-make-unibyte').
2257 When operating on binary data, it may be necessary to preserve the
2258 original bytes of a unibyte string when inserting it into a multibyte
2259 buffer; to accomplish this, apply `string-as-multibyte' to the string
2260 and insert the result.
2262 usage: (insert &rest ARGS) */)
2263 (ptrdiff_t nargs
, Lisp_Object
*args
)
2265 general_insert_function (insert
, insert_from_string
, 0, nargs
, args
);
2269 DEFUN ("insert-and-inherit", Finsert_and_inherit
, Sinsert_and_inherit
,
2271 doc
: /* Insert the arguments at point, inheriting properties from adjoining text.
2272 Point and before-insertion markers move forward to end up
2273 after the inserted text.
2274 Any other markers at the point of insertion remain before the text.
2276 If the current buffer is multibyte, unibyte strings are converted
2277 to multibyte for insertion (see `unibyte-char-to-multibyte').
2278 If the current buffer is unibyte, multibyte strings are converted
2279 to unibyte for insertion.
2281 usage: (insert-and-inherit &rest ARGS) */)
2282 (ptrdiff_t nargs
, Lisp_Object
*args
)
2284 general_insert_function (insert_and_inherit
, insert_from_string
, 1,
2289 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
2290 doc
: /* Insert strings or characters at point, relocating markers after the text.
2291 Point and markers move forward to end up after the inserted text.
2293 If the current buffer is multibyte, unibyte strings are converted
2294 to multibyte for insertion (see `unibyte-char-to-multibyte').
2295 If the current buffer is unibyte, multibyte strings are converted
2296 to unibyte for insertion.
2298 usage: (insert-before-markers &rest ARGS) */)
2299 (ptrdiff_t nargs
, Lisp_Object
*args
)
2301 general_insert_function (insert_before_markers
,
2302 insert_from_string_before_markers
, 0,
2307 DEFUN ("insert-before-markers-and-inherit", Finsert_and_inherit_before_markers
,
2308 Sinsert_and_inherit_before_markers
, 0, MANY
, 0,
2309 doc
: /* Insert text at point, relocating markers and inheriting properties.
2310 Point and markers move forward to end up after the inserted text.
2312 If the current buffer is multibyte, unibyte strings are converted
2313 to multibyte for insertion (see `unibyte-char-to-multibyte').
2314 If the current buffer is unibyte, multibyte strings are converted
2315 to unibyte for insertion.
2317 usage: (insert-before-markers-and-inherit &rest ARGS) */)
2318 (ptrdiff_t nargs
, Lisp_Object
*args
)
2320 general_insert_function (insert_before_markers_and_inherit
,
2321 insert_from_string_before_markers
, 1,
2326 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 2, 3, 0,
2327 doc
: /* Insert COUNT copies of CHARACTER.
2328 Point, and before-insertion markers, are relocated as in the function `insert'.
2329 The optional third arg INHERIT, if non-nil, says to inherit text properties
2330 from adjoining text, if those properties are sticky. */)
2331 (Lisp_Object character
, Lisp_Object count
, Lisp_Object inherit
)
2334 register EMACS_INT n
;
2336 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2339 CHECK_CHARACTER (character
);
2340 CHECK_NUMBER (count
);
2341 c
= XFASTINT (character
);
2343 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2344 len
= CHAR_STRING (c
, str
);
2346 str
[0] = c
, len
= 1;
2347 if (XINT (count
) <= 0)
2349 if (BUF_BYTES_MAX
/ len
< XINT (count
))
2351 n
= XINT (count
) * len
;
2352 stringlen
= min (n
, sizeof string
- sizeof string
% len
);
2353 for (i
= 0; i
< stringlen
; i
++)
2354 string
[i
] = str
[i
% len
];
2355 while (n
> stringlen
)
2358 if (!NILP (inherit
))
2359 insert_and_inherit (string
, stringlen
);
2361 insert (string
, stringlen
);
2364 if (!NILP (inherit
))
2365 insert_and_inherit (string
, n
);
2371 DEFUN ("insert-byte", Finsert_byte
, Sinsert_byte
, 2, 3, 0,
2372 doc
: /* Insert COUNT (second arg) copies of BYTE (first arg).
2373 Both arguments are required.
2374 BYTE is a number of the range 0..255.
2376 If BYTE is 128..255 and the current buffer is multibyte, the
2377 corresponding eight-bit character is inserted.
2379 Point, and before-insertion markers, are relocated as in the function `insert'.
2380 The optional third arg INHERIT, if non-nil, says to inherit text properties
2381 from adjoining text, if those properties are sticky. */)
2382 (Lisp_Object byte
, Lisp_Object count
, Lisp_Object inherit
)
2384 CHECK_NUMBER (byte
);
2385 if (XINT (byte
) < 0 || XINT (byte
) > 255)
2386 args_out_of_range_3 (byte
, make_number (0), make_number (255));
2387 if (XINT (byte
) >= 128
2388 && ! NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2389 XSETFASTINT (byte
, BYTE8_TO_CHAR (XINT (byte
)));
2390 return Finsert_char (byte
, count
, inherit
);
2394 /* Making strings from buffer contents. */
2396 /* Return a Lisp_String containing the text of the current buffer from
2397 START to END. If text properties are in use and the current buffer
2398 has properties in the range specified, the resulting string will also
2399 have them, if PROPS is nonzero.
2401 We don't want to use plain old make_string here, because it calls
2402 make_uninit_string, which can cause the buffer arena to be
2403 compacted. make_string has no way of knowing that the data has
2404 been moved, and thus copies the wrong data into the string. This
2405 doesn't effect most of the other users of make_string, so it should
2406 be left as is. But we should use this function when conjuring
2407 buffer substrings. */
2410 make_buffer_string (EMACS_INT start
, EMACS_INT end
, int props
)
2412 EMACS_INT start_byte
= CHAR_TO_BYTE (start
);
2413 EMACS_INT end_byte
= CHAR_TO_BYTE (end
);
2415 return make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
);
2418 /* Return a Lisp_String containing the text of the current buffer from
2419 START / START_BYTE to END / END_BYTE.
2421 If text properties are in use and the current buffer
2422 has properties in the range specified, the resulting string will also
2423 have them, if PROPS is nonzero.
2425 We don't want to use plain old make_string here, because it calls
2426 make_uninit_string, which can cause the buffer arena to be
2427 compacted. make_string has no way of knowing that the data has
2428 been moved, and thus copies the wrong data into the string. This
2429 doesn't effect most of the other users of make_string, so it should
2430 be left as is. But we should use this function when conjuring
2431 buffer substrings. */
2434 make_buffer_string_both (EMACS_INT start
, EMACS_INT start_byte
,
2435 EMACS_INT end
, EMACS_INT end_byte
, int props
)
2437 Lisp_Object result
, tem
, tem1
;
2439 if (start
< GPT
&& GPT
< end
)
2442 if (! NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2443 result
= make_uninit_multibyte_string (end
- start
, end_byte
- start_byte
);
2445 result
= make_uninit_string (end
- start
);
2446 memcpy (SDATA (result
), BYTE_POS_ADDR (start_byte
), end_byte
- start_byte
);
2448 /* If desired, update and copy the text properties. */
2451 update_buffer_properties (start
, end
);
2453 tem
= Fnext_property_change (make_number (start
), Qnil
, make_number (end
));
2454 tem1
= Ftext_properties_at (make_number (start
), Qnil
);
2456 if (XINT (tem
) != end
|| !NILP (tem1
))
2457 copy_intervals_to_string (result
, current_buffer
, start
,
2464 /* Call Vbuffer_access_fontify_functions for the range START ... END
2465 in the current buffer, if necessary. */
2468 update_buffer_properties (EMACS_INT start
, EMACS_INT end
)
2470 /* If this buffer has some access functions,
2471 call them, specifying the range of the buffer being accessed. */
2472 if (!NILP (Vbuffer_access_fontify_functions
))
2474 Lisp_Object args
[3];
2477 args
[0] = Qbuffer_access_fontify_functions
;
2478 XSETINT (args
[1], start
);
2479 XSETINT (args
[2], end
);
2481 /* But don't call them if we can tell that the work
2482 has already been done. */
2483 if (!NILP (Vbuffer_access_fontified_property
))
2485 tem
= Ftext_property_any (args
[1], args
[2],
2486 Vbuffer_access_fontified_property
,
2489 Frun_hook_with_args (3, args
);
2492 Frun_hook_with_args (3, args
);
2496 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
2497 doc
: /* Return the contents of part of the current buffer as a string.
2498 The two arguments START and END are character positions;
2499 they can be in either order.
2500 The string returned is multibyte if the buffer is multibyte.
2502 This function copies the text properties of that part of the buffer
2503 into the result string; if you don't want the text properties,
2504 use `buffer-substring-no-properties' instead. */)
2505 (Lisp_Object start
, Lisp_Object end
)
2507 register EMACS_INT b
, e
;
2509 validate_region (&start
, &end
);
2513 return make_buffer_string (b
, e
, 1);
2516 DEFUN ("buffer-substring-no-properties", Fbuffer_substring_no_properties
,
2517 Sbuffer_substring_no_properties
, 2, 2, 0,
2518 doc
: /* Return the characters of part of the buffer, without the text properties.
2519 The two arguments START and END are character positions;
2520 they can be in either order. */)
2521 (Lisp_Object start
, Lisp_Object end
)
2523 register EMACS_INT b
, e
;
2525 validate_region (&start
, &end
);
2529 return make_buffer_string (b
, e
, 0);
2532 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
2533 doc
: /* Return the contents of the current buffer as a string.
2534 If narrowing is in effect, this function returns only the visible part
2538 return make_buffer_string (BEGV
, ZV
, 1);
2541 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
2543 doc
: /* Insert before point a substring of the contents of BUFFER.
2544 BUFFER may be a buffer or a buffer name.
2545 Arguments START and END are character positions specifying the substring.
2546 They default to the values of (point-min) and (point-max) in BUFFER. */)
2547 (Lisp_Object buffer
, Lisp_Object start
, Lisp_Object end
)
2549 register EMACS_INT b
, e
, temp
;
2550 register struct buffer
*bp
, *obuf
;
2553 buf
= Fget_buffer (buffer
);
2557 if (NILP (BVAR (bp
, name
)))
2558 error ("Selecting deleted buffer");
2564 CHECK_NUMBER_COERCE_MARKER (start
);
2571 CHECK_NUMBER_COERCE_MARKER (end
);
2576 temp
= b
, b
= e
, e
= temp
;
2578 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
2579 args_out_of_range (start
, end
);
2581 obuf
= current_buffer
;
2582 set_buffer_internal_1 (bp
);
2583 update_buffer_properties (b
, e
);
2584 set_buffer_internal_1 (obuf
);
2586 insert_from_buffer (bp
, b
, e
- b
, 0);
2590 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
2592 doc
: /* Compare two substrings of two buffers; return result as number.
2593 the value is -N if first string is less after N-1 chars,
2594 +N if first string is greater after N-1 chars, or 0 if strings match.
2595 Each substring is represented as three arguments: BUFFER, START and END.
2596 That makes six args in all, three for each substring.
2598 The value of `case-fold-search' in the current buffer
2599 determines whether case is significant or ignored. */)
2600 (Lisp_Object buffer1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object buffer2
, Lisp_Object start2
, Lisp_Object end2
)
2602 register EMACS_INT begp1
, endp1
, begp2
, endp2
, temp
;
2603 register struct buffer
*bp1
, *bp2
;
2604 register Lisp_Object trt
2605 = (!NILP (BVAR (current_buffer
, case_fold_search
))
2606 ? BVAR (current_buffer
, case_canon_table
) : Qnil
);
2607 EMACS_INT chars
= 0;
2608 EMACS_INT i1
, i2
, i1_byte
, i2_byte
;
2610 /* Find the first buffer and its substring. */
2613 bp1
= current_buffer
;
2617 buf1
= Fget_buffer (buffer1
);
2620 bp1
= XBUFFER (buf1
);
2621 if (NILP (BVAR (bp1
, name
)))
2622 error ("Selecting deleted buffer");
2626 begp1
= BUF_BEGV (bp1
);
2629 CHECK_NUMBER_COERCE_MARKER (start1
);
2630 begp1
= XINT (start1
);
2633 endp1
= BUF_ZV (bp1
);
2636 CHECK_NUMBER_COERCE_MARKER (end1
);
2637 endp1
= XINT (end1
);
2641 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
2643 if (!(BUF_BEGV (bp1
) <= begp1
2645 && endp1
<= BUF_ZV (bp1
)))
2646 args_out_of_range (start1
, end1
);
2648 /* Likewise for second substring. */
2651 bp2
= current_buffer
;
2655 buf2
= Fget_buffer (buffer2
);
2658 bp2
= XBUFFER (buf2
);
2659 if (NILP (BVAR (bp2
, name
)))
2660 error ("Selecting deleted buffer");
2664 begp2
= BUF_BEGV (bp2
);
2667 CHECK_NUMBER_COERCE_MARKER (start2
);
2668 begp2
= XINT (start2
);
2671 endp2
= BUF_ZV (bp2
);
2674 CHECK_NUMBER_COERCE_MARKER (end2
);
2675 endp2
= XINT (end2
);
2679 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
2681 if (!(BUF_BEGV (bp2
) <= begp2
2683 && endp2
<= BUF_ZV (bp2
)))
2684 args_out_of_range (start2
, end2
);
2688 i1_byte
= buf_charpos_to_bytepos (bp1
, i1
);
2689 i2_byte
= buf_charpos_to_bytepos (bp2
, i2
);
2691 while (i1
< endp1
&& i2
< endp2
)
2693 /* When we find a mismatch, we must compare the
2694 characters, not just the bytes. */
2699 if (! NILP (BVAR (bp1
, enable_multibyte_characters
)))
2701 c1
= BUF_FETCH_MULTIBYTE_CHAR (bp1
, i1_byte
);
2702 BUF_INC_POS (bp1
, i1_byte
);
2707 c1
= BUF_FETCH_BYTE (bp1
, i1
);
2708 MAKE_CHAR_MULTIBYTE (c1
);
2712 if (! NILP (BVAR (bp2
, enable_multibyte_characters
)))
2714 c2
= BUF_FETCH_MULTIBYTE_CHAR (bp2
, i2_byte
);
2715 BUF_INC_POS (bp2
, i2_byte
);
2720 c2
= BUF_FETCH_BYTE (bp2
, i2
);
2721 MAKE_CHAR_MULTIBYTE (c2
);
2727 c1
= CHAR_TABLE_TRANSLATE (trt
, c1
);
2728 c2
= CHAR_TABLE_TRANSLATE (trt
, c2
);
2731 return make_number (- 1 - chars
);
2733 return make_number (chars
+ 1);
2738 /* The strings match as far as they go.
2739 If one is shorter, that one is less. */
2740 if (chars
< endp1
- begp1
)
2741 return make_number (chars
+ 1);
2742 else if (chars
< endp2
- begp2
)
2743 return make_number (- chars
- 1);
2745 /* Same length too => they are equal. */
2746 return make_number (0);
2750 subst_char_in_region_unwind (Lisp_Object arg
)
2752 return BVAR (current_buffer
, undo_list
) = arg
;
2756 subst_char_in_region_unwind_1 (Lisp_Object arg
)
2758 return BVAR (current_buffer
, filename
) = arg
;
2761 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
2762 Ssubst_char_in_region
, 4, 5, 0,
2763 doc
: /* From START to END, replace FROMCHAR with TOCHAR each time it occurs.
2764 If optional arg NOUNDO is non-nil, don't record this change for undo
2765 and don't mark the buffer as really changed.
2766 Both characters must have the same length of multi-byte form. */)
2767 (Lisp_Object start
, Lisp_Object end
, Lisp_Object fromchar
, Lisp_Object tochar
, Lisp_Object noundo
)
2769 register EMACS_INT pos
, pos_byte
, stop
, i
, len
, end_byte
;
2770 /* Keep track of the first change in the buffer:
2771 if 0 we haven't found it yet.
2772 if < 0 we've found it and we've run the before-change-function.
2773 if > 0 we've actually performed it and the value is its position. */
2774 EMACS_INT changed
= 0;
2775 unsigned char fromstr
[MAX_MULTIBYTE_LENGTH
], tostr
[MAX_MULTIBYTE_LENGTH
];
2777 int count
= SPECPDL_INDEX ();
2778 #define COMBINING_NO 0
2779 #define COMBINING_BEFORE 1
2780 #define COMBINING_AFTER 2
2781 #define COMBINING_BOTH (COMBINING_BEFORE | COMBINING_AFTER)
2782 int maybe_byte_combining
= COMBINING_NO
;
2783 EMACS_INT last_changed
= 0;
2784 int multibyte_p
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
2789 validate_region (&start
, &end
);
2790 CHECK_CHARACTER (fromchar
);
2791 CHECK_CHARACTER (tochar
);
2792 fromc
= XFASTINT (fromchar
);
2793 toc
= XFASTINT (tochar
);
2797 len
= CHAR_STRING (fromc
, fromstr
);
2798 if (CHAR_STRING (toc
, tostr
) != len
)
2799 error ("Characters in `subst-char-in-region' have different byte-lengths");
2800 if (!ASCII_BYTE_P (*tostr
))
2802 /* If *TOSTR is in the range 0x80..0x9F and TOCHAR is not a
2803 complete multibyte character, it may be combined with the
2804 after bytes. If it is in the range 0xA0..0xFF, it may be
2805 combined with the before and after bytes. */
2806 if (!CHAR_HEAD_P (*tostr
))
2807 maybe_byte_combining
= COMBINING_BOTH
;
2808 else if (BYTES_BY_CHAR_HEAD (*tostr
) > len
)
2809 maybe_byte_combining
= COMBINING_AFTER
;
2820 pos_byte
= CHAR_TO_BYTE (pos
);
2821 stop
= CHAR_TO_BYTE (XINT (end
));
2824 /* If we don't want undo, turn off putting stuff on the list.
2825 That's faster than getting rid of things,
2826 and it prevents even the entry for a first change.
2827 Also inhibit locking the file. */
2828 if (!changed
&& !NILP (noundo
))
2830 record_unwind_protect (subst_char_in_region_unwind
,
2831 BVAR (current_buffer
, undo_list
));
2832 BVAR (current_buffer
, undo_list
) = Qt
;
2833 /* Don't do file-locking. */
2834 record_unwind_protect (subst_char_in_region_unwind_1
,
2835 BVAR (current_buffer
, filename
));
2836 BVAR (current_buffer
, filename
) = Qnil
;
2839 if (pos_byte
< GPT_BYTE
)
2840 stop
= min (stop
, GPT_BYTE
);
2843 EMACS_INT pos_byte_next
= pos_byte
;
2845 if (pos_byte
>= stop
)
2847 if (pos_byte
>= end_byte
) break;
2850 p
= BYTE_POS_ADDR (pos_byte
);
2852 INC_POS (pos_byte_next
);
2855 if (pos_byte_next
- pos_byte
== len
2856 && p
[0] == fromstr
[0]
2858 || (p
[1] == fromstr
[1]
2859 && (len
== 2 || (p
[2] == fromstr
[2]
2860 && (len
== 3 || p
[3] == fromstr
[3]))))))
2863 /* We've already seen this and run the before-change-function;
2864 this time we only need to record the actual position. */
2869 modify_region (current_buffer
, pos
, XINT (end
), 0);
2871 if (! NILP (noundo
))
2873 if (MODIFF
- 1 == SAVE_MODIFF
)
2875 if (MODIFF
- 1 == BUF_AUTOSAVE_MODIFF (current_buffer
))
2876 BUF_AUTOSAVE_MODIFF (current_buffer
)++;
2879 /* The before-change-function may have moved the gap
2880 or even modified the buffer so we should start over. */
2884 /* Take care of the case where the new character
2885 combines with neighboring bytes. */
2886 if (maybe_byte_combining
2887 && (maybe_byte_combining
== COMBINING_AFTER
2888 ? (pos_byte_next
< Z_BYTE
2889 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2890 : ((pos_byte_next
< Z_BYTE
2891 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2892 || (pos_byte
> BEG_BYTE
2893 && ! ASCII_BYTE_P (FETCH_BYTE (pos_byte
- 1))))))
2895 Lisp_Object tem
, string
;
2897 struct gcpro gcpro1
;
2899 tem
= BVAR (current_buffer
, undo_list
);
2902 /* Make a multibyte string containing this single character. */
2903 string
= make_multibyte_string ((char *) tostr
, 1, len
);
2904 /* replace_range is less efficient, because it moves the gap,
2905 but it handles combining correctly. */
2906 replace_range (pos
, pos
+ 1, string
,
2908 pos_byte_next
= CHAR_TO_BYTE (pos
);
2909 if (pos_byte_next
> pos_byte
)
2910 /* Before combining happened. We should not increment
2911 POS. So, to cancel the later increment of POS,
2915 INC_POS (pos_byte_next
);
2917 if (! NILP (noundo
))
2918 BVAR (current_buffer
, undo_list
) = tem
;
2925 record_change (pos
, 1);
2926 for (i
= 0; i
< len
; i
++) *p
++ = tostr
[i
];
2928 last_changed
= pos
+ 1;
2930 pos_byte
= pos_byte_next
;
2936 signal_after_change (changed
,
2937 last_changed
- changed
, last_changed
- changed
);
2938 update_compositions (changed
, last_changed
, CHECK_ALL
);
2941 unbind_to (count
, Qnil
);
2946 static Lisp_Object
check_translation (EMACS_INT
, EMACS_INT
, EMACS_INT
,
2949 /* Helper function for Ftranslate_region_internal.
2951 Check if a character sequence at POS (POS_BYTE) matches an element
2952 of VAL. VAL is a list (([FROM-CHAR ...] . TO) ...). If a matching
2953 element is found, return it. Otherwise return Qnil. */
2956 check_translation (EMACS_INT pos
, EMACS_INT pos_byte
, EMACS_INT end
,
2959 int buf_size
= 16, buf_used
= 0;
2960 int *buf
= alloca (sizeof (int) * buf_size
);
2962 for (; CONSP (val
); val
= XCDR (val
))
2971 if (! VECTORP (elt
))
2974 if (len
<= end
- pos
)
2976 for (i
= 0; i
< len
; i
++)
2980 unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
2983 if (buf_used
== buf_size
)
2988 newbuf
= alloca (sizeof (int) * buf_size
);
2989 memcpy (newbuf
, buf
, sizeof (int) * buf_used
);
2992 buf
[buf_used
++] = STRING_CHAR_AND_LENGTH (p
, len1
);
2995 if (XINT (AREF (elt
, i
)) != buf
[i
])
3006 DEFUN ("translate-region-internal", Ftranslate_region_internal
,
3007 Stranslate_region_internal
, 3, 3, 0,
3008 doc
: /* Internal use only.
3009 From START to END, translate characters according to TABLE.
3010 TABLE is a string or a char-table; the Nth character in it is the
3011 mapping for the character with code N.
3012 It returns the number of characters changed. */)
3013 (Lisp_Object start
, Lisp_Object end
, register Lisp_Object table
)
3015 register unsigned char *tt
; /* Trans table. */
3016 register int nc
; /* New character. */
3017 int cnt
; /* Number of changes made. */
3018 EMACS_INT size
; /* Size of translate table. */
3019 EMACS_INT pos
, pos_byte
, end_pos
;
3020 int multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3021 int string_multibyte
IF_LINT (= 0);
3023 validate_region (&start
, &end
);
3024 if (CHAR_TABLE_P (table
))
3026 if (! EQ (XCHAR_TABLE (table
)->purpose
, Qtranslation_table
))
3027 error ("Not a translation table");
3033 CHECK_STRING (table
);
3035 if (! multibyte
&& (SCHARS (table
) < SBYTES (table
)))
3036 table
= string_make_unibyte (table
);
3037 string_multibyte
= SCHARS (table
) < SBYTES (table
);
3038 size
= SBYTES (table
);
3043 pos_byte
= CHAR_TO_BYTE (pos
);
3044 end_pos
= XINT (end
);
3045 modify_region (current_buffer
, pos
, end_pos
, 0);
3048 for (; pos
< end_pos
; )
3050 register unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
3051 unsigned char *str
, buf
[MAX_MULTIBYTE_LENGTH
];
3057 oc
= STRING_CHAR_AND_LENGTH (p
, len
);
3064 /* Reload as signal_after_change in last iteration may GC. */
3066 if (string_multibyte
)
3068 str
= tt
+ string_char_to_byte (table
, oc
);
3069 nc
= STRING_CHAR_AND_LENGTH (str
, str_len
);
3074 if (! ASCII_BYTE_P (nc
) && multibyte
)
3076 str_len
= BYTE8_STRING (nc
, buf
);
3089 val
= CHAR_TABLE_REF (table
, oc
);
3090 if (CHARACTERP (val
))
3092 nc
= XFASTINT (val
);
3093 str_len
= CHAR_STRING (nc
, buf
);
3096 else if (VECTORP (val
) || (CONSP (val
)))
3098 /* VAL is [TO_CHAR ...] or (([FROM-CHAR ...] . TO) ...)
3099 where TO is TO-CHAR or [TO-CHAR ...]. */
3104 if (nc
!= oc
&& nc
>= 0)
3106 /* Simple one char to one char translation. */
3111 /* This is less efficient, because it moves the gap,
3112 but it should handle multibyte characters correctly. */
3113 string
= make_multibyte_string ((char *) str
, 1, str_len
);
3114 replace_range (pos
, pos
+ 1, string
, 1, 0, 1);
3119 record_change (pos
, 1);
3120 while (str_len
-- > 0)
3122 signal_after_change (pos
, 1, 1);
3123 update_compositions (pos
, pos
+ 1, CHECK_BORDER
);
3133 val
= check_translation (pos
, pos_byte
, end_pos
, val
);
3140 /* VAL is ([FROM-CHAR ...] . TO). */
3141 len
= ASIZE (XCAR (val
));
3149 string
= Fconcat (1, &val
);
3153 string
= Fmake_string (make_number (1), val
);
3155 replace_range (pos
, pos
+ len
, string
, 1, 0, 1);
3156 pos_byte
+= SBYTES (string
);
3157 pos
+= SCHARS (string
);
3158 cnt
+= SCHARS (string
);
3159 end_pos
+= SCHARS (string
) - len
;
3167 return make_number (cnt
);
3170 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
3171 doc
: /* Delete the text between START and END.
3172 If called interactively, delete the region between point and mark.
3173 This command deletes buffer text without modifying the kill ring. */)
3174 (Lisp_Object start
, Lisp_Object end
)
3176 validate_region (&start
, &end
);
3177 del_range (XINT (start
), XINT (end
));
3181 DEFUN ("delete-and-extract-region", Fdelete_and_extract_region
,
3182 Sdelete_and_extract_region
, 2, 2, 0,
3183 doc
: /* Delete the text between START and END and return it. */)
3184 (Lisp_Object start
, Lisp_Object end
)
3186 validate_region (&start
, &end
);
3187 if (XINT (start
) == XINT (end
))
3188 return empty_unibyte_string
;
3189 return del_range_1 (XINT (start
), XINT (end
), 1, 1);
3192 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
3193 doc
: /* Remove restrictions (narrowing) from current buffer.
3194 This allows the buffer's full text to be seen and edited. */)
3197 if (BEG
!= BEGV
|| Z
!= ZV
)
3198 current_buffer
->clip_changed
= 1;
3200 BEGV_BYTE
= BEG_BYTE
;
3201 SET_BUF_ZV_BOTH (current_buffer
, Z
, Z_BYTE
);
3202 /* Changing the buffer bounds invalidates any recorded current column. */
3203 invalidate_current_column ();
3207 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
3208 doc
: /* Restrict editing in this buffer to the current region.
3209 The rest of the text becomes temporarily invisible and untouchable
3210 but is not deleted; if you save the buffer in a file, the invisible
3211 text is included in the file. \\[widen] makes all visible again.
3212 See also `save-restriction'.
3214 When calling from a program, pass two arguments; positions (integers
3215 or markers) bounding the text that should remain visible. */)
3216 (register Lisp_Object start
, Lisp_Object end
)
3218 CHECK_NUMBER_COERCE_MARKER (start
);
3219 CHECK_NUMBER_COERCE_MARKER (end
);
3221 if (XINT (start
) > XINT (end
))
3224 tem
= start
; start
= end
; end
= tem
;
3227 if (!(BEG
<= XINT (start
) && XINT (start
) <= XINT (end
) && XINT (end
) <= Z
))
3228 args_out_of_range (start
, end
);
3230 if (BEGV
!= XFASTINT (start
) || ZV
!= XFASTINT (end
))
3231 current_buffer
->clip_changed
= 1;
3233 SET_BUF_BEGV (current_buffer
, XFASTINT (start
));
3234 SET_BUF_ZV (current_buffer
, XFASTINT (end
));
3235 if (PT
< XFASTINT (start
))
3236 SET_PT (XFASTINT (start
));
3237 if (PT
> XFASTINT (end
))
3238 SET_PT (XFASTINT (end
));
3239 /* Changing the buffer bounds invalidates any recorded current column. */
3240 invalidate_current_column ();
3245 save_restriction_save (void)
3247 if (BEGV
== BEG
&& ZV
== Z
)
3248 /* The common case that the buffer isn't narrowed.
3249 We return just the buffer object, which save_restriction_restore
3250 recognizes as meaning `no restriction'. */
3251 return Fcurrent_buffer ();
3253 /* We have to save a restriction, so return a pair of markers, one
3254 for the beginning and one for the end. */
3256 Lisp_Object beg
, end
;
3258 beg
= buildmark (BEGV
, BEGV_BYTE
);
3259 end
= buildmark (ZV
, ZV_BYTE
);
3261 /* END must move forward if text is inserted at its exact location. */
3262 XMARKER (end
)->insertion_type
= 1;
3264 return Fcons (beg
, end
);
3269 save_restriction_restore (Lisp_Object data
)
3271 struct buffer
*cur
= NULL
;
3272 struct buffer
*buf
= (CONSP (data
)
3273 ? XMARKER (XCAR (data
))->buffer
3276 if (buf
&& buf
!= current_buffer
&& !NILP (BVAR (buf
, pt_marker
)))
3277 { /* If `buf' uses markers to keep track of PT, BEGV, and ZV (as
3278 is the case if it is or has an indirect buffer), then make
3279 sure it is current before we update BEGV, so
3280 set_buffer_internal takes care of managing those markers. */
3281 cur
= current_buffer
;
3282 set_buffer_internal (buf
);
3286 /* A pair of marks bounding a saved restriction. */
3288 struct Lisp_Marker
*beg
= XMARKER (XCAR (data
));
3289 struct Lisp_Marker
*end
= XMARKER (XCDR (data
));
3290 eassert (buf
== end
->buffer
);
3292 if (buf
/* Verify marker still points to a buffer. */
3293 && (beg
->charpos
!= BUF_BEGV (buf
) || end
->charpos
!= BUF_ZV (buf
)))
3294 /* The restriction has changed from the saved one, so restore
3295 the saved restriction. */
3297 EMACS_INT pt
= BUF_PT (buf
);
3299 SET_BUF_BEGV_BOTH (buf
, beg
->charpos
, beg
->bytepos
);
3300 SET_BUF_ZV_BOTH (buf
, end
->charpos
, end
->bytepos
);
3302 if (pt
< beg
->charpos
|| pt
> end
->charpos
)
3303 /* The point is outside the new visible range, move it inside. */
3304 SET_BUF_PT_BOTH (buf
,
3305 clip_to_bounds (beg
->charpos
, pt
, end
->charpos
),
3306 clip_to_bounds (beg
->bytepos
, BUF_PT_BYTE (buf
),
3309 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3313 /* A buffer, which means that there was no old restriction. */
3315 if (buf
/* Verify marker still points to a buffer. */
3316 && (BUF_BEGV (buf
) != BUF_BEG (buf
) || BUF_ZV (buf
) != BUF_Z (buf
)))
3317 /* The buffer has been narrowed, get rid of the narrowing. */
3319 SET_BUF_BEGV_BOTH (buf
, BUF_BEG (buf
), BUF_BEG_BYTE (buf
));
3320 SET_BUF_ZV_BOTH (buf
, BUF_Z (buf
), BUF_Z_BYTE (buf
));
3322 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3326 /* Changing the buffer bounds invalidates any recorded current column. */
3327 invalidate_current_column ();
3330 set_buffer_internal (cur
);
3335 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
3336 doc
: /* Execute BODY, saving and restoring current buffer's restrictions.
3337 The buffer's restrictions make parts of the beginning and end invisible.
3338 \(They are set up with `narrow-to-region' and eliminated with `widen'.)
3339 This special form, `save-restriction', saves the current buffer's restrictions
3340 when it is entered, and restores them when it is exited.
3341 So any `narrow-to-region' within BODY lasts only until the end of the form.
3342 The old restrictions settings are restored
3343 even in case of abnormal exit (throw or error).
3345 The value returned is the value of the last form in BODY.
3347 Note: if you are using both `save-excursion' and `save-restriction',
3348 use `save-excursion' outermost:
3349 (save-excursion (save-restriction ...))
3351 usage: (save-restriction &rest BODY) */)
3354 register Lisp_Object val
;
3355 int count
= SPECPDL_INDEX ();
3357 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
3358 val
= Fprogn (body
);
3359 return unbind_to (count
, val
);
3362 /* Buffer for the most recent text displayed by Fmessage_box. */
3363 static char *message_text
;
3365 /* Allocated length of that buffer. */
3366 static ptrdiff_t message_length
;
3368 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
3369 doc
: /* Display a message at the bottom of the screen.
3370 The message also goes into the `*Messages*' buffer.
3371 \(In keyboard macros, that's all it does.)
3374 The first argument is a format control string, and the rest are data
3375 to be formatted under control of the string. See `format' for details.
3377 Note: Use (message "%s" VALUE) to print the value of expressions and
3378 variables to avoid accidentally interpreting `%' as format specifiers.
3380 If the first argument is nil or the empty string, the function clears
3381 any existing message; this lets the minibuffer contents show. See
3382 also `current-message'.
3384 usage: (message FORMAT-STRING &rest ARGS) */)
3385 (ptrdiff_t nargs
, Lisp_Object
*args
)
3388 || (STRINGP (args
[0])
3389 && SBYTES (args
[0]) == 0))
3396 register Lisp_Object val
;
3397 val
= Fformat (nargs
, args
);
3398 message3 (val
, SBYTES (val
), STRING_MULTIBYTE (val
));
3403 DEFUN ("message-box", Fmessage_box
, Smessage_box
, 1, MANY
, 0,
3404 doc
: /* Display a message, in a dialog box if possible.
3405 If a dialog box is not available, use the echo area.
3406 The first argument is a format control string, and the rest are data
3407 to be formatted under control of the string. See `format' for details.
3409 If the first argument is nil or the empty string, clear any existing
3410 message; let the minibuffer contents show.
3412 usage: (message-box FORMAT-STRING &rest ARGS) */)
3413 (ptrdiff_t nargs
, Lisp_Object
*args
)
3422 register Lisp_Object val
;
3423 val
= Fformat (nargs
, args
);
3425 /* The MS-DOS frames support popup menus even though they are
3426 not FRAME_WINDOW_P. */
3427 if (FRAME_WINDOW_P (XFRAME (selected_frame
))
3428 || FRAME_MSDOS_P (XFRAME (selected_frame
)))
3430 Lisp_Object pane
, menu
;
3431 struct gcpro gcpro1
;
3432 pane
= Fcons (Fcons (build_string ("OK"), Qt
), Qnil
);
3434 menu
= Fcons (val
, pane
);
3435 Fx_popup_dialog (Qt
, menu
, Qt
);
3439 #endif /* HAVE_MENUS */
3440 /* Copy the data so that it won't move when we GC. */
3443 message_text
= (char *)xmalloc (80);
3444 message_length
= 80;
3446 if (SBYTES (val
) > message_length
)
3448 message_text
= (char *) xrealloc (message_text
, SBYTES (val
));
3449 message_length
= SBYTES (val
);
3451 memcpy (message_text
, SDATA (val
), SBYTES (val
));
3452 message2 (message_text
, SBYTES (val
),
3453 STRING_MULTIBYTE (val
));
3458 DEFUN ("message-or-box", Fmessage_or_box
, Smessage_or_box
, 1, MANY
, 0,
3459 doc
: /* Display a message in a dialog box or in the echo area.
3460 If this command was invoked with the mouse, use a dialog box if
3461 `use-dialog-box' is non-nil.
3462 Otherwise, use the echo area.
3463 The first argument is a format control string, and the rest are data
3464 to be formatted under control of the string. See `format' for details.
3466 If the first argument is nil or the empty string, clear any existing
3467 message; let the minibuffer contents show.
3469 usage: (message-or-box FORMAT-STRING &rest ARGS) */)
3470 (ptrdiff_t nargs
, Lisp_Object
*args
)
3473 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3475 return Fmessage_box (nargs
, args
);
3477 return Fmessage (nargs
, args
);
3480 DEFUN ("current-message", Fcurrent_message
, Scurrent_message
, 0, 0, 0,
3481 doc
: /* Return the string currently displayed in the echo area, or nil if none. */)
3484 return current_message ();
3488 DEFUN ("propertize", Fpropertize
, Spropertize
, 1, MANY
, 0,
3489 doc
: /* Return a copy of STRING with text properties added.
3490 First argument is the string to copy.
3491 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
3492 properties to add to the result.
3493 usage: (propertize STRING &rest PROPERTIES) */)
3494 (ptrdiff_t nargs
, Lisp_Object
*args
)
3496 Lisp_Object properties
, string
;
3497 struct gcpro gcpro1
, gcpro2
;
3500 /* Number of args must be odd. */
3501 if ((nargs
& 1) == 0)
3502 error ("Wrong number of arguments");
3504 properties
= string
= Qnil
;
3505 GCPRO2 (properties
, string
);
3507 /* First argument must be a string. */
3508 CHECK_STRING (args
[0]);
3509 string
= Fcopy_sequence (args
[0]);
3511 for (i
= 1; i
< nargs
; i
+= 2)
3512 properties
= Fcons (args
[i
], Fcons (args
[i
+ 1], properties
));
3514 Fadd_text_properties (make_number (0),
3515 make_number (SCHARS (string
)),
3516 properties
, string
);
3517 RETURN_UNGCPRO (string
);
3520 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
3521 doc
: /* Format a string out of a format-string and arguments.
3522 The first argument is a format control string.
3523 The other arguments are substituted into it to make the result, a string.
3525 The format control string may contain %-sequences meaning to substitute
3526 the next available argument:
3528 %s means print a string argument. Actually, prints any object, with `princ'.
3529 %d means print as number in decimal (%o octal, %x hex).
3530 %X is like %x, but uses upper case.
3531 %e means print a number in exponential notation.
3532 %f means print a number in decimal-point notation.
3533 %g means print a number in exponential notation
3534 or decimal-point notation, whichever uses fewer characters.
3535 %c means print a number as a single character.
3536 %S means print any object as an s-expression (using `prin1').
3538 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.
3539 Use %% to put a single % into the output.
3541 A %-sequence may contain optional flag, width, and precision
3542 specifiers, as follows:
3544 %<flags><width><precision>character
3546 where flags is [+ #-0]+, width is [0-9]+, and precision is .[0-9]+
3548 The + flag character inserts a + before any positive number, while a
3549 space inserts a space before any positive number; these flags only
3550 affect %d, %e, %f, and %g sequences, and the + flag takes precedence.
3551 The # flag means to use an alternate display form for %o, %x, %X, %e,
3552 %f, and %g sequences. The - and 0 flags affect the width specifier,
3555 The width specifier supplies a lower limit for the length of the
3556 printed representation. The padding, if any, normally goes on the
3557 left, but it goes on the right if the - flag is present. The padding
3558 character is normally a space, but it is 0 if the 0 flag is present.
3559 The 0 flag is ignored if the - flag is present, or the format sequence
3560 is something other than %d, %e, %f, and %g.
3562 For %e, %f, and %g sequences, the number after the "." in the
3563 precision specifier says how many decimal places to show; if zero, the
3564 decimal point itself is omitted. For %s and %S, the precision
3565 specifier truncates the string to the given width.
3567 usage: (format STRING &rest OBJECTS) */)
3568 (ptrdiff_t nargs
, Lisp_Object
*args
)
3570 ptrdiff_t n
; /* The number of the next arg to substitute */
3571 char initial_buffer
[4000];
3572 char *buf
= initial_buffer
;
3573 EMACS_INT bufsize
= sizeof initial_buffer
;
3574 EMACS_INT max_bufsize
= STRING_BYTES_BOUND
+ 1;
3576 Lisp_Object buf_save_value
IF_LINT (= {0});
3577 register char *format
, *end
, *format_start
;
3578 EMACS_INT formatlen
, nchars
;
3579 /* Nonzero if the format is multibyte. */
3580 int multibyte_format
= 0;
3581 /* Nonzero if the output should be a multibyte string,
3582 which is true if any of the inputs is one. */
3584 /* When we make a multibyte string, we must pay attention to the
3585 byte combining problem, i.e., a byte may be combined with a
3586 multibyte character of the previous string. This flag tells if we
3587 must consider such a situation or not. */
3588 int maybe_combine_byte
;
3590 int arg_intervals
= 0;
3593 /* discarded[I] is 1 if byte I of the format
3594 string was not copied into the output.
3595 It is 2 if byte I was not the first byte of its character. */
3598 /* Each element records, for one argument,
3599 the start and end bytepos in the output string,
3600 whether the argument has been converted to string (e.g., due to "%S"),
3601 and whether the argument is a string with intervals.
3602 info[0] is unused. Unused elements have -1 for start. */
3605 EMACS_INT start
, end
;
3606 int converted_to_string
;
3610 /* It should not be necessary to GCPRO ARGS, because
3611 the caller in the interpreter should take care of that. */
3613 CHECK_STRING (args
[0]);
3614 format_start
= SSDATA (args
[0]);
3615 formatlen
= SBYTES (args
[0]);
3617 /* Allocate the info and discarded tables. */
3620 if ((SIZE_MAX
- formatlen
) / sizeof (struct info
) <= nargs
)
3621 memory_full (SIZE_MAX
);
3622 SAFE_ALLOCA (info
, struct info
*, (nargs
+ 1) * sizeof *info
+ formatlen
);
3623 discarded
= (char *) &info
[nargs
+ 1];
3624 for (i
= 0; i
< nargs
+ 1; i
++)
3627 info
[i
].intervals
= info
[i
].converted_to_string
= 0;
3629 memset (discarded
, 0, formatlen
);
3632 /* Try to determine whether the result should be multibyte.
3633 This is not always right; sometimes the result needs to be multibyte
3634 because of an object that we will pass through prin1,
3635 and in that case, we won't know it here. */
3636 multibyte_format
= STRING_MULTIBYTE (args
[0]);
3637 multibyte
= multibyte_format
;
3638 for (n
= 1; !multibyte
&& n
< nargs
; n
++)
3639 if (STRINGP (args
[n
]) && STRING_MULTIBYTE (args
[n
]))
3642 /* If we start out planning a unibyte result,
3643 then discover it has to be multibyte, we jump back to retry. */
3650 /* Scan the format and store result in BUF. */
3651 format
= format_start
;
3652 end
= format
+ formatlen
;
3653 maybe_combine_byte
= 0;
3655 while (format
!= end
)
3657 /* The values of N and FORMAT when the loop body is entered. */
3659 char *format0
= format
;
3661 /* Bytes needed to represent the output of this conversion. */
3662 EMACS_INT convbytes
;
3666 /* General format specifications look like
3668 '%' [flags] [field-width] [precision] format
3673 field-width ::= [0-9]+
3674 precision ::= '.' [0-9]*
3676 If a field-width is specified, it specifies to which width
3677 the output should be padded with blanks, if the output
3678 string is shorter than field-width.
3680 If precision is specified, it specifies the number of
3681 digits to print after the '.' for floats, or the max.
3682 number of chars to print from a string. */
3689 EMACS_INT field_width
;
3690 int precision_given
;
3691 uintmax_t precision
= UINTMAX_MAX
;
3699 case '-': minus_flag
= 1; continue;
3700 case '+': plus_flag
= 1; continue;
3701 case ' ': space_flag
= 1; continue;
3702 case '#': sharp_flag
= 1; continue;
3703 case '0': zero_flag
= 1; continue;
3708 /* Ignore flags when sprintf ignores them. */
3709 space_flag
&= ~ plus_flag
;
3710 zero_flag
&= ~ minus_flag
;
3713 uintmax_t w
= strtoumax (format
, &num_end
, 10);
3714 if (max_bufsize
<= w
)
3718 precision_given
= *num_end
== '.';
3719 if (precision_given
)
3720 precision
= strtoumax (num_end
+ 1, &num_end
, 10);
3724 error ("Format string ends in middle of format specifier");
3726 memset (&discarded
[format0
- format_start
], 1, format
- format0
);
3727 conversion
= *format
;
3728 if (conversion
== '%')
3730 discarded
[format
- format_start
] = 1;
3735 error ("Not enough arguments for format string");
3737 /* For 'S', prin1 the argument, and then treat like 's'.
3738 For 's', princ any argument that is not a string or
3739 symbol. But don't do this conversion twice, which might
3740 happen after retrying. */
3741 if ((conversion
== 'S'
3742 || (conversion
== 's'
3743 && ! STRINGP (args
[n
]) && ! SYMBOLP (args
[n
]))))
3745 if (! info
[n
].converted_to_string
)
3747 Lisp_Object noescape
= conversion
== 'S' ? Qnil
: Qt
;
3748 args
[n
] = Fprin1_to_string (args
[n
], noescape
);
3749 info
[n
].converted_to_string
= 1;
3750 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
3758 else if (conversion
== 'c')
3760 if (FLOATP (args
[n
]))
3762 double d
= XFLOAT_DATA (args
[n
]);
3763 args
[n
] = make_number (FIXNUM_OVERFLOW_P (d
) ? -1 : d
);
3766 if (INTEGERP (args
[n
]) && ! ASCII_CHAR_P (XINT (args
[n
])))
3773 args
[n
] = Fchar_to_string (args
[n
]);
3774 info
[n
].converted_to_string
= 1;
3777 if (info
[n
].converted_to_string
)
3782 if (SYMBOLP (args
[n
]))
3784 args
[n
] = SYMBOL_NAME (args
[n
]);
3785 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
3792 if (conversion
== 's')
3794 /* handle case (precision[n] >= 0) */
3796 EMACS_INT width
, padding
, nbytes
;
3797 EMACS_INT nchars_string
;
3799 EMACS_INT prec
= -1;
3800 if (precision_given
&& precision
<= TYPE_MAXIMUM (EMACS_INT
))
3803 /* lisp_string_width ignores a precision of 0, but GNU
3804 libc functions print 0 characters when the precision
3805 is 0. Imitate libc behavior here. Changing
3806 lisp_string_width is the right thing, and will be
3807 done, but meanwhile we work with it. */
3810 width
= nchars_string
= nbytes
= 0;
3814 width
= lisp_string_width (args
[n
], prec
, &nch
, &nby
);
3817 nchars_string
= SCHARS (args
[n
]);
3818 nbytes
= SBYTES (args
[n
]);
3822 nchars_string
= nch
;
3828 if (convbytes
&& multibyte
&& ! STRING_MULTIBYTE (args
[n
]))
3829 convbytes
= count_size_as_multibyte (SDATA (args
[n
]), nbytes
);
3831 padding
= width
< field_width
? field_width
- width
: 0;
3833 if (max_bufsize
- padding
<= convbytes
)
3835 convbytes
+= padding
;
3836 if (convbytes
<= buf
+ bufsize
- p
)
3840 memset (p
, ' ', padding
);
3847 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3848 && STRING_MULTIBYTE (args
[n
])
3849 && !CHAR_HEAD_P (SREF (args
[n
], 0)))
3850 maybe_combine_byte
= 1;
3852 p
+= copy_text (SDATA (args
[n
]), (unsigned char *) p
,
3854 STRING_MULTIBYTE (args
[n
]), multibyte
);
3856 info
[n
].start
= nchars
;
3857 nchars
+= nchars_string
;
3858 info
[n
].end
= nchars
;
3862 memset (p
, ' ', padding
);
3867 /* If this argument has text properties, record where
3868 in the result string it appears. */
3869 if (STRING_INTERVALS (args
[n
]))
3870 info
[n
].intervals
= arg_intervals
= 1;
3875 else if (! (conversion
== 'c' || conversion
== 'd'
3876 || conversion
== 'e' || conversion
== 'f'
3877 || conversion
== 'g' || conversion
== 'i'
3878 || conversion
== 'o' || conversion
== 'x'
3879 || conversion
== 'X'))
3880 error ("Invalid format operation %%%c",
3881 STRING_CHAR ((unsigned char *) format
- 1));
3882 else if (! (INTEGERP (args
[n
]) || FLOATP (args
[n
])))
3883 error ("Format specifier doesn't match argument type");
3888 /* Maximum precision for a %f conversion such that the
3889 trailing output digit might be nonzero. Any precision
3890 larger than this will not yield useful information. */
3891 USEFUL_PRECISION_MAX
=
3893 * (FLT_RADIX
== 2 || FLT_RADIX
== 10 ? 1
3894 : FLT_RADIX
== 16 ? 4
3897 /* Maximum number of bytes generated by any format, if
3898 precision is no more than USEFUL_PRECISION_MAX.
3899 On all practical hosts, %f is the worst case. */
3901 sizeof "-." + (DBL_MAX_10_EXP
+ 1) + USEFUL_PRECISION_MAX
,
3903 /* Length of pM (that is, of pMd without the
3905 pMlen
= sizeof pMd
- 2
3907 verify (0 < USEFUL_PRECISION_MAX
);
3910 EMACS_INT padding
, sprintf_bytes
;
3911 uintmax_t excess_precision
, numwidth
;
3912 uintmax_t leading_zeros
= 0, trailing_zeros
= 0;
3914 char sprintf_buf
[SPRINTF_BUFSIZE
];
3916 /* Copy of conversion specification, modified somewhat.
3917 At most three flags F can be specified at once. */
3918 char convspec
[sizeof "%FFF.*d" + pMlen
];
3920 /* Avoid undefined behavior in underlying sprintf. */
3921 if (conversion
== 'd' || conversion
== 'i')
3924 /* Create the copy of the conversion specification, with
3925 any width and precision removed, with ".*" inserted,
3926 and with pM inserted for integer formats. */
3930 *f
= '-'; f
+= minus_flag
;
3931 *f
= '+'; f
+= plus_flag
;
3932 *f
= ' '; f
+= space_flag
;
3933 *f
= '#'; f
+= sharp_flag
;
3934 *f
= '0'; f
+= zero_flag
;
3937 if (conversion
== 'd' || conversion
== 'i'
3938 || conversion
== 'o' || conversion
== 'x'
3939 || conversion
== 'X')
3941 memcpy (f
, pMd
, pMlen
);
3943 zero_flag
&= ~ precision_given
;
3950 if (precision_given
)
3951 prec
= min (precision
, USEFUL_PRECISION_MAX
);
3953 /* Use sprintf to format this number into sprintf_buf. Omit
3954 padding and excess precision, though, because sprintf limits
3955 output length to INT_MAX.
3957 There are four types of conversion: double, unsigned
3958 char (passed as int), wide signed int, and wide
3959 unsigned int. Treat them separately because the
3960 sprintf ABI is sensitive to which type is passed. Be
3961 careful about integer overflow, NaNs, infinities, and
3962 conversions; for example, the min and max macros are
3963 not suitable here. */
3964 if (conversion
== 'e' || conversion
== 'f' || conversion
== 'g')
3966 double x
= (INTEGERP (args
[n
])
3968 : XFLOAT_DATA (args
[n
]));
3969 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
3971 else if (conversion
== 'c')
3973 /* Don't use sprintf here, as it might mishandle prec. */
3974 sprintf_buf
[0] = XINT (args
[n
]);
3975 sprintf_bytes
= prec
!= 0;
3977 else if (conversion
== 'd')
3979 /* For float, maybe we should use "%1.0f"
3980 instead so it also works for values outside
3981 the integer range. */
3983 if (INTEGERP (args
[n
]))
3987 double d
= XFLOAT_DATA (args
[n
]);
3990 x
= TYPE_MINIMUM (printmax_t
);
3996 x
= TYPE_MAXIMUM (printmax_t
);
4001 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4005 /* Don't sign-extend for octal or hex printing. */
4007 if (INTEGERP (args
[n
]))
4008 x
= XUINT (args
[n
]);
4011 double d
= XFLOAT_DATA (args
[n
]);
4016 x
= TYPE_MAXIMUM (uprintmax_t
);
4021 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4024 /* Now the length of the formatted item is known, except it omits
4025 padding and excess precision. Deal with excess precision
4026 first. This happens only when the format specifies
4027 ridiculously large precision. */
4028 excess_precision
= precision
- prec
;
4029 if (excess_precision
)
4031 if (conversion
== 'e' || conversion
== 'f'
4032 || conversion
== 'g')
4034 if ((conversion
== 'g' && ! sharp_flag
)
4035 || ! ('0' <= sprintf_buf
[sprintf_bytes
- 1]
4036 && sprintf_buf
[sprintf_bytes
- 1] <= '9'))
4037 excess_precision
= 0;
4040 if (conversion
== 'g')
4042 char *dot
= strchr (sprintf_buf
, '.');
4044 excess_precision
= 0;
4047 trailing_zeros
= excess_precision
;
4050 leading_zeros
= excess_precision
;
4053 /* Compute the total bytes needed for this item, including
4054 excess precision and padding. */
4055 numwidth
= sprintf_bytes
+ excess_precision
;
4056 padding
= numwidth
< field_width
? field_width
- numwidth
: 0;
4057 if (max_bufsize
- sprintf_bytes
<= excess_precision
4058 || max_bufsize
- padding
<= numwidth
)
4060 convbytes
= numwidth
+ padding
;
4062 if (convbytes
<= buf
+ bufsize
- p
)
4064 /* Copy the formatted item from sprintf_buf into buf,
4065 inserting padding and excess-precision zeros. */
4067 char *src
= sprintf_buf
;
4069 int exponent_bytes
= 0;
4070 int signedp
= src0
== '-' || src0
== '+' || src0
== ' ';
4071 int significand_bytes
;
4073 && ((src
[signedp
] >= '0' && src
[signedp
] <= '9')
4074 || (src
[signedp
] >= 'a' && src
[signedp
] <= 'f')
4075 || (src
[signedp
] >= 'A' && src
[signedp
] <= 'F')))
4077 leading_zeros
+= padding
;
4081 if (excess_precision
4082 && (conversion
== 'e' || conversion
== 'g'))
4084 char *e
= strchr (src
, 'e');
4086 exponent_bytes
= src
+ sprintf_bytes
- e
;
4091 memset (p
, ' ', padding
);
4099 memset (p
, '0', leading_zeros
);
4101 significand_bytes
= sprintf_bytes
- signedp
- exponent_bytes
;
4102 memcpy (p
, src
, significand_bytes
);
4103 p
+= significand_bytes
;
4104 src
+= significand_bytes
;
4105 memset (p
, '0', trailing_zeros
);
4106 p
+= trailing_zeros
;
4107 memcpy (p
, src
, exponent_bytes
);
4108 p
+= exponent_bytes
;
4110 info
[n
].start
= nchars
;
4111 nchars
+= leading_zeros
+ sprintf_bytes
+ trailing_zeros
;
4112 info
[n
].end
= nchars
;
4116 memset (p
, ' ', padding
);
4128 /* Copy a single character from format to buf. */
4131 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
4133 if (multibyte_format
)
4135 /* Copy a whole multibyte character. */
4137 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
4138 && !CHAR_HEAD_P (*format
))
4139 maybe_combine_byte
= 1;
4143 while (! CHAR_HEAD_P (*format
));
4145 convbytes
= format
- src
;
4146 memset (&discarded
[src
+ 1 - format_start
], 2, convbytes
- 1);
4150 unsigned char uc
= *format
++;
4151 if (! multibyte
|| ASCII_BYTE_P (uc
))
4155 int c
= BYTE8_TO_CHAR (uc
);
4156 convbytes
= CHAR_STRING (c
, str
);
4161 if (convbytes
<= buf
+ bufsize
- p
)
4163 memcpy (p
, src
, convbytes
);
4170 /* There wasn't enough room to store this conversion or single
4171 character. CONVBYTES says how much room is needed. Allocate
4172 enough room (and then some) and do it again. */
4174 ptrdiff_t used
= p
- buf
;
4176 if (max_bufsize
- used
< convbytes
)
4178 bufsize
= used
+ convbytes
;
4179 bufsize
= bufsize
< max_bufsize
/ 2 ? bufsize
* 2 : max_bufsize
;
4181 if (buf
== initial_buffer
)
4183 buf
= xmalloc (bufsize
);
4185 buf_save_value
= make_save_value (buf
, 0);
4186 record_unwind_protect (safe_alloca_unwind
, buf_save_value
);
4187 memcpy (buf
, initial_buffer
, used
);
4190 XSAVE_VALUE (buf_save_value
)->pointer
= buf
= xrealloc (buf
, bufsize
);
4199 if (bufsize
< p
- buf
)
4202 if (maybe_combine_byte
)
4203 nchars
= multibyte_chars_in_text ((unsigned char *) buf
, p
- buf
);
4204 val
= make_specified_string (buf
, nchars
, p
- buf
, multibyte
);
4206 /* If we allocated BUF with malloc, free it too. */
4209 /* If the format string has text properties, or any of the string
4210 arguments has text properties, set up text properties of the
4213 if (STRING_INTERVALS (args
[0]) || arg_intervals
)
4215 Lisp_Object len
, new_len
, props
;
4216 struct gcpro gcpro1
;
4218 /* Add text properties from the format string. */
4219 len
= make_number (SCHARS (args
[0]));
4220 props
= text_property_list (args
[0], make_number (0), len
, Qnil
);
4225 EMACS_INT bytepos
= 0, position
= 0, translated
= 0;
4229 /* Adjust the bounds of each text property
4230 to the proper start and end in the output string. */
4232 /* Put the positions in PROPS in increasing order, so that
4233 we can do (effectively) one scan through the position
4234 space of the format string. */
4235 props
= Fnreverse (props
);
4237 /* BYTEPOS is the byte position in the format string,
4238 POSITION is the untranslated char position in it,
4239 TRANSLATED is the translated char position in BUF,
4240 and ARGN is the number of the next arg we will come to. */
4241 for (list
= props
; CONSP (list
); list
= XCDR (list
))
4248 /* First adjust the property start position. */
4249 pos
= XINT (XCAR (item
));
4251 /* Advance BYTEPOS, POSITION, TRANSLATED and ARGN
4252 up to this position. */
4253 for (; position
< pos
; bytepos
++)
4255 if (! discarded
[bytepos
])
4256 position
++, translated
++;
4257 else if (discarded
[bytepos
] == 1)
4260 if (translated
== info
[argn
].start
)
4262 translated
+= info
[argn
].end
- info
[argn
].start
;
4268 XSETCAR (item
, make_number (translated
));
4270 /* Likewise adjust the property end position. */
4271 pos
= XINT (XCAR (XCDR (item
)));
4273 for (; position
< pos
; bytepos
++)
4275 if (! discarded
[bytepos
])
4276 position
++, translated
++;
4277 else if (discarded
[bytepos
] == 1)
4280 if (translated
== info
[argn
].start
)
4282 translated
+= info
[argn
].end
- info
[argn
].start
;
4288 XSETCAR (XCDR (item
), make_number (translated
));
4291 add_text_properties_from_list (val
, props
, make_number (0));
4294 /* Add text properties from arguments. */
4296 for (n
= 1; n
< nargs
; ++n
)
4297 if (info
[n
].intervals
)
4299 len
= make_number (SCHARS (args
[n
]));
4300 new_len
= make_number (info
[n
].end
- info
[n
].start
);
4301 props
= text_property_list (args
[n
], make_number (0), len
, Qnil
);
4302 props
= extend_property_ranges (props
, new_len
);
4303 /* If successive arguments have properties, be sure that
4304 the value of `composition' property be the copy. */
4305 if (n
> 1 && info
[n
- 1].end
)
4306 make_composition_value_copy (props
);
4307 add_text_properties_from_list (val
, props
,
4308 make_number (info
[n
].start
));
4318 format2 (const char *string1
, Lisp_Object arg0
, Lisp_Object arg1
)
4320 Lisp_Object args
[3];
4321 args
[0] = build_string (string1
);
4324 return Fformat (3, args
);
4327 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
4328 doc
: /* Return t if two characters match, optionally ignoring case.
4329 Both arguments must be characters (i.e. integers).
4330 Case is ignored if `case-fold-search' is non-nil in the current buffer. */)
4331 (register Lisp_Object c1
, Lisp_Object c2
)
4334 /* Check they're chars, not just integers, otherwise we could get array
4335 bounds violations in downcase. */
4336 CHECK_CHARACTER (c1
);
4337 CHECK_CHARACTER (c2
);
4339 if (XINT (c1
) == XINT (c2
))
4341 if (NILP (BVAR (current_buffer
, case_fold_search
)))
4345 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
))
4346 && ! ASCII_CHAR_P (i1
))
4348 MAKE_CHAR_MULTIBYTE (i1
);
4351 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
))
4352 && ! ASCII_CHAR_P (i2
))
4354 MAKE_CHAR_MULTIBYTE (i2
);
4356 return (downcase (i1
) == downcase (i2
) ? Qt
: Qnil
);
4359 /* Transpose the markers in two regions of the current buffer, and
4360 adjust the ones between them if necessary (i.e.: if the regions
4363 START1, END1 are the character positions of the first region.
4364 START1_BYTE, END1_BYTE are the byte positions.
4365 START2, END2 are the character positions of the second region.
4366 START2_BYTE, END2_BYTE are the byte positions.
4368 Traverses the entire marker list of the buffer to do so, adding an
4369 appropriate amount to some, subtracting from some, and leaving the
4370 rest untouched. Most of this is copied from adjust_markers in insdel.c.
4372 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
4375 transpose_markers (EMACS_INT start1
, EMACS_INT end1
,
4376 EMACS_INT start2
, EMACS_INT end2
,
4377 EMACS_INT start1_byte
, EMACS_INT end1_byte
,
4378 EMACS_INT start2_byte
, EMACS_INT end2_byte
)
4380 register EMACS_INT amt1
, amt1_byte
, amt2
, amt2_byte
, diff
, diff_byte
, mpos
;
4381 register struct Lisp_Marker
*marker
;
4383 /* Update point as if it were a marker. */
4387 TEMP_SET_PT_BOTH (PT
+ (end2
- end1
),
4388 PT_BYTE
+ (end2_byte
- end1_byte
));
4389 else if (PT
< start2
)
4390 TEMP_SET_PT_BOTH (PT
+ (end2
- start2
) - (end1
- start1
),
4391 (PT_BYTE
+ (end2_byte
- start2_byte
)
4392 - (end1_byte
- start1_byte
)));
4394 TEMP_SET_PT_BOTH (PT
- (start2
- start1
),
4395 PT_BYTE
- (start2_byte
- start1_byte
));
4397 /* We used to adjust the endpoints here to account for the gap, but that
4398 isn't good enough. Even if we assume the caller has tried to move the
4399 gap out of our way, it might still be at start1 exactly, for example;
4400 and that places it `inside' the interval, for our purposes. The amount
4401 of adjustment is nontrivial if there's a `denormalized' marker whose
4402 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
4403 the dirty work to Fmarker_position, below. */
4405 /* The difference between the region's lengths */
4406 diff
= (end2
- start2
) - (end1
- start1
);
4407 diff_byte
= (end2_byte
- start2_byte
) - (end1_byte
- start1_byte
);
4409 /* For shifting each marker in a region by the length of the other
4410 region plus the distance between the regions. */
4411 amt1
= (end2
- start2
) + (start2
- end1
);
4412 amt2
= (end1
- start1
) + (start2
- end1
);
4413 amt1_byte
= (end2_byte
- start2_byte
) + (start2_byte
- end1_byte
);
4414 amt2_byte
= (end1_byte
- start1_byte
) + (start2_byte
- end1_byte
);
4416 for (marker
= BUF_MARKERS (current_buffer
); marker
; marker
= marker
->next
)
4418 mpos
= marker
->bytepos
;
4419 if (mpos
>= start1_byte
&& mpos
< end2_byte
)
4421 if (mpos
< end1_byte
)
4423 else if (mpos
< start2_byte
)
4427 marker
->bytepos
= mpos
;
4429 mpos
= marker
->charpos
;
4430 if (mpos
>= start1
&& mpos
< end2
)
4434 else if (mpos
< start2
)
4439 marker
->charpos
= mpos
;
4443 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
4444 doc
: /* Transpose region STARTR1 to ENDR1 with STARTR2 to ENDR2.
4445 The regions should not be overlapping, because the size of the buffer is
4446 never changed in a transposition.
4448 Optional fifth arg LEAVE-MARKERS, if non-nil, means don't update
4449 any markers that happen to be located in the regions.
4451 Transposing beyond buffer boundaries is an error. */)
4452 (Lisp_Object startr1
, Lisp_Object endr1
, Lisp_Object startr2
, Lisp_Object endr2
, Lisp_Object leave_markers
)
4454 register EMACS_INT start1
, end1
, start2
, end2
;
4455 EMACS_INT start1_byte
, start2_byte
, len1_byte
, len2_byte
;
4456 EMACS_INT gap
, len1
, len_mid
, len2
;
4457 unsigned char *start1_addr
, *start2_addr
, *temp
;
4459 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
, tmp_interval3
;
4462 XSETBUFFER (buf
, current_buffer
);
4463 cur_intv
= BUF_INTERVALS (current_buffer
);
4465 validate_region (&startr1
, &endr1
);
4466 validate_region (&startr2
, &endr2
);
4468 start1
= XFASTINT (startr1
);
4469 end1
= XFASTINT (endr1
);
4470 start2
= XFASTINT (startr2
);
4471 end2
= XFASTINT (endr2
);
4474 /* Swap the regions if they're reversed. */
4477 register EMACS_INT glumph
= start1
;
4485 len1
= end1
- start1
;
4486 len2
= end2
- start2
;
4489 error ("Transposed regions overlap");
4490 /* Nothing to change for adjacent regions with one being empty */
4491 else if ((start1
== end1
|| start2
== end2
) && end1
== start2
)
4494 /* The possibilities are:
4495 1. Adjacent (contiguous) regions, or separate but equal regions
4496 (no, really equal, in this case!), or
4497 2. Separate regions of unequal size.
4499 The worst case is usually No. 2. It means that (aside from
4500 potential need for getting the gap out of the way), there also
4501 needs to be a shifting of the text between the two regions. So
4502 if they are spread far apart, we are that much slower... sigh. */
4504 /* It must be pointed out that the really studly thing to do would
4505 be not to move the gap at all, but to leave it in place and work
4506 around it if necessary. This would be extremely efficient,
4507 especially considering that people are likely to do
4508 transpositions near where they are working interactively, which
4509 is exactly where the gap would be found. However, such code
4510 would be much harder to write and to read. So, if you are
4511 reading this comment and are feeling squirrely, by all means have
4512 a go! I just didn't feel like doing it, so I will simply move
4513 the gap the minimum distance to get it out of the way, and then
4514 deal with an unbroken array. */
4516 /* Make sure the gap won't interfere, by moving it out of the text
4517 we will operate on. */
4518 if (start1
< gap
&& gap
< end2
)
4520 if (gap
- start1
< end2
- gap
)
4526 start1_byte
= CHAR_TO_BYTE (start1
);
4527 start2_byte
= CHAR_TO_BYTE (start2
);
4528 len1_byte
= CHAR_TO_BYTE (end1
) - start1_byte
;
4529 len2_byte
= CHAR_TO_BYTE (end2
) - start2_byte
;
4531 #ifdef BYTE_COMBINING_DEBUG
4534 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4535 len2_byte
, start1
, start1_byte
)
4536 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4537 len1_byte
, end2
, start2_byte
+ len2_byte
)
4538 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4539 len1_byte
, end2
, start2_byte
+ len2_byte
))
4544 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4545 len2_byte
, start1
, start1_byte
)
4546 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4547 len1_byte
, start2
, start2_byte
)
4548 || count_combining_after (BYTE_POS_ADDR (start2_byte
),
4549 len2_byte
, end1
, start1_byte
+ len1_byte
)
4550 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4551 len1_byte
, end2
, start2_byte
+ len2_byte
))
4556 /* Hmmm... how about checking to see if the gap is large
4557 enough to use as the temporary storage? That would avoid an
4558 allocation... interesting. Later, don't fool with it now. */
4560 /* Working without memmove, for portability (sigh), so must be
4561 careful of overlapping subsections of the array... */
4563 if (end1
== start2
) /* adjacent regions */
4565 modify_region (current_buffer
, start1
, end2
, 0);
4566 record_change (start1
, len1
+ len2
);
4568 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4569 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4570 /* Don't use Fset_text_properties: that can cause GC, which can
4571 clobber objects stored in the tmp_intervals. */
4572 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4573 if (!NULL_INTERVAL_P (tmp_interval3
))
4574 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4576 /* First region smaller than second. */
4577 if (len1_byte
< len2_byte
)
4581 SAFE_ALLOCA (temp
, unsigned char *, len2_byte
);
4583 /* Don't precompute these addresses. We have to compute them
4584 at the last minute, because the relocating allocator might
4585 have moved the buffer around during the xmalloc. */
4586 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4587 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4589 memcpy (temp
, start2_addr
, len2_byte
);
4590 memcpy (start1_addr
+ len2_byte
, start1_addr
, len1_byte
);
4591 memcpy (start1_addr
, temp
, len2_byte
);
4595 /* First region not smaller than second. */
4599 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4600 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4601 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4602 memcpy (temp
, start1_addr
, len1_byte
);
4603 memcpy (start1_addr
, start2_addr
, len2_byte
);
4604 memcpy (start1_addr
+ len2_byte
, temp
, len1_byte
);
4607 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
4608 len1
, current_buffer
, 0);
4609 graft_intervals_into_buffer (tmp_interval2
, start1
,
4610 len2
, current_buffer
, 0);
4611 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4612 update_compositions (start1
+ len2
, end2
, CHECK_TAIL
);
4614 /* Non-adjacent regions, because end1 != start2, bleagh... */
4617 len_mid
= start2_byte
- (start1_byte
+ len1_byte
);
4619 if (len1_byte
== len2_byte
)
4620 /* Regions are same size, though, how nice. */
4624 modify_region (current_buffer
, start1
, end1
, 0);
4625 modify_region (current_buffer
, start2
, end2
, 0);
4626 record_change (start1
, len1
);
4627 record_change (start2
, len2
);
4628 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4629 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4631 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr1
, 0);
4632 if (!NULL_INTERVAL_P (tmp_interval3
))
4633 set_text_properties_1 (startr1
, endr1
, Qnil
, buf
, tmp_interval3
);
4635 tmp_interval3
= validate_interval_range (buf
, &startr2
, &endr2
, 0);
4636 if (!NULL_INTERVAL_P (tmp_interval3
))
4637 set_text_properties_1 (startr2
, endr2
, Qnil
, buf
, tmp_interval3
);
4639 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4640 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4641 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4642 memcpy (temp
, start1_addr
, len1_byte
);
4643 memcpy (start1_addr
, start2_addr
, len2_byte
);
4644 memcpy (start2_addr
, temp
, len1_byte
);
4647 graft_intervals_into_buffer (tmp_interval1
, start2
,
4648 len1
, current_buffer
, 0);
4649 graft_intervals_into_buffer (tmp_interval2
, start1
,
4650 len2
, current_buffer
, 0);
4653 else if (len1_byte
< len2_byte
) /* Second region larger than first */
4654 /* Non-adjacent & unequal size, area between must also be shifted. */
4658 modify_region (current_buffer
, start1
, end2
, 0);
4659 record_change (start1
, (end2
- start1
));
4660 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4661 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4662 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4664 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4665 if (!NULL_INTERVAL_P (tmp_interval3
))
4666 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4668 /* holds region 2 */
4669 SAFE_ALLOCA (temp
, unsigned char *, len2_byte
);
4670 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4671 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4672 memcpy (temp
, start2_addr
, len2_byte
);
4673 memcpy (start1_addr
+ len_mid
+ len2_byte
, start1_addr
, len1_byte
);
4674 memmove (start1_addr
+ len2_byte
, start1_addr
+ len1_byte
, len_mid
);
4675 memcpy (start1_addr
, temp
, len2_byte
);
4678 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4679 len1
, current_buffer
, 0);
4680 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4681 len_mid
, current_buffer
, 0);
4682 graft_intervals_into_buffer (tmp_interval2
, start1
,
4683 len2
, current_buffer
, 0);
4686 /* Second region smaller than first. */
4690 record_change (start1
, (end2
- start1
));
4691 modify_region (current_buffer
, start1
, end2
, 0);
4693 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4694 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4695 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4697 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4698 if (!NULL_INTERVAL_P (tmp_interval3
))
4699 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4701 /* holds region 1 */
4702 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4703 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4704 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4705 memcpy (temp
, start1_addr
, len1_byte
);
4706 memcpy (start1_addr
, start2_addr
, len2_byte
);
4707 memcpy (start1_addr
+ len2_byte
, start1_addr
+ len1_byte
, len_mid
);
4708 memcpy (start1_addr
+ len2_byte
+ len_mid
, temp
, len1_byte
);
4711 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4712 len1
, current_buffer
, 0);
4713 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4714 len_mid
, current_buffer
, 0);
4715 graft_intervals_into_buffer (tmp_interval2
, start1
,
4716 len2
, current_buffer
, 0);
4719 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4720 update_compositions (end2
- len1
, end2
, CHECK_BORDER
);
4723 /* When doing multiple transpositions, it might be nice
4724 to optimize this. Perhaps the markers in any one buffer
4725 should be organized in some sorted data tree. */
4726 if (NILP (leave_markers
))
4728 transpose_markers (start1
, end1
, start2
, end2
,
4729 start1_byte
, start1_byte
+ len1_byte
,
4730 start2_byte
, start2_byte
+ len2_byte
);
4731 fix_start_end_in_overlays (start1
, end2
);
4734 signal_after_change (start1
, end2
- start1
, end2
- start1
);
4740 syms_of_editfns (void)
4745 DEFSYM (Qbuffer_access_fontify_functions
, "buffer-access-fontify-functions");
4747 DEFVAR_LISP ("inhibit-field-text-motion", Vinhibit_field_text_motion
,
4748 doc
: /* Non-nil means text motion commands don't notice fields. */);
4749 Vinhibit_field_text_motion
= Qnil
;
4751 DEFVAR_LISP ("buffer-access-fontify-functions",
4752 Vbuffer_access_fontify_functions
,
4753 doc
: /* List of functions called by `buffer-substring' to fontify if necessary.
4754 Each function is called with two arguments which specify the range
4755 of the buffer being accessed. */);
4756 Vbuffer_access_fontify_functions
= Qnil
;
4760 obuf
= Fcurrent_buffer ();
4761 /* Do this here, because init_buffer_once is too early--it won't work. */
4762 Fset_buffer (Vprin1_to_string_buffer
);
4763 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
4764 Fset (Fmake_local_variable (intern_c_string ("buffer-access-fontify-functions")),
4769 DEFVAR_LISP ("buffer-access-fontified-property",
4770 Vbuffer_access_fontified_property
,
4771 doc
: /* Property which (if non-nil) indicates text has been fontified.
4772 `buffer-substring' need not call the `buffer-access-fontify-functions'
4773 functions if all the text being accessed has this property. */);
4774 Vbuffer_access_fontified_property
= Qnil
;
4776 DEFVAR_LISP ("system-name", Vsystem_name
,
4777 doc
: /* The host name of the machine Emacs is running on. */);
4779 DEFVAR_LISP ("user-full-name", Vuser_full_name
,
4780 doc
: /* The full name of the user logged in. */);
4782 DEFVAR_LISP ("user-login-name", Vuser_login_name
,
4783 doc
: /* The user's name, taken from environment variables if possible. */);
4785 DEFVAR_LISP ("user-real-login-name", Vuser_real_login_name
,
4786 doc
: /* The user's name, based upon the real uid only. */);
4788 DEFVAR_LISP ("operating-system-release", Voperating_system_release
,
4789 doc
: /* The release of the operating system Emacs is running on. */);
4791 defsubr (&Spropertize
);
4792 defsubr (&Schar_equal
);
4793 defsubr (&Sgoto_char
);
4794 defsubr (&Sstring_to_char
);
4795 defsubr (&Schar_to_string
);
4796 defsubr (&Sbyte_to_string
);
4797 defsubr (&Sbuffer_substring
);
4798 defsubr (&Sbuffer_substring_no_properties
);
4799 defsubr (&Sbuffer_string
);
4801 defsubr (&Spoint_marker
);
4802 defsubr (&Smark_marker
);
4804 defsubr (&Sregion_beginning
);
4805 defsubr (&Sregion_end
);
4807 DEFSYM (Qfield
, "field");
4808 DEFSYM (Qboundary
, "boundary");
4809 defsubr (&Sfield_beginning
);
4810 defsubr (&Sfield_end
);
4811 defsubr (&Sfield_string
);
4812 defsubr (&Sfield_string_no_properties
);
4813 defsubr (&Sdelete_field
);
4814 defsubr (&Sconstrain_to_field
);
4816 defsubr (&Sline_beginning_position
);
4817 defsubr (&Sline_end_position
);
4819 /* defsubr (&Smark); */
4820 /* defsubr (&Sset_mark); */
4821 defsubr (&Ssave_excursion
);
4822 defsubr (&Ssave_current_buffer
);
4824 defsubr (&Sbufsize
);
4825 defsubr (&Spoint_max
);
4826 defsubr (&Spoint_min
);
4827 defsubr (&Spoint_min_marker
);
4828 defsubr (&Spoint_max_marker
);
4829 defsubr (&Sgap_position
);
4830 defsubr (&Sgap_size
);
4831 defsubr (&Sposition_bytes
);
4832 defsubr (&Sbyte_to_position
);
4838 defsubr (&Sfollowing_char
);
4839 defsubr (&Sprevious_char
);
4840 defsubr (&Schar_after
);
4841 defsubr (&Schar_before
);
4843 defsubr (&Sinsert_before_markers
);
4844 defsubr (&Sinsert_and_inherit
);
4845 defsubr (&Sinsert_and_inherit_before_markers
);
4846 defsubr (&Sinsert_char
);
4847 defsubr (&Sinsert_byte
);
4849 defsubr (&Suser_login_name
);
4850 defsubr (&Suser_real_login_name
);
4851 defsubr (&Suser_uid
);
4852 defsubr (&Suser_real_uid
);
4853 defsubr (&Suser_full_name
);
4854 defsubr (&Semacs_pid
);
4855 defsubr (&Scurrent_time
);
4856 defsubr (&Sget_internal_run_time
);
4857 defsubr (&Sformat_time_string
);
4858 defsubr (&Sfloat_time
);
4859 defsubr (&Sdecode_time
);
4860 defsubr (&Sencode_time
);
4861 defsubr (&Scurrent_time_string
);
4862 defsubr (&Scurrent_time_zone
);
4863 defsubr (&Sset_time_zone_rule
);
4864 defsubr (&Ssystem_name
);
4865 defsubr (&Smessage
);
4866 defsubr (&Smessage_box
);
4867 defsubr (&Smessage_or_box
);
4868 defsubr (&Scurrent_message
);
4871 defsubr (&Sinsert_buffer_substring
);
4872 defsubr (&Scompare_buffer_substrings
);
4873 defsubr (&Ssubst_char_in_region
);
4874 defsubr (&Stranslate_region_internal
);
4875 defsubr (&Sdelete_region
);
4876 defsubr (&Sdelete_and_extract_region
);
4878 defsubr (&Snarrow_to_region
);
4879 defsubr (&Ssave_restriction
);
4880 defsubr (&Stranspose_regions
);