1 /* Lisp functions pertaining to editing.
3 Copyright (C) 1985-1987, 1989, 1993-2011 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software: you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation, either version 3 of the License, or
10 (at your option) any later version.
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
22 #include <sys/types.h>
32 #ifdef HAVE_SYS_UTSNAME_H
33 #include <sys/utsname.h>
38 /* systime.h includes <sys/time.h> which, on some systems, is required
39 for <sys/resource.h>; thus systime.h must be included before
43 #if defined HAVE_SYS_RESOURCE_H
44 #include <sys/resource.h>
54 #include "intervals.h"
56 #include "character.h"
60 #include "blockinput.h"
66 #ifndef USER_FULL_NAME
67 #define USER_FULL_NAME pw->pw_gecos
71 extern char **environ
;
74 #define TM_YEAR_BASE 1900
76 /* Nonzero if TM_YEAR is a struct tm's tm_year value that causes
77 asctime to have well-defined behavior. */
78 #ifndef TM_YEAR_IN_ASCTIME_RANGE
79 # define TM_YEAR_IN_ASCTIME_RANGE(tm_year) \
80 (1000 - TM_YEAR_BASE <= (tm_year) && (tm_year) <= 9999 - TM_YEAR_BASE)
84 extern Lisp_Object
w32_get_internal_run_time (void);
87 static void time_overflow (void) NO_RETURN
;
88 static int tm_diff (struct tm
*, struct tm
*);
89 static void update_buffer_properties (EMACS_INT
, EMACS_INT
);
91 static Lisp_Object Qbuffer_access_fontify_functions
;
92 static Lisp_Object
Fuser_full_name (Lisp_Object
);
94 /* Symbol for the text property used to mark fields. */
98 /* A special value for Qfield properties. */
100 static Lisp_Object Qboundary
;
106 const char *user_name
;
108 struct passwd
*pw
; /* password entry for the current user */
111 /* Set up system_name even when dumping. */
115 /* Don't bother with this on initial start when just dumping out */
118 #endif /* not CANNOT_DUMP */
120 pw
= getpwuid (getuid ());
122 /* We let the real user name default to "root" because that's quite
123 accurate on MSDOG and because it lets Emacs find the init file.
124 (The DVX libraries override the Djgpp libraries here.) */
125 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "root");
127 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "unknown");
130 /* Get the effective user name, by consulting environment variables,
131 or the effective uid if those are unset. */
132 user_name
= getenv ("LOGNAME");
135 user_name
= getenv ("USERNAME"); /* it's USERNAME on NT */
136 #else /* WINDOWSNT */
137 user_name
= getenv ("USER");
138 #endif /* WINDOWSNT */
141 pw
= getpwuid (geteuid ());
142 user_name
= pw
? pw
->pw_name
: "unknown";
144 Vuser_login_name
= build_string (user_name
);
146 /* If the user name claimed in the environment vars differs from
147 the real uid, use the claimed name to find the full name. */
148 tem
= Fstring_equal (Vuser_login_name
, Vuser_real_login_name
);
149 Vuser_full_name
= Fuser_full_name (NILP (tem
)? make_number (geteuid ())
154 Vuser_full_name
= build_string (p
);
155 else if (NILP (Vuser_full_name
))
156 Vuser_full_name
= build_string ("unknown");
158 #ifdef HAVE_SYS_UTSNAME_H
162 Voperating_system_release
= build_string (uts
.release
);
165 Voperating_system_release
= Qnil
;
169 DEFUN ("char-to-string", Fchar_to_string
, Schar_to_string
, 1, 1, 0,
170 doc
: /* Convert arg CHAR to a string containing that character.
171 usage: (char-to-string CHAR) */)
172 (Lisp_Object character
)
175 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
177 CHECK_CHARACTER (character
);
178 c
= XFASTINT (character
);
180 len
= CHAR_STRING (c
, str
);
181 return make_string_from_bytes ((char *) str
, 1, len
);
184 DEFUN ("byte-to-string", Fbyte_to_string
, Sbyte_to_string
, 1, 1, 0,
185 doc
: /* Convert arg BYTE to a unibyte string containing that byte. */)
190 if (XINT (byte
) < 0 || XINT (byte
) > 255)
191 error ("Invalid byte");
193 return make_string_from_bytes ((char *) &b
, 1, 1);
196 DEFUN ("string-to-char", Fstring_to_char
, Sstring_to_char
, 1, 1, 0,
197 doc
: /* Return the first character in STRING. */)
198 (register Lisp_Object string
)
200 register Lisp_Object val
;
201 CHECK_STRING (string
);
204 if (STRING_MULTIBYTE (string
))
205 XSETFASTINT (val
, STRING_CHAR (SDATA (string
)));
207 XSETFASTINT (val
, SREF (string
, 0));
210 XSETFASTINT (val
, 0);
215 buildmark (EMACS_INT charpos
, EMACS_INT bytepos
)
217 register Lisp_Object mark
;
218 mark
= Fmake_marker ();
219 set_marker_both (mark
, Qnil
, charpos
, bytepos
);
223 DEFUN ("point", Fpoint
, Spoint
, 0, 0, 0,
224 doc
: /* Return value of point, as an integer.
225 Beginning of buffer is position (point-min). */)
229 XSETFASTINT (temp
, PT
);
233 DEFUN ("point-marker", Fpoint_marker
, Spoint_marker
, 0, 0, 0,
234 doc
: /* Return value of point, as a marker object. */)
237 return buildmark (PT
, PT_BYTE
);
241 clip_to_bounds (EMACS_INT lower
, EMACS_INT num
, EMACS_INT upper
)
245 else if (num
> upper
)
251 DEFUN ("goto-char", Fgoto_char
, Sgoto_char
, 1, 1, "NGoto char: ",
252 doc
: /* Set point to POSITION, a number or marker.
253 Beginning of buffer is position (point-min), end is (point-max).
255 The return value is POSITION. */)
256 (register Lisp_Object position
)
260 if (MARKERP (position
)
261 && current_buffer
== XMARKER (position
)->buffer
)
263 pos
= marker_position (position
);
265 SET_PT_BOTH (BEGV
, BEGV_BYTE
);
267 SET_PT_BOTH (ZV
, ZV_BYTE
);
269 SET_PT_BOTH (pos
, marker_byte_position (position
));
274 CHECK_NUMBER_COERCE_MARKER (position
);
276 pos
= clip_to_bounds (BEGV
, XINT (position
), ZV
);
282 /* Return the start or end position of the region.
283 BEGINNINGP non-zero means return the start.
284 If there is no region active, signal an error. */
287 region_limit (int beginningp
)
291 if (!NILP (Vtransient_mark_mode
)
292 && NILP (Vmark_even_if_inactive
)
293 && NILP (BVAR (current_buffer
, mark_active
)))
294 xsignal0 (Qmark_inactive
);
296 m
= Fmarker_position (BVAR (current_buffer
, mark
));
298 error ("The mark is not set now, so there is no region");
300 if ((PT
< XFASTINT (m
)) == (beginningp
!= 0))
301 m
= make_number (PT
);
305 DEFUN ("region-beginning", Fregion_beginning
, Sregion_beginning
, 0, 0, 0,
306 doc
: /* Return the integer value of point or mark, whichever is smaller. */)
309 return region_limit (1);
312 DEFUN ("region-end", Fregion_end
, Sregion_end
, 0, 0, 0,
313 doc
: /* Return the integer value of point or mark, whichever is larger. */)
316 return region_limit (0);
319 DEFUN ("mark-marker", Fmark_marker
, Smark_marker
, 0, 0, 0,
320 doc
: /* Return this buffer's mark, as a marker object.
321 Watch out! Moving this marker changes the mark position.
322 If you set the marker not to point anywhere, the buffer will have no mark. */)
325 return BVAR (current_buffer
, mark
);
329 /* Find all the overlays in the current buffer that touch position POS.
330 Return the number found, and store them in a vector in VEC
334 overlays_around (EMACS_INT pos
, Lisp_Object
*vec
, ptrdiff_t len
)
336 Lisp_Object overlay
, start
, end
;
337 struct Lisp_Overlay
*tail
;
338 EMACS_INT startpos
, endpos
;
341 for (tail
= current_buffer
->overlays_before
; tail
; tail
= tail
->next
)
343 XSETMISC (overlay
, tail
);
345 end
= OVERLAY_END (overlay
);
346 endpos
= OVERLAY_POSITION (end
);
349 start
= OVERLAY_START (overlay
);
350 startpos
= OVERLAY_POSITION (start
);
355 /* Keep counting overlays even if we can't return them all. */
360 for (tail
= current_buffer
->overlays_after
; tail
; tail
= tail
->next
)
362 XSETMISC (overlay
, tail
);
364 start
= OVERLAY_START (overlay
);
365 startpos
= OVERLAY_POSITION (start
);
368 end
= OVERLAY_END (overlay
);
369 endpos
= OVERLAY_POSITION (end
);
381 /* Return the value of property PROP, in OBJECT at POSITION.
382 It's the value of PROP that a char inserted at POSITION would get.
383 OBJECT is optional and defaults to the current buffer.
384 If OBJECT is a buffer, then overlay properties are considered as well as
386 If OBJECT is a window, then that window's buffer is used, but
387 window-specific overlays are considered only if they are associated
390 get_pos_property (Lisp_Object position
, register Lisp_Object prop
, Lisp_Object object
)
392 CHECK_NUMBER_COERCE_MARKER (position
);
395 XSETBUFFER (object
, current_buffer
);
396 else if (WINDOWP (object
))
397 object
= XWINDOW (object
)->buffer
;
399 if (!BUFFERP (object
))
400 /* pos-property only makes sense in buffers right now, since strings
401 have no overlays and no notion of insertion for which stickiness
403 return Fget_text_property (position
, prop
, object
);
406 EMACS_INT posn
= XINT (position
);
408 Lisp_Object
*overlay_vec
, tem
;
409 struct buffer
*obuf
= current_buffer
;
411 set_buffer_temp (XBUFFER (object
));
413 /* First try with room for 40 overlays. */
415 overlay_vec
= (Lisp_Object
*) alloca (noverlays
* sizeof (Lisp_Object
));
416 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
418 /* If there are more than 40,
419 make enough space for all, and try again. */
422 overlay_vec
= (Lisp_Object
*) alloca (noverlays
* sizeof (Lisp_Object
));
423 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
425 noverlays
= sort_overlays (overlay_vec
, noverlays
, NULL
);
427 set_buffer_temp (obuf
);
429 /* Now check the overlays in order of decreasing priority. */
430 while (--noverlays
>= 0)
432 Lisp_Object ol
= overlay_vec
[noverlays
];
433 tem
= Foverlay_get (ol
, prop
);
436 /* Check the overlay is indeed active at point. */
437 Lisp_Object start
= OVERLAY_START (ol
), finish
= OVERLAY_END (ol
);
438 if ((OVERLAY_POSITION (start
) == posn
439 && XMARKER (start
)->insertion_type
== 1)
440 || (OVERLAY_POSITION (finish
) == posn
441 && XMARKER (finish
)->insertion_type
== 0))
442 ; /* The overlay will not cover a char inserted at point. */
450 { /* Now check the text properties. */
451 int stickiness
= text_property_stickiness (prop
, position
, object
);
453 return Fget_text_property (position
, prop
, object
);
454 else if (stickiness
< 0
455 && XINT (position
) > BUF_BEGV (XBUFFER (object
)))
456 return Fget_text_property (make_number (XINT (position
) - 1),
464 /* Find the field surrounding POS in *BEG and *END. If POS is nil,
465 the value of point is used instead. If BEG or END is null,
466 means don't store the beginning or end of the field.
468 BEG_LIMIT and END_LIMIT serve to limit the ranged of the returned
469 results; they do not effect boundary behavior.
471 If MERGE_AT_BOUNDARY is nonzero, then if POS is at the very first
472 position of a field, then the beginning of the previous field is
473 returned instead of the beginning of POS's field (since the end of a
474 field is actually also the beginning of the next input field, this
475 behavior is sometimes useful). Additionally in the MERGE_AT_BOUNDARY
476 true case, if two fields are separated by a field with the special
477 value `boundary', and POS lies within it, then the two separated
478 fields are considered to be adjacent, and POS between them, when
479 finding the beginning and ending of the "merged" field.
481 Either BEG or END may be 0, in which case the corresponding value
485 find_field (Lisp_Object pos
, Lisp_Object merge_at_boundary
,
486 Lisp_Object beg_limit
,
487 EMACS_INT
*beg
, Lisp_Object end_limit
, EMACS_INT
*end
)
489 /* Fields right before and after the point. */
490 Lisp_Object before_field
, after_field
;
491 /* 1 if POS counts as the start of a field. */
492 int at_field_start
= 0;
493 /* 1 if POS counts as the end of a field. */
494 int at_field_end
= 0;
497 XSETFASTINT (pos
, PT
);
499 CHECK_NUMBER_COERCE_MARKER (pos
);
502 = get_char_property_and_overlay (pos
, Qfield
, Qnil
, NULL
);
504 = (XFASTINT (pos
) > BEGV
505 ? get_char_property_and_overlay (make_number (XINT (pos
) - 1),
507 /* Using nil here would be a more obvious choice, but it would
508 fail when the buffer starts with a non-sticky field. */
511 /* See if we need to handle the case where MERGE_AT_BOUNDARY is nil
512 and POS is at beginning of a field, which can also be interpreted
513 as the end of the previous field. Note that the case where if
514 MERGE_AT_BOUNDARY is non-nil (see function comment) is actually the
515 more natural one; then we avoid treating the beginning of a field
517 if (NILP (merge_at_boundary
))
519 Lisp_Object field
= get_pos_property (pos
, Qfield
, Qnil
);
520 if (!EQ (field
, after_field
))
522 if (!EQ (field
, before_field
))
524 if (NILP (field
) && at_field_start
&& at_field_end
)
525 /* If an inserted char would have a nil field while the surrounding
526 text is non-nil, we're probably not looking at a
527 zero-length field, but instead at a non-nil field that's
528 not intended for editing (such as comint's prompts). */
529 at_field_end
= at_field_start
= 0;
532 /* Note about special `boundary' fields:
534 Consider the case where the point (`.') is between the fields `x' and `y':
538 In this situation, if merge_at_boundary is true, we consider the
539 `x' and `y' fields as forming one big merged field, and so the end
540 of the field is the end of `y'.
542 However, if `x' and `y' are separated by a special `boundary' field
543 (a field with a `field' char-property of 'boundary), then we ignore
544 this special field when merging adjacent fields. Here's the same
545 situation, but with a `boundary' field between the `x' and `y' fields:
549 Here, if point is at the end of `x', the beginning of `y', or
550 anywhere in-between (within the `boundary' field), we merge all
551 three fields and consider the beginning as being the beginning of
552 the `x' field, and the end as being the end of the `y' field. */
557 /* POS is at the edge of a field, and we should consider it as
558 the beginning of the following field. */
559 *beg
= XFASTINT (pos
);
561 /* Find the previous field boundary. */
564 if (!NILP (merge_at_boundary
) && EQ (before_field
, Qboundary
))
565 /* Skip a `boundary' field. */
566 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
569 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
571 *beg
= NILP (p
) ? BEGV
: XFASTINT (p
);
578 /* POS is at the edge of a field, and we should consider it as
579 the end of the previous field. */
580 *end
= XFASTINT (pos
);
582 /* Find the next field boundary. */
584 if (!NILP (merge_at_boundary
) && EQ (after_field
, Qboundary
))
585 /* Skip a `boundary' field. */
586 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
589 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
591 *end
= NILP (pos
) ? ZV
: XFASTINT (pos
);
597 DEFUN ("delete-field", Fdelete_field
, Sdelete_field
, 0, 1, 0,
598 doc
: /* Delete the field surrounding POS.
599 A field is a region of text with the same `field' property.
600 If POS is nil, the value of point is used for POS. */)
604 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
606 del_range (beg
, end
);
610 DEFUN ("field-string", Ffield_string
, Sfield_string
, 0, 1, 0,
611 doc
: /* Return the contents of the field surrounding POS as a string.
612 A field is a region of text with the same `field' property.
613 If POS is nil, the value of point is used for POS. */)
617 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
618 return make_buffer_string (beg
, end
, 1);
621 DEFUN ("field-string-no-properties", Ffield_string_no_properties
, Sfield_string_no_properties
, 0, 1, 0,
622 doc
: /* Return the contents of the field around POS, without text properties.
623 A field is a region of text with the same `field' property.
624 If POS is nil, the value of point is used for POS. */)
628 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
629 return make_buffer_string (beg
, end
, 0);
632 DEFUN ("field-beginning", Ffield_beginning
, Sfield_beginning
, 0, 3, 0,
633 doc
: /* Return the beginning of the field surrounding POS.
634 A field is a region of text with the same `field' property.
635 If POS is nil, the value of point is used for POS.
636 If ESCAPE-FROM-EDGE is non-nil and POS is at the beginning of its
637 field, then the beginning of the *previous* field is returned.
638 If LIMIT is non-nil, it is a buffer position; if the beginning of the field
639 is before LIMIT, then LIMIT will be returned instead. */)
640 (Lisp_Object pos
, Lisp_Object escape_from_edge
, Lisp_Object limit
)
643 find_field (pos
, escape_from_edge
, limit
, &beg
, Qnil
, 0);
644 return make_number (beg
);
647 DEFUN ("field-end", Ffield_end
, Sfield_end
, 0, 3, 0,
648 doc
: /* Return the end of the field surrounding POS.
649 A field is a region of text with the same `field' property.
650 If POS is nil, the value of point is used for POS.
651 If ESCAPE-FROM-EDGE is non-nil and POS is at the end of its field,
652 then the end of the *following* field is returned.
653 If LIMIT is non-nil, it is a buffer position; if the end of the field
654 is after LIMIT, then LIMIT will be returned instead. */)
655 (Lisp_Object pos
, Lisp_Object escape_from_edge
, Lisp_Object limit
)
658 find_field (pos
, escape_from_edge
, Qnil
, 0, limit
, &end
);
659 return make_number (end
);
662 DEFUN ("constrain-to-field", Fconstrain_to_field
, Sconstrain_to_field
, 2, 5, 0,
663 doc
: /* Return the position closest to NEW-POS that is in the same field as OLD-POS.
665 A field is a region of text with the same `field' property.
666 If NEW-POS is nil, then the current point is used instead, and set to the
667 constrained position if that is different.
669 If OLD-POS is at the boundary of two fields, then the allowable
670 positions for NEW-POS depends on the value of the optional argument
671 ESCAPE-FROM-EDGE: If ESCAPE-FROM-EDGE is nil, then NEW-POS is
672 constrained to the field that has the same `field' char-property
673 as any new characters inserted at OLD-POS, whereas if ESCAPE-FROM-EDGE
674 is non-nil, NEW-POS is constrained to the union of the two adjacent
675 fields. Additionally, if two fields are separated by another field with
676 the special value `boundary', then any point within this special field is
677 also considered to be `on the boundary'.
679 If the optional argument ONLY-IN-LINE is non-nil and constraining
680 NEW-POS would move it to a different line, NEW-POS is returned
681 unconstrained. This useful for commands that move by line, like
682 \\[next-line] or \\[beginning-of-line], which should generally respect field boundaries
683 only in the case where they can still move to the right line.
685 If the optional argument INHIBIT-CAPTURE-PROPERTY is non-nil, and OLD-POS has
686 a non-nil property of that name, then any field boundaries are ignored.
688 Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */)
689 (Lisp_Object new_pos
, Lisp_Object old_pos
, Lisp_Object escape_from_edge
, Lisp_Object only_in_line
, Lisp_Object inhibit_capture_property
)
691 /* If non-zero, then the original point, before re-positioning. */
692 EMACS_INT orig_point
= 0;
694 Lisp_Object prev_old
, prev_new
;
697 /* Use the current point, and afterwards, set it. */
700 XSETFASTINT (new_pos
, PT
);
703 CHECK_NUMBER_COERCE_MARKER (new_pos
);
704 CHECK_NUMBER_COERCE_MARKER (old_pos
);
706 fwd
= (XFASTINT (new_pos
) > XFASTINT (old_pos
));
708 prev_old
= make_number (XFASTINT (old_pos
) - 1);
709 prev_new
= make_number (XFASTINT (new_pos
) - 1);
711 if (NILP (Vinhibit_field_text_motion
)
712 && !EQ (new_pos
, old_pos
)
713 && (!NILP (Fget_char_property (new_pos
, Qfield
, Qnil
))
714 || !NILP (Fget_char_property (old_pos
, Qfield
, Qnil
))
715 /* To recognize field boundaries, we must also look at the
716 previous positions; we could use `get_pos_property'
717 instead, but in itself that would fail inside non-sticky
718 fields (like comint prompts). */
719 || (XFASTINT (new_pos
) > BEGV
720 && !NILP (Fget_char_property (prev_new
, Qfield
, Qnil
)))
721 || (XFASTINT (old_pos
) > BEGV
722 && !NILP (Fget_char_property (prev_old
, Qfield
, Qnil
))))
723 && (NILP (inhibit_capture_property
)
724 /* Field boundaries are again a problem; but now we must
725 decide the case exactly, so we need to call
726 `get_pos_property' as well. */
727 || (NILP (get_pos_property (old_pos
, inhibit_capture_property
, Qnil
))
728 && (XFASTINT (old_pos
) <= BEGV
729 || NILP (Fget_char_property (old_pos
, inhibit_capture_property
, Qnil
))
730 || NILP (Fget_char_property (prev_old
, inhibit_capture_property
, Qnil
))))))
731 /* It is possible that NEW_POS is not within the same field as
732 OLD_POS; try to move NEW_POS so that it is. */
735 Lisp_Object field_bound
;
738 field_bound
= Ffield_end (old_pos
, escape_from_edge
, new_pos
);
740 field_bound
= Ffield_beginning (old_pos
, escape_from_edge
, new_pos
);
742 if (/* See if ESCAPE_FROM_EDGE caused FIELD_BOUND to jump to the
743 other side of NEW_POS, which would mean that NEW_POS is
744 already acceptable, and it's not necessary to constrain it
746 ((XFASTINT (field_bound
) < XFASTINT (new_pos
)) ? fwd
: !fwd
)
747 /* NEW_POS should be constrained, but only if either
748 ONLY_IN_LINE is nil (in which case any constraint is OK),
749 or NEW_POS and FIELD_BOUND are on the same line (in which
750 case the constraint is OK even if ONLY_IN_LINE is non-nil). */
751 && (NILP (only_in_line
)
752 /* This is the ONLY_IN_LINE case, check that NEW_POS and
753 FIELD_BOUND are on the same line by seeing whether
754 there's an intervening newline or not. */
755 || (scan_buffer ('\n',
756 XFASTINT (new_pos
), XFASTINT (field_bound
),
757 fwd
? -1 : 1, &shortage
, 1),
759 /* Constrain NEW_POS to FIELD_BOUND. */
760 new_pos
= field_bound
;
762 if (orig_point
&& XFASTINT (new_pos
) != orig_point
)
763 /* The NEW_POS argument was originally nil, so automatically set PT. */
764 SET_PT (XFASTINT (new_pos
));
771 DEFUN ("line-beginning-position",
772 Fline_beginning_position
, Sline_beginning_position
, 0, 1, 0,
773 doc
: /* Return the character position of the first character on the current line.
774 With argument N not nil or 1, move forward N - 1 lines first.
775 If scan reaches end of buffer, return that position.
777 The returned position is of the first character in the logical order,
778 i.e. the one that has the smallest character position.
780 This function constrains the returned position to the current field
781 unless that would be on a different line than the original,
782 unconstrained result. If N is nil or 1, and a front-sticky field
783 starts at point, the scan stops as soon as it starts. To ignore field
784 boundaries bind `inhibit-field-text-motion' to t.
786 This function does not move point. */)
789 EMACS_INT orig
, orig_byte
, end
;
790 int count
= SPECPDL_INDEX ();
791 specbind (Qinhibit_point_motion_hooks
, Qt
);
800 Fforward_line (make_number (XINT (n
) - 1));
803 SET_PT_BOTH (orig
, orig_byte
);
805 unbind_to (count
, Qnil
);
807 /* Return END constrained to the current input field. */
808 return Fconstrain_to_field (make_number (end
), make_number (orig
),
809 XINT (n
) != 1 ? Qt
: Qnil
,
813 DEFUN ("line-end-position", Fline_end_position
, Sline_end_position
, 0, 1, 0,
814 doc
: /* Return the character position of the last character on the current line.
815 With argument N not nil or 1, move forward N - 1 lines first.
816 If scan reaches end of buffer, return that position.
818 The returned position is of the last character in the logical order,
819 i.e. the character whose buffer position is the largest one.
821 This function constrains the returned position to the current field
822 unless that would be on a different line than the original,
823 unconstrained result. If N is nil or 1, and a rear-sticky field ends
824 at point, the scan stops as soon as it starts. To ignore field
825 boundaries bind `inhibit-field-text-motion' to t.
827 This function does not move point. */)
838 end_pos
= find_before_next_newline (orig
, 0, XINT (n
) - (XINT (n
) <= 0));
840 /* Return END_POS constrained to the current input field. */
841 return Fconstrain_to_field (make_number (end_pos
), make_number (orig
),
847 save_excursion_save (void)
849 int visible
= (XBUFFER (XWINDOW (selected_window
)->buffer
)
852 return Fcons (Fpoint_marker (),
853 Fcons (Fcopy_marker (BVAR (current_buffer
, mark
), Qnil
),
854 Fcons (visible
? Qt
: Qnil
,
855 Fcons (BVAR (current_buffer
, mark_active
),
860 save_excursion_restore (Lisp_Object info
)
862 Lisp_Object tem
, tem1
, omark
, nmark
;
863 struct gcpro gcpro1
, gcpro2
, gcpro3
;
866 tem
= Fmarker_buffer (XCAR (info
));
867 /* If buffer being returned to is now deleted, avoid error */
868 /* Otherwise could get error here while unwinding to top level
870 /* In that case, Fmarker_buffer returns nil now. */
874 omark
= nmark
= Qnil
;
875 GCPRO3 (info
, omark
, nmark
);
882 unchain_marker (XMARKER (tem
));
887 omark
= Fmarker_position (BVAR (current_buffer
, mark
));
888 Fset_marker (BVAR (current_buffer
, mark
), tem
, Fcurrent_buffer ());
889 nmark
= Fmarker_position (tem
);
890 unchain_marker (XMARKER (tem
));
894 visible_p
= !NILP (XCAR (info
));
896 #if 0 /* We used to make the current buffer visible in the selected window
897 if that was true previously. That avoids some anomalies.
898 But it creates others, and it wasn't documented, and it is simpler
899 and cleaner never to alter the window/buffer connections. */
902 && current_buffer
!= XBUFFER (XWINDOW (selected_window
)->buffer
))
903 Fswitch_to_buffer (Fcurrent_buffer (), Qnil
);
909 tem1
= BVAR (current_buffer
, mark_active
);
910 BVAR (current_buffer
, mark_active
) = tem
;
912 /* If mark is active now, and either was not active
913 or was at a different place, run the activate hook. */
916 if (! EQ (omark
, nmark
))
918 tem
= intern ("activate-mark-hook");
919 Frun_hooks (1, &tem
);
922 /* If mark has ceased to be active, run deactivate hook. */
923 else if (! NILP (tem1
))
925 tem
= intern ("deactivate-mark-hook");
926 Frun_hooks (1, &tem
);
929 /* If buffer was visible in a window, and a different window was
930 selected, and the old selected window is still showing this
931 buffer, restore point in that window. */
934 && !EQ (tem
, selected_window
)
935 && (tem1
= XWINDOW (tem
)->buffer
,
936 (/* Window is live... */
938 /* ...and it shows the current buffer. */
939 && XBUFFER (tem1
) == current_buffer
)))
940 Fset_window_point (tem
, make_number (PT
));
946 DEFUN ("save-excursion", Fsave_excursion
, Ssave_excursion
, 0, UNEVALLED
, 0,
947 doc
: /* Save point, mark, and current buffer; execute BODY; restore those things.
948 Executes BODY just like `progn'.
949 The values of point, mark and the current buffer are restored
950 even in case of abnormal exit (throw or error).
951 The state of activation of the mark is also restored.
953 This construct does not save `deactivate-mark', and therefore
954 functions that change the buffer will still cause deactivation
955 of the mark at the end of the command. To prevent that, bind
956 `deactivate-mark' with `let'.
958 If you only want to save the current buffer but not point nor mark,
959 then just use `save-current-buffer', or even `with-current-buffer'.
961 usage: (save-excursion &rest BODY) */)
964 register Lisp_Object val
;
965 int count
= SPECPDL_INDEX ();
967 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
970 return unbind_to (count
, val
);
973 DEFUN ("save-current-buffer", Fsave_current_buffer
, Ssave_current_buffer
, 0, UNEVALLED
, 0,
974 doc
: /* Save the current buffer; execute BODY; restore the current buffer.
975 Executes BODY just like `progn'.
976 usage: (save-current-buffer &rest BODY) */)
980 int count
= SPECPDL_INDEX ();
982 record_unwind_protect (set_buffer_if_live
, Fcurrent_buffer ());
985 return unbind_to (count
, val
);
988 DEFUN ("buffer-size", Fbufsize
, Sbufsize
, 0, 1, 0,
989 doc
: /* Return the number of characters in the current buffer.
990 If BUFFER, return the number of characters in that buffer instead. */)
994 return make_number (Z
- BEG
);
997 CHECK_BUFFER (buffer
);
998 return make_number (BUF_Z (XBUFFER (buffer
))
999 - BUF_BEG (XBUFFER (buffer
)));
1003 DEFUN ("point-min", Fpoint_min
, Spoint_min
, 0, 0, 0,
1004 doc
: /* Return the minimum permissible value of point in the current buffer.
1005 This is 1, unless narrowing (a buffer restriction) is in effect. */)
1009 XSETFASTINT (temp
, BEGV
);
1013 DEFUN ("point-min-marker", Fpoint_min_marker
, Spoint_min_marker
, 0, 0, 0,
1014 doc
: /* Return a marker to the minimum permissible value of point in this buffer.
1015 This is the beginning, unless narrowing (a buffer restriction) is in effect. */)
1018 return buildmark (BEGV
, BEGV_BYTE
);
1021 DEFUN ("point-max", Fpoint_max
, Spoint_max
, 0, 0, 0,
1022 doc
: /* Return the maximum permissible value of point in the current buffer.
1023 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1024 is in effect, in which case it is less. */)
1028 XSETFASTINT (temp
, ZV
);
1032 DEFUN ("point-max-marker", Fpoint_max_marker
, Spoint_max_marker
, 0, 0, 0,
1033 doc
: /* Return a marker to the maximum permissible value of point in this buffer.
1034 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1035 is in effect, in which case it is less. */)
1038 return buildmark (ZV
, ZV_BYTE
);
1041 DEFUN ("gap-position", Fgap_position
, Sgap_position
, 0, 0, 0,
1042 doc
: /* Return the position of the gap, in the current buffer.
1043 See also `gap-size'. */)
1047 XSETFASTINT (temp
, GPT
);
1051 DEFUN ("gap-size", Fgap_size
, Sgap_size
, 0, 0, 0,
1052 doc
: /* Return the size of the current buffer's gap.
1053 See also `gap-position'. */)
1057 XSETFASTINT (temp
, GAP_SIZE
);
1061 DEFUN ("position-bytes", Fposition_bytes
, Sposition_bytes
, 1, 1, 0,
1062 doc
: /* Return the byte position for character position POSITION.
1063 If POSITION is out of range, the value is nil. */)
1064 (Lisp_Object position
)
1066 CHECK_NUMBER_COERCE_MARKER (position
);
1067 if (XINT (position
) < BEG
|| XINT (position
) > Z
)
1069 return make_number (CHAR_TO_BYTE (XINT (position
)));
1072 DEFUN ("byte-to-position", Fbyte_to_position
, Sbyte_to_position
, 1, 1, 0,
1073 doc
: /* Return the character position for byte position BYTEPOS.
1074 If BYTEPOS is out of range, the value is nil. */)
1075 (Lisp_Object bytepos
)
1077 CHECK_NUMBER (bytepos
);
1078 if (XINT (bytepos
) < BEG_BYTE
|| XINT (bytepos
) > Z_BYTE
)
1080 return make_number (BYTE_TO_CHAR (XINT (bytepos
)));
1083 DEFUN ("following-char", Ffollowing_char
, Sfollowing_char
, 0, 0, 0,
1084 doc
: /* Return the character following point, as a number.
1085 At the end of the buffer or accessible region, return 0. */)
1090 XSETFASTINT (temp
, 0);
1092 XSETFASTINT (temp
, FETCH_CHAR (PT_BYTE
));
1096 DEFUN ("preceding-char", Fprevious_char
, Sprevious_char
, 0, 0, 0,
1097 doc
: /* Return the character preceding point, as a number.
1098 At the beginning of the buffer or accessible region, return 0. */)
1103 XSETFASTINT (temp
, 0);
1104 else if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
1106 EMACS_INT pos
= PT_BYTE
;
1108 XSETFASTINT (temp
, FETCH_CHAR (pos
));
1111 XSETFASTINT (temp
, FETCH_BYTE (PT_BYTE
- 1));
1115 DEFUN ("bobp", Fbobp
, Sbobp
, 0, 0, 0,
1116 doc
: /* Return t if point is at the beginning of the buffer.
1117 If the buffer is narrowed, this means the beginning of the narrowed part. */)
1125 DEFUN ("eobp", Feobp
, Seobp
, 0, 0, 0,
1126 doc
: /* Return t if point is at the end of the buffer.
1127 If the buffer is narrowed, this means the end of the narrowed part. */)
1135 DEFUN ("bolp", Fbolp
, Sbolp
, 0, 0, 0,
1136 doc
: /* Return t if point is at the beginning of a line. */)
1139 if (PT
== BEGV
|| FETCH_BYTE (PT_BYTE
- 1) == '\n')
1144 DEFUN ("eolp", Feolp
, Seolp
, 0, 0, 0,
1145 doc
: /* Return t if point is at the end of a line.
1146 `End of a line' includes point being at the end of the buffer. */)
1149 if (PT
== ZV
|| FETCH_BYTE (PT_BYTE
) == '\n')
1154 DEFUN ("char-after", Fchar_after
, Schar_after
, 0, 1, 0,
1155 doc
: /* Return character in current buffer at position POS.
1156 POS is an integer or a marker and defaults to point.
1157 If POS is out of range, the value is nil. */)
1160 register EMACS_INT pos_byte
;
1165 XSETFASTINT (pos
, PT
);
1170 pos_byte
= marker_byte_position (pos
);
1171 if (pos_byte
< BEGV_BYTE
|| pos_byte
>= ZV_BYTE
)
1176 CHECK_NUMBER_COERCE_MARKER (pos
);
1177 if (XINT (pos
) < BEGV
|| XINT (pos
) >= ZV
)
1180 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1183 return make_number (FETCH_CHAR (pos_byte
));
1186 DEFUN ("char-before", Fchar_before
, Schar_before
, 0, 1, 0,
1187 doc
: /* Return character in current buffer preceding position POS.
1188 POS is an integer or a marker and defaults to point.
1189 If POS is out of range, the value is nil. */)
1192 register Lisp_Object val
;
1193 register EMACS_INT pos_byte
;
1198 XSETFASTINT (pos
, PT
);
1203 pos_byte
= marker_byte_position (pos
);
1205 if (pos_byte
<= BEGV_BYTE
|| pos_byte
> ZV_BYTE
)
1210 CHECK_NUMBER_COERCE_MARKER (pos
);
1212 if (XINT (pos
) <= BEGV
|| XINT (pos
) > ZV
)
1215 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1218 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
1221 XSETFASTINT (val
, FETCH_CHAR (pos_byte
));
1226 XSETFASTINT (val
, FETCH_BYTE (pos_byte
));
1231 DEFUN ("user-login-name", Fuser_login_name
, Suser_login_name
, 0, 1, 0,
1232 doc
: /* Return the name under which the user logged in, as a string.
1233 This is based on the effective uid, not the real uid.
1234 Also, if the environment variables LOGNAME or USER are set,
1235 that determines the value of this function.
1237 If optional argument UID is an integer or a float, return the login name
1238 of the user with that uid, or nil if there is no such user. */)
1244 /* Set up the user name info if we didn't do it before.
1245 (That can happen if Emacs is dumpable
1246 but you decide to run `temacs -l loadup' and not dump. */
1247 if (INTEGERP (Vuser_login_name
))
1251 return Vuser_login_name
;
1253 id
= XFLOATINT (uid
);
1257 return (pw
? build_string (pw
->pw_name
) : Qnil
);
1260 DEFUN ("user-real-login-name", Fuser_real_login_name
, Suser_real_login_name
,
1262 doc
: /* Return the name of the user's real uid, as a string.
1263 This ignores the environment variables LOGNAME and USER, so it differs from
1264 `user-login-name' when running under `su'. */)
1267 /* Set up the user name info if we didn't do it before.
1268 (That can happen if Emacs is dumpable
1269 but you decide to run `temacs -l loadup' and not dump. */
1270 if (INTEGERP (Vuser_login_name
))
1272 return Vuser_real_login_name
;
1275 DEFUN ("user-uid", Fuser_uid
, Suser_uid
, 0, 0, 0,
1276 doc
: /* Return the effective uid of Emacs.
1277 Value is an integer or a float, depending on the value. */)
1280 /* Assignment to EMACS_INT stops GCC whining about limited range of
1282 EMACS_INT euid
= geteuid ();
1284 /* Make sure we don't produce a negative UID due to signed integer
1287 return make_float (geteuid ());
1288 return make_fixnum_or_float (euid
);
1291 DEFUN ("user-real-uid", Fuser_real_uid
, Suser_real_uid
, 0, 0, 0,
1292 doc
: /* Return the real uid of Emacs.
1293 Value is an integer or a float, depending on the value. */)
1296 /* Assignment to EMACS_INT stops GCC whining about limited range of
1298 EMACS_INT uid
= getuid ();
1300 /* Make sure we don't produce a negative UID due to signed integer
1303 return make_float (getuid ());
1304 return make_fixnum_or_float (uid
);
1307 DEFUN ("user-full-name", Fuser_full_name
, Suser_full_name
, 0, 1, 0,
1308 doc
: /* Return the full name of the user logged in, as a string.
1309 If the full name corresponding to Emacs's userid is not known,
1312 If optional argument UID is an integer or float, return the full name
1313 of the user with that uid, or nil if there is no such user.
1314 If UID is a string, return the full name of the user with that login
1315 name, or nil if there is no such user. */)
1319 register char *p
, *q
;
1323 return Vuser_full_name
;
1324 else if (NUMBERP (uid
))
1326 uid_t u
= XFLOATINT (uid
);
1331 else if (STRINGP (uid
))
1334 pw
= getpwnam (SSDATA (uid
));
1338 error ("Invalid UID specification");
1344 /* Chop off everything after the first comma. */
1345 q
= strchr (p
, ',');
1346 full
= make_string (p
, q
? q
- p
: strlen (p
));
1348 #ifdef AMPERSAND_FULL_NAME
1350 q
= strchr (p
, '&');
1351 /* Substitute the login name for the &, upcasing the first character. */
1357 login
= Fuser_login_name (make_number (pw
->pw_uid
));
1358 r
= (char *) alloca (strlen (p
) + SCHARS (login
) + 1);
1359 memcpy (r
, p
, q
- p
);
1361 strcat (r
, SSDATA (login
));
1362 r
[q
- p
] = upcase ((unsigned char) r
[q
- p
]);
1364 full
= build_string (r
);
1366 #endif /* AMPERSAND_FULL_NAME */
1371 DEFUN ("system-name", Fsystem_name
, Ssystem_name
, 0, 0, 0,
1372 doc
: /* Return the host name of the machine you are running on, as a string. */)
1375 return Vsystem_name
;
1379 get_system_name (void)
1381 if (STRINGP (Vsystem_name
))
1382 return SSDATA (Vsystem_name
);
1387 DEFUN ("emacs-pid", Femacs_pid
, Semacs_pid
, 0, 0, 0,
1388 doc
: /* Return the process ID of Emacs, as an integer. */)
1391 return make_number (getpid ());
1397 # define TIME_T_MIN TYPE_MINIMUM (time_t)
1400 # define TIME_T_MAX TYPE_MAXIMUM (time_t)
1403 /* Report that a time value is out of range for Emacs. */
1405 time_overflow (void)
1407 error ("Specified time is not representable");
1410 /* Return the upper part of the time T (everything but the bottom 16 bits),
1411 making sure that it is representable. */
1415 time_t hi
= t
>> 16;
1417 /* Check for overflow, helping the compiler for common cases where
1418 no runtime check is needed, and taking care not to convert
1419 negative numbers to unsigned before comparing them. */
1420 if (! ((! TYPE_SIGNED (time_t)
1421 || MOST_NEGATIVE_FIXNUM
<= TIME_T_MIN
>> 16
1422 || MOST_NEGATIVE_FIXNUM
<= hi
)
1423 && (TIME_T_MAX
>> 16 <= MOST_POSITIVE_FIXNUM
1424 || hi
<= MOST_POSITIVE_FIXNUM
)))
1430 /* Return the bottom 16 bits of the time T. */
1434 return t
& ((1 << 16) - 1);
1437 DEFUN ("current-time", Fcurrent_time
, Scurrent_time
, 0, 0, 0,
1438 doc
: /* Return the current time, as the number of seconds since 1970-01-01 00:00:00.
1439 The time is returned as a list of three integers. The first has the
1440 most significant 16 bits of the seconds, while the second has the
1441 least significant 16 bits. The third integer gives the microsecond
1444 The microsecond count is zero on systems that do not provide
1445 resolution finer than a second. */)
1451 return list3 (make_number (hi_time (EMACS_SECS (t
))),
1452 make_number (lo_time (EMACS_SECS (t
))),
1453 make_number (EMACS_USECS (t
)));
1456 DEFUN ("get-internal-run-time", Fget_internal_run_time
, Sget_internal_run_time
,
1458 doc
: /* Return the current run time used by Emacs.
1459 The time is returned as a list of three integers. The first has the
1460 most significant 16 bits of the seconds, while the second has the
1461 least significant 16 bits. The third integer gives the microsecond
1464 On systems that can't determine the run time, `get-internal-run-time'
1465 does the same thing as `current-time'. The microsecond count is zero
1466 on systems that do not provide resolution finer than a second. */)
1469 #ifdef HAVE_GETRUSAGE
1470 struct rusage usage
;
1474 if (getrusage (RUSAGE_SELF
, &usage
) < 0)
1475 /* This shouldn't happen. What action is appropriate? */
1478 /* Sum up user time and system time. */
1479 secs
= usage
.ru_utime
.tv_sec
+ usage
.ru_stime
.tv_sec
;
1480 usecs
= usage
.ru_utime
.tv_usec
+ usage
.ru_stime
.tv_usec
;
1481 if (usecs
>= 1000000)
1487 return list3 (make_number (hi_time (secs
)),
1488 make_number (lo_time (secs
)),
1489 make_number (usecs
));
1490 #else /* ! HAVE_GETRUSAGE */
1492 return w32_get_internal_run_time ();
1493 #else /* ! WINDOWSNT */
1494 return Fcurrent_time ();
1495 #endif /* WINDOWSNT */
1496 #endif /* HAVE_GETRUSAGE */
1500 /* Make a Lisp list that represents the time T. */
1502 make_time (time_t t
)
1504 return list2 (make_number (hi_time (t
)),
1505 make_number (lo_time (t
)));
1508 /* Decode a Lisp list SPECIFIED_TIME that represents a time.
1509 If SPECIFIED_TIME is nil, use the current time.
1510 Set *RESULT to seconds since the Epoch.
1511 If USEC is not null, set *USEC to the microseconds component.
1512 Return nonzero if successful. */
1514 lisp_time_argument (Lisp_Object specified_time
, time_t *result
, int *usec
)
1516 if (NILP (specified_time
))
1523 *usec
= EMACS_USECS (t
);
1524 *result
= EMACS_SECS (t
);
1528 return time (result
) != -1;
1532 Lisp_Object high
, low
;
1534 high
= Fcar (specified_time
);
1535 CHECK_NUMBER (high
);
1536 low
= Fcdr (specified_time
);
1541 Lisp_Object usec_l
= Fcdr (low
);
1543 usec_l
= Fcar (usec_l
);
1548 CHECK_NUMBER (usec_l
);
1549 *usec
= XINT (usec_l
);
1559 /* Check for overflow, helping the compiler for common cases
1560 where no runtime check is needed, and taking care not to
1561 convert negative numbers to unsigned before comparing them. */
1562 if (! ((TYPE_SIGNED (time_t)
1563 ? (TIME_T_MIN
>> 16 <= MOST_NEGATIVE_FIXNUM
1564 || TIME_T_MIN
>> 16 <= hi
)
1566 && (MOST_POSITIVE_FIXNUM
<= TIME_T_MAX
>> 16
1567 || hi
<= TIME_T_MAX
>> 16)))
1570 *result
= (hi
<< 16) + (XINT (low
) & 0xffff);
1575 DEFUN ("float-time", Ffloat_time
, Sfloat_time
, 0, 1, 0,
1576 doc
: /* Return the current time, as a float number of seconds since the epoch.
1577 If SPECIFIED-TIME is given, it is the time to convert to float
1578 instead of the current time. The argument should have the form
1579 (HIGH LOW) or (HIGH LOW USEC). Thus, you can use times obtained from
1580 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
1581 have the form (HIGH . LOW), but this is considered obsolete.
1583 WARNING: Since the result is floating point, it may not be exact.
1584 If precise time stamps are required, use either `current-time',
1585 or (if you need time as a string) `format-time-string'. */)
1586 (Lisp_Object specified_time
)
1591 if (! lisp_time_argument (specified_time
, &sec
, &usec
))
1592 error ("Invalid time specification");
1594 return make_float ((sec
* 1e6
+ usec
) / 1e6
);
1597 /* Write information into buffer S of size MAXSIZE, according to the
1598 FORMAT of length FORMAT_LEN, using time information taken from *TP.
1599 Default to Universal Time if UT is nonzero, local time otherwise.
1600 Use NS as the number of nanoseconds in the %N directive.
1601 Return the number of bytes written, not including the terminating
1602 '\0'. If S is NULL, nothing will be written anywhere; so to
1603 determine how many bytes would be written, use NULL for S and
1604 ((size_t) -1) for MAXSIZE.
1606 This function behaves like nstrftime, except it allows null
1607 bytes in FORMAT and it does not support nanoseconds. */
1609 emacs_nmemftime (char *s
, size_t maxsize
, const char *format
,
1610 size_t format_len
, const struct tm
*tp
, int ut
, int ns
)
1614 /* Loop through all the null-terminated strings in the format
1615 argument. Normally there's just one null-terminated string, but
1616 there can be arbitrarily many, concatenated together, if the
1617 format contains '\0' bytes. nstrftime stops at the first
1618 '\0' byte so we must invoke it separately for each such string. */
1627 result
= nstrftime (s
, maxsize
, format
, tp
, ut
, ns
);
1631 if (result
== 0 && s
[0] != '\0')
1636 maxsize
-= result
+ 1;
1638 len
= strlen (format
);
1639 if (len
== format_len
)
1643 format_len
-= len
+ 1;
1647 DEFUN ("format-time-string", Fformat_time_string
, Sformat_time_string
, 1, 3, 0,
1648 doc
: /* Use FORMAT-STRING to format the time TIME, or now if omitted.
1649 TIME is specified as (HIGH LOW . IGNORED), as returned by
1650 `current-time' or `file-attributes'. The obsolete form (HIGH . LOW)
1651 is also still accepted.
1652 The third, optional, argument UNIVERSAL, if non-nil, means describe TIME
1653 as Universal Time; nil means describe TIME in the local time zone.
1654 The value is a copy of FORMAT-STRING, but with certain constructs replaced
1655 by text that describes the specified date and time in TIME:
1657 %Y is the year, %y within the century, %C the century.
1658 %G is the year corresponding to the ISO week, %g within the century.
1659 %m is the numeric month.
1660 %b and %h are the locale's abbreviated month name, %B the full name.
1661 %d is the day of the month, zero-padded, %e is blank-padded.
1662 %u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.
1663 %a is the locale's abbreviated name of the day of week, %A the full name.
1664 %U is the week number starting on Sunday, %W starting on Monday,
1665 %V according to ISO 8601.
1666 %j is the day of the year.
1668 %H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H
1669 only blank-padded, %l is like %I blank-padded.
1670 %p is the locale's equivalent of either AM or PM.
1673 %N is the nanosecond, %6N the microsecond, %3N the millisecond, etc.
1674 %Z is the time zone name, %z is the numeric form.
1675 %s is the number of seconds since 1970-01-01 00:00:00 +0000.
1677 %c is the locale's date and time format.
1678 %x is the locale's "preferred" date format.
1679 %D is like "%m/%d/%y".
1681 %R is like "%H:%M", %T is like "%H:%M:%S", %r is like "%I:%M:%S %p".
1682 %X is the locale's "preferred" time format.
1684 Finally, %n is a newline, %t is a tab, %% is a literal %.
1686 Certain flags and modifiers are available with some format controls.
1687 The flags are `_', `-', `^' and `#'. For certain characters X,
1688 %_X is like %X, but padded with blanks; %-X is like %X,
1689 but without padding. %^X is like %X, but with all textual
1690 characters up-cased; %#X is like %X, but with letter-case of
1691 all textual characters reversed.
1692 %NX (where N stands for an integer) is like %X,
1693 but takes up at least N (a number) positions.
1694 The modifiers are `E' and `O'. For certain characters X,
1695 %EX is a locale's alternative version of %X;
1696 %OX is like %X, but uses the locale's number symbols.
1698 For example, to produce full ISO 8601 format, use "%Y-%m-%dT%T%z".
1700 usage: (format-time-string FORMAT-STRING &optional TIME UNIVERSAL) */)
1701 (Lisp_Object format_string
, Lisp_Object timeval
, Lisp_Object universal
)
1708 int ut
= ! NILP (universal
);
1710 CHECK_STRING (format_string
);
1712 if (! (lisp_time_argument (timeval
, &value
, &usec
)
1713 && 0 <= usec
&& usec
< 1000000))
1714 error ("Invalid time specification");
1717 format_string
= code_convert_string_norecord (format_string
,
1718 Vlocale_coding_system
, 1);
1720 /* This is probably enough. */
1721 size
= SBYTES (format_string
);
1722 if (size
<= (STRING_BYTES_BOUND
- 50) / 6)
1723 size
= size
* 6 + 50;
1726 tm
= ut
? gmtime (&value
) : localtime (&value
);
1731 synchronize_system_time_locale ();
1735 char *buf
= (char *) alloca (size
+ 1);
1740 result
= emacs_nmemftime (buf
, size
, SSDATA (format_string
),
1741 SBYTES (format_string
),
1744 if ((result
> 0 && result
< size
) || (result
== 0 && buf
[0] == '\0'))
1745 return code_convert_string_norecord (make_unibyte_string (buf
, result
),
1746 Vlocale_coding_system
, 0);
1748 /* If buffer was too small, make it bigger and try again. */
1750 result
= emacs_nmemftime (NULL
, (size_t) -1,
1751 SSDATA (format_string
),
1752 SBYTES (format_string
),
1755 if (STRING_BYTES_BOUND
<= result
)
1761 DEFUN ("decode-time", Fdecode_time
, Sdecode_time
, 0, 1, 0,
1762 doc
: /* Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST ZONE).
1763 The optional SPECIFIED-TIME should be a list of (HIGH LOW . IGNORED),
1764 as from `current-time' and `file-attributes', or nil to use the
1765 current time. The obsolete form (HIGH . LOW) is also still accepted.
1766 The list has the following nine members: SEC is an integer between 0
1767 and 60; SEC is 60 for a leap second, which only some operating systems
1768 support. MINUTE is an integer between 0 and 59. HOUR is an integer
1769 between 0 and 23. DAY is an integer between 1 and 31. MONTH is an
1770 integer between 1 and 12. YEAR is an integer indicating the
1771 four-digit year. DOW is the day of week, an integer between 0 and 6,
1772 where 0 is Sunday. DST is t if daylight saving time is in effect,
1773 otherwise nil. ZONE is an integer indicating the number of seconds
1774 east of Greenwich. (Note that Common Lisp has different meanings for
1776 (Lisp_Object specified_time
)
1780 struct tm
*decoded_time
;
1781 Lisp_Object list_args
[9];
1783 if (! lisp_time_argument (specified_time
, &time_spec
, NULL
))
1784 error ("Invalid time specification");
1787 decoded_time
= localtime (&time_spec
);
1790 && MOST_NEGATIVE_FIXNUM
- TM_YEAR_BASE
<= decoded_time
->tm_year
1791 && decoded_time
->tm_year
<= MOST_POSITIVE_FIXNUM
- TM_YEAR_BASE
))
1793 XSETFASTINT (list_args
[0], decoded_time
->tm_sec
);
1794 XSETFASTINT (list_args
[1], decoded_time
->tm_min
);
1795 XSETFASTINT (list_args
[2], decoded_time
->tm_hour
);
1796 XSETFASTINT (list_args
[3], decoded_time
->tm_mday
);
1797 XSETFASTINT (list_args
[4], decoded_time
->tm_mon
+ 1);
1798 /* On 64-bit machines an int is narrower than EMACS_INT, thus the
1799 cast below avoids overflow in int arithmetics. */
1800 XSETINT (list_args
[5], TM_YEAR_BASE
+ (EMACS_INT
) decoded_time
->tm_year
);
1801 XSETFASTINT (list_args
[6], decoded_time
->tm_wday
);
1802 list_args
[7] = (decoded_time
->tm_isdst
)? Qt
: Qnil
;
1804 /* Make a copy, in case gmtime modifies the struct. */
1805 save_tm
= *decoded_time
;
1807 decoded_time
= gmtime (&time_spec
);
1809 if (decoded_time
== 0)
1810 list_args
[8] = Qnil
;
1812 XSETINT (list_args
[8], tm_diff (&save_tm
, decoded_time
));
1813 return Flist (9, list_args
);
1816 /* Return OBJ - OFFSET, checking that OBJ is a valid fixnum and that
1817 the result is representable as an int. Assume OFFSET is small and
1820 check_tm_member (Lisp_Object obj
, int offset
)
1825 if (! (INT_MIN
+ offset
<= n
&& n
- offset
<= INT_MAX
))
1830 DEFUN ("encode-time", Fencode_time
, Sencode_time
, 6, MANY
, 0,
1831 doc
: /* Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.
1832 This is the reverse operation of `decode-time', which see.
1833 ZONE defaults to the current time zone rule. This can
1834 be a string or t (as from `set-time-zone-rule'), or it can be a list
1835 \(as from `current-time-zone') or an integer (as from `decode-time')
1836 applied without consideration for daylight saving time.
1838 You can pass more than 7 arguments; then the first six arguments
1839 are used as SECOND through YEAR, and the *last* argument is used as ZONE.
1840 The intervening arguments are ignored.
1841 This feature lets (apply 'encode-time (decode-time ...)) work.
1843 Out-of-range values for SECOND, MINUTE, HOUR, DAY, or MONTH are allowed;
1844 for example, a DAY of 0 means the day preceding the given month.
1845 Year numbers less than 100 are treated just like other year numbers.
1846 If you want them to stand for years in this century, you must do that yourself.
1848 Years before 1970 are not guaranteed to work. On some systems,
1849 year values as low as 1901 do work.
1851 usage: (encode-time SECOND MINUTE HOUR DAY MONTH YEAR &optional ZONE) */)
1852 (ptrdiff_t nargs
, Lisp_Object
*args
)
1856 Lisp_Object zone
= (nargs
> 6 ? args
[nargs
- 1] : Qnil
);
1858 tm
.tm_sec
= check_tm_member (args
[0], 0);
1859 tm
.tm_min
= check_tm_member (args
[1], 0);
1860 tm
.tm_hour
= check_tm_member (args
[2], 0);
1861 tm
.tm_mday
= check_tm_member (args
[3], 0);
1862 tm
.tm_mon
= check_tm_member (args
[4], 1);
1863 tm
.tm_year
= check_tm_member (args
[5], TM_YEAR_BASE
);
1871 value
= mktime (&tm
);
1877 const char *tzstring
;
1878 char **oldenv
= environ
, **newenv
;
1882 else if (STRINGP (zone
))
1883 tzstring
= SSDATA (zone
);
1884 else if (INTEGERP (zone
))
1886 int abszone
= eabs (XINT (zone
));
1887 sprintf (tzbuf
, "XXX%s%d:%02d:%02d", "-" + (XINT (zone
) < 0),
1888 abszone
/ (60*60), (abszone
/60) % 60, abszone
% 60);
1892 error ("Invalid time zone specification");
1894 /* Set TZ before calling mktime; merely adjusting mktime's returned
1895 value doesn't suffice, since that would mishandle leap seconds. */
1896 set_time_zone_rule (tzstring
);
1899 value
= mktime (&tm
);
1902 /* Restore TZ to previous value. */
1906 #ifdef LOCALTIME_CACHE
1911 if (value
== (time_t) -1)
1914 return make_time (value
);
1917 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
, 0, 1, 0,
1918 doc
: /* Return the current local time, as a human-readable string.
1919 Programs can use this function to decode a time,
1920 since the number of columns in each field is fixed
1921 if the year is in the range 1000-9999.
1922 The format is `Sun Sep 16 01:03:52 1973'.
1923 However, see also the functions `decode-time' and `format-time-string'
1924 which provide a much more powerful and general facility.
1926 If SPECIFIED-TIME is given, it is a time to format instead of the
1927 current time. The argument should have the form (HIGH LOW . IGNORED).
1928 Thus, you can use times obtained from `current-time' and from
1929 `file-attributes'. SPECIFIED-TIME can also have the form (HIGH . LOW),
1930 but this is considered obsolete. */)
1931 (Lisp_Object specified_time
)
1937 if (! lisp_time_argument (specified_time
, &value
, NULL
))
1938 error ("Invalid time specification");
1940 /* Convert to a string, checking for out-of-range time stamps.
1941 Don't use 'ctime', as that might dump core if VALUE is out of
1944 tm
= localtime (&value
);
1946 if (! (tm
&& TM_YEAR_IN_ASCTIME_RANGE (tm
->tm_year
) && (tem
= asctime (tm
))))
1949 /* Remove the trailing newline. */
1950 tem
[strlen (tem
) - 1] = '\0';
1952 return build_string (tem
);
1955 /* Yield A - B, measured in seconds.
1956 This function is copied from the GNU C Library. */
1958 tm_diff (struct tm
*a
, struct tm
*b
)
1960 /* Compute intervening leap days correctly even if year is negative.
1961 Take care to avoid int overflow in leap day calculations,
1962 but it's OK to assume that A and B are close to each other. */
1963 int a4
= (a
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (a
->tm_year
& 3);
1964 int b4
= (b
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (b
->tm_year
& 3);
1965 int a100
= a4
/ 25 - (a4
% 25 < 0);
1966 int b100
= b4
/ 25 - (b4
% 25 < 0);
1967 int a400
= a100
>> 2;
1968 int b400
= b100
>> 2;
1969 int intervening_leap_days
= (a4
- b4
) - (a100
- b100
) + (a400
- b400
);
1970 int years
= a
->tm_year
- b
->tm_year
;
1971 int days
= (365 * years
+ intervening_leap_days
1972 + (a
->tm_yday
- b
->tm_yday
));
1973 return (60 * (60 * (24 * days
+ (a
->tm_hour
- b
->tm_hour
))
1974 + (a
->tm_min
- b
->tm_min
))
1975 + (a
->tm_sec
- b
->tm_sec
));
1978 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 1, 0,
1979 doc
: /* Return the offset and name for the local time zone.
1980 This returns a list of the form (OFFSET NAME).
1981 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).
1982 A negative value means west of Greenwich.
1983 NAME is a string giving the name of the time zone.
1984 If SPECIFIED-TIME is given, the time zone offset is determined from it
1985 instead of using the current time. The argument should have the form
1986 (HIGH LOW . IGNORED). Thus, you can use times obtained from
1987 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
1988 have the form (HIGH . LOW), but this is considered obsolete.
1990 Some operating systems cannot provide all this information to Emacs;
1991 in this case, `current-time-zone' returns a list containing nil for
1992 the data it can't find. */)
1993 (Lisp_Object specified_time
)
1999 if (!lisp_time_argument (specified_time
, &value
, NULL
))
2004 t
= gmtime (&value
);
2008 t
= localtime (&value
);
2015 int offset
= tm_diff (t
, &gmt
);
2017 char buf
[sizeof "+00" + INT_STRLEN_BOUND (int)];
2021 s
= (char *)t
->tm_zone
;
2022 #else /* not HAVE_TM_ZONE */
2024 if (t
->tm_isdst
== 0 || t
->tm_isdst
== 1)
2025 s
= tzname
[t
->tm_isdst
];
2027 #endif /* not HAVE_TM_ZONE */
2031 /* No local time zone name is available; use "+-NNNN" instead. */
2032 int m
= offset
/ 60;
2033 int am
= offset
< 0 ? - m
: m
;
2034 sprintf (buf
, "%c%02d%02d", (offset
< 0 ? '-' : '+'), am
/60, am
%60);
2038 return Fcons (make_number (offset
), Fcons (build_string (s
), Qnil
));
2041 return Fmake_list (make_number (2), Qnil
);
2044 /* This holds the value of `environ' produced by the previous
2045 call to Fset_time_zone_rule, or 0 if Fset_time_zone_rule
2046 has never been called. */
2047 static char **environbuf
;
2049 /* This holds the startup value of the TZ environment variable so it
2050 can be restored if the user calls set-time-zone-rule with a nil
2052 static char *initial_tz
;
2054 DEFUN ("set-time-zone-rule", Fset_time_zone_rule
, Sset_time_zone_rule
, 1, 1, 0,
2055 doc
: /* Set the local time zone using TZ, a string specifying a time zone rule.
2056 If TZ is nil, use implementation-defined default time zone information.
2057 If TZ is t, use Universal Time.
2059 Instead of calling this function, you typically want (setenv "TZ" TZ).
2060 That changes both the environment of the Emacs process and the
2061 variable `process-environment', whereas `set-time-zone-rule' affects
2062 only the former. */)
2065 const char *tzstring
;
2067 /* When called for the first time, save the original TZ. */
2069 initial_tz
= (char *) getenv ("TZ");
2072 tzstring
= initial_tz
;
2073 else if (EQ (tz
, Qt
))
2078 tzstring
= SSDATA (tz
);
2081 set_time_zone_rule (tzstring
);
2083 environbuf
= environ
;
2088 #ifdef LOCALTIME_CACHE
2090 /* These two values are known to load tz files in buggy implementations,
2091 i.e. Solaris 1 executables running under either Solaris 1 or Solaris 2.
2092 Their values shouldn't matter in non-buggy implementations.
2093 We don't use string literals for these strings,
2094 since if a string in the environment is in readonly
2095 storage, it runs afoul of bugs in SVR4 and Solaris 2.3.
2096 See Sun bugs 1113095 and 1114114, ``Timezone routines
2097 improperly modify environment''. */
2099 static char set_time_zone_rule_tz1
[] = "TZ=GMT+0";
2100 static char set_time_zone_rule_tz2
[] = "TZ=GMT+1";
2104 /* Set the local time zone rule to TZSTRING.
2105 This allocates memory into `environ', which it is the caller's
2106 responsibility to free. */
2109 set_time_zone_rule (const char *tzstring
)
2112 char **from
, **to
, **newenv
;
2114 /* Make the ENVIRON vector longer with room for TZSTRING. */
2115 for (from
= environ
; *from
; from
++)
2117 envptrs
= from
- environ
+ 2;
2118 newenv
= to
= (char **) xmalloc (envptrs
* sizeof (char *)
2119 + (tzstring
? strlen (tzstring
) + 4 : 0));
2121 /* Add TZSTRING to the end of environ, as a value for TZ. */
2124 char *t
= (char *) (to
+ envptrs
);
2126 strcat (t
, tzstring
);
2130 /* Copy the old environ vector elements into NEWENV,
2131 but don't copy the TZ variable.
2132 So we have only one definition of TZ, which came from TZSTRING. */
2133 for (from
= environ
; *from
; from
++)
2134 if (strncmp (*from
, "TZ=", 3) != 0)
2140 /* If we do have a TZSTRING, NEWENV points to the vector slot where
2141 the TZ variable is stored. If we do not have a TZSTRING,
2142 TO points to the vector slot which has the terminating null. */
2144 #ifdef LOCALTIME_CACHE
2146 /* In SunOS 4.1.3_U1 and 4.1.4, if TZ has a value like
2147 "US/Pacific" that loads a tz file, then changes to a value like
2148 "XXX0" that does not load a tz file, and then changes back to
2149 its original value, the last change is (incorrectly) ignored.
2150 Also, if TZ changes twice in succession to values that do
2151 not load a tz file, tzset can dump core (see Sun bug#1225179).
2152 The following code works around these bugs. */
2156 /* Temporarily set TZ to a value that loads a tz file
2157 and that differs from tzstring. */
2159 *newenv
= (strcmp (tzstring
, set_time_zone_rule_tz1
+ 3) == 0
2160 ? set_time_zone_rule_tz2
: set_time_zone_rule_tz1
);
2166 /* The implied tzstring is unknown, so temporarily set TZ to
2167 two different values that each load a tz file. */
2168 *to
= set_time_zone_rule_tz1
;
2171 *to
= set_time_zone_rule_tz2
;
2176 /* Now TZ has the desired value, and tzset can be invoked safely. */
2183 /* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC
2184 (if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a
2185 type of object is Lisp_String). INHERIT is passed to
2186 INSERT_FROM_STRING_FUNC as the last argument. */
2189 general_insert_function (void (*insert_func
)
2190 (const char *, EMACS_INT
),
2191 void (*insert_from_string_func
)
2192 (Lisp_Object
, EMACS_INT
, EMACS_INT
,
2193 EMACS_INT
, EMACS_INT
, int),
2194 int inherit
, ptrdiff_t nargs
, Lisp_Object
*args
)
2197 register Lisp_Object val
;
2199 for (argnum
= 0; argnum
< nargs
; argnum
++)
2202 if (CHARACTERP (val
))
2204 int c
= XFASTINT (val
);
2205 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2208 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2209 len
= CHAR_STRING (c
, str
);
2212 str
[0] = ASCII_CHAR_P (c
) ? c
: multibyte_char_to_unibyte (c
);
2215 (*insert_func
) ((char *) str
, len
);
2217 else if (STRINGP (val
))
2219 (*insert_from_string_func
) (val
, 0, 0,
2225 wrong_type_argument (Qchar_or_string_p
, val
);
2230 insert1 (Lisp_Object arg
)
2236 /* Callers passing one argument to Finsert need not gcpro the
2237 argument "array", since the only element of the array will
2238 not be used after calling insert or insert_from_string, so
2239 we don't care if it gets trashed. */
2241 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
2242 doc
: /* Insert the arguments, either strings or characters, at point.
2243 Point and before-insertion markers move forward to end up
2244 after the inserted text.
2245 Any other markers at the point of insertion remain before the text.
2247 If the current buffer is multibyte, unibyte strings are converted
2248 to multibyte for insertion (see `string-make-multibyte').
2249 If the current buffer is unibyte, multibyte strings are converted
2250 to unibyte for insertion (see `string-make-unibyte').
2252 When operating on binary data, it may be necessary to preserve the
2253 original bytes of a unibyte string when inserting it into a multibyte
2254 buffer; to accomplish this, apply `string-as-multibyte' to the string
2255 and insert the result.
2257 usage: (insert &rest ARGS) */)
2258 (ptrdiff_t nargs
, Lisp_Object
*args
)
2260 general_insert_function (insert
, insert_from_string
, 0, nargs
, args
);
2264 DEFUN ("insert-and-inherit", Finsert_and_inherit
, Sinsert_and_inherit
,
2266 doc
: /* Insert the arguments at point, inheriting properties from adjoining text.
2267 Point and before-insertion markers move forward to end up
2268 after the inserted text.
2269 Any other markers at the point of insertion remain before the text.
2271 If the current buffer is multibyte, unibyte strings are converted
2272 to multibyte for insertion (see `unibyte-char-to-multibyte').
2273 If the current buffer is unibyte, multibyte strings are converted
2274 to unibyte for insertion.
2276 usage: (insert-and-inherit &rest ARGS) */)
2277 (ptrdiff_t nargs
, Lisp_Object
*args
)
2279 general_insert_function (insert_and_inherit
, insert_from_string
, 1,
2284 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
2285 doc
: /* Insert strings or characters at point, relocating markers after the text.
2286 Point and markers move forward to end up after the inserted text.
2288 If the current buffer is multibyte, unibyte strings are converted
2289 to multibyte for insertion (see `unibyte-char-to-multibyte').
2290 If the current buffer is unibyte, multibyte strings are converted
2291 to unibyte for insertion.
2293 usage: (insert-before-markers &rest ARGS) */)
2294 (ptrdiff_t nargs
, Lisp_Object
*args
)
2296 general_insert_function (insert_before_markers
,
2297 insert_from_string_before_markers
, 0,
2302 DEFUN ("insert-before-markers-and-inherit", Finsert_and_inherit_before_markers
,
2303 Sinsert_and_inherit_before_markers
, 0, MANY
, 0,
2304 doc
: /* Insert text at point, relocating markers and inheriting properties.
2305 Point and markers move forward to end up after the inserted text.
2307 If the current buffer is multibyte, unibyte strings are converted
2308 to multibyte for insertion (see `unibyte-char-to-multibyte').
2309 If the current buffer is unibyte, multibyte strings are converted
2310 to unibyte for insertion.
2312 usage: (insert-before-markers-and-inherit &rest ARGS) */)
2313 (ptrdiff_t nargs
, Lisp_Object
*args
)
2315 general_insert_function (insert_before_markers_and_inherit
,
2316 insert_from_string_before_markers
, 1,
2321 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 2, 3, 0,
2322 doc
: /* Insert COUNT copies of CHARACTER.
2323 Point, and before-insertion markers, are relocated as in the function `insert'.
2324 The optional third arg INHERIT, if non-nil, says to inherit text properties
2325 from adjoining text, if those properties are sticky. */)
2326 (Lisp_Object character
, Lisp_Object count
, Lisp_Object inherit
)
2329 register EMACS_INT n
;
2331 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2334 CHECK_CHARACTER (character
);
2335 CHECK_NUMBER (count
);
2336 c
= XFASTINT (character
);
2338 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2339 len
= CHAR_STRING (c
, str
);
2341 str
[0] = c
, len
= 1;
2342 if (XINT (count
) <= 0)
2344 if (BUF_BYTES_MAX
/ len
< XINT (count
))
2346 n
= XINT (count
) * len
;
2347 stringlen
= min (n
, sizeof string
- sizeof string
% len
);
2348 for (i
= 0; i
< stringlen
; i
++)
2349 string
[i
] = str
[i
% len
];
2350 while (n
> stringlen
)
2353 if (!NILP (inherit
))
2354 insert_and_inherit (string
, stringlen
);
2356 insert (string
, stringlen
);
2359 if (!NILP (inherit
))
2360 insert_and_inherit (string
, n
);
2366 DEFUN ("insert-byte", Finsert_byte
, Sinsert_byte
, 2, 3, 0,
2367 doc
: /* Insert COUNT (second arg) copies of BYTE (first arg).
2368 Both arguments are required.
2369 BYTE is a number of the range 0..255.
2371 If BYTE is 128..255 and the current buffer is multibyte, the
2372 corresponding eight-bit character is inserted.
2374 Point, and before-insertion markers, are relocated as in the function `insert'.
2375 The optional third arg INHERIT, if non-nil, says to inherit text properties
2376 from adjoining text, if those properties are sticky. */)
2377 (Lisp_Object byte
, Lisp_Object count
, Lisp_Object inherit
)
2379 CHECK_NUMBER (byte
);
2380 if (XINT (byte
) < 0 || XINT (byte
) > 255)
2381 args_out_of_range_3 (byte
, make_number (0), make_number (255));
2382 if (XINT (byte
) >= 128
2383 && ! NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2384 XSETFASTINT (byte
, BYTE8_TO_CHAR (XINT (byte
)));
2385 return Finsert_char (byte
, count
, inherit
);
2389 /* Making strings from buffer contents. */
2391 /* Return a Lisp_String containing the text of the current buffer from
2392 START to END. If text properties are in use and the current buffer
2393 has properties in the range specified, the resulting string will also
2394 have them, if PROPS is nonzero.
2396 We don't want to use plain old make_string here, because it calls
2397 make_uninit_string, which can cause the buffer arena to be
2398 compacted. make_string has no way of knowing that the data has
2399 been moved, and thus copies the wrong data into the string. This
2400 doesn't effect most of the other users of make_string, so it should
2401 be left as is. But we should use this function when conjuring
2402 buffer substrings. */
2405 make_buffer_string (EMACS_INT start
, EMACS_INT end
, int props
)
2407 EMACS_INT start_byte
= CHAR_TO_BYTE (start
);
2408 EMACS_INT end_byte
= CHAR_TO_BYTE (end
);
2410 return make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
);
2413 /* Return a Lisp_String containing the text of the current buffer from
2414 START / START_BYTE to END / END_BYTE.
2416 If text properties are in use and the current buffer
2417 has properties in the range specified, the resulting string will also
2418 have them, if PROPS is nonzero.
2420 We don't want to use plain old make_string here, because it calls
2421 make_uninit_string, which can cause the buffer arena to be
2422 compacted. make_string has no way of knowing that the data has
2423 been moved, and thus copies the wrong data into the string. This
2424 doesn't effect most of the other users of make_string, so it should
2425 be left as is. But we should use this function when conjuring
2426 buffer substrings. */
2429 make_buffer_string_both (EMACS_INT start
, EMACS_INT start_byte
,
2430 EMACS_INT end
, EMACS_INT end_byte
, int props
)
2432 Lisp_Object result
, tem
, tem1
;
2434 if (start
< GPT
&& GPT
< end
)
2437 if (! NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2438 result
= make_uninit_multibyte_string (end
- start
, end_byte
- start_byte
);
2440 result
= make_uninit_string (end
- start
);
2441 memcpy (SDATA (result
), BYTE_POS_ADDR (start_byte
), end_byte
- start_byte
);
2443 /* If desired, update and copy the text properties. */
2446 update_buffer_properties (start
, end
);
2448 tem
= Fnext_property_change (make_number (start
), Qnil
, make_number (end
));
2449 tem1
= Ftext_properties_at (make_number (start
), Qnil
);
2451 if (XINT (tem
) != end
|| !NILP (tem1
))
2452 copy_intervals_to_string (result
, current_buffer
, start
,
2459 /* Call Vbuffer_access_fontify_functions for the range START ... END
2460 in the current buffer, if necessary. */
2463 update_buffer_properties (EMACS_INT start
, EMACS_INT end
)
2465 /* If this buffer has some access functions,
2466 call them, specifying the range of the buffer being accessed. */
2467 if (!NILP (Vbuffer_access_fontify_functions
))
2469 Lisp_Object args
[3];
2472 args
[0] = Qbuffer_access_fontify_functions
;
2473 XSETINT (args
[1], start
);
2474 XSETINT (args
[2], end
);
2476 /* But don't call them if we can tell that the work
2477 has already been done. */
2478 if (!NILP (Vbuffer_access_fontified_property
))
2480 tem
= Ftext_property_any (args
[1], args
[2],
2481 Vbuffer_access_fontified_property
,
2484 Frun_hook_with_args (3, args
);
2487 Frun_hook_with_args (3, args
);
2491 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
2492 doc
: /* Return the contents of part of the current buffer as a string.
2493 The two arguments START and END are character positions;
2494 they can be in either order.
2495 The string returned is multibyte if the buffer is multibyte.
2497 This function copies the text properties of that part of the buffer
2498 into the result string; if you don't want the text properties,
2499 use `buffer-substring-no-properties' instead. */)
2500 (Lisp_Object start
, Lisp_Object end
)
2502 register EMACS_INT b
, e
;
2504 validate_region (&start
, &end
);
2508 return make_buffer_string (b
, e
, 1);
2511 DEFUN ("buffer-substring-no-properties", Fbuffer_substring_no_properties
,
2512 Sbuffer_substring_no_properties
, 2, 2, 0,
2513 doc
: /* Return the characters of part of the buffer, without the text properties.
2514 The two arguments START and END are character positions;
2515 they can be in either order. */)
2516 (Lisp_Object start
, Lisp_Object end
)
2518 register EMACS_INT b
, e
;
2520 validate_region (&start
, &end
);
2524 return make_buffer_string (b
, e
, 0);
2527 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
2528 doc
: /* Return the contents of the current buffer as a string.
2529 If narrowing is in effect, this function returns only the visible part
2533 return make_buffer_string (BEGV
, ZV
, 1);
2536 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
2538 doc
: /* Insert before point a substring of the contents of BUFFER.
2539 BUFFER may be a buffer or a buffer name.
2540 Arguments START and END are character positions specifying the substring.
2541 They default to the values of (point-min) and (point-max) in BUFFER. */)
2542 (Lisp_Object buffer
, Lisp_Object start
, Lisp_Object end
)
2544 register EMACS_INT b
, e
, temp
;
2545 register struct buffer
*bp
, *obuf
;
2548 buf
= Fget_buffer (buffer
);
2552 if (NILP (BVAR (bp
, name
)))
2553 error ("Selecting deleted buffer");
2559 CHECK_NUMBER_COERCE_MARKER (start
);
2566 CHECK_NUMBER_COERCE_MARKER (end
);
2571 temp
= b
, b
= e
, e
= temp
;
2573 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
2574 args_out_of_range (start
, end
);
2576 obuf
= current_buffer
;
2577 set_buffer_internal_1 (bp
);
2578 update_buffer_properties (b
, e
);
2579 set_buffer_internal_1 (obuf
);
2581 insert_from_buffer (bp
, b
, e
- b
, 0);
2585 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
2587 doc
: /* Compare two substrings of two buffers; return result as number.
2588 the value is -N if first string is less after N-1 chars,
2589 +N if first string is greater after N-1 chars, or 0 if strings match.
2590 Each substring is represented as three arguments: BUFFER, START and END.
2591 That makes six args in all, three for each substring.
2593 The value of `case-fold-search' in the current buffer
2594 determines whether case is significant or ignored. */)
2595 (Lisp_Object buffer1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object buffer2
, Lisp_Object start2
, Lisp_Object end2
)
2597 register EMACS_INT begp1
, endp1
, begp2
, endp2
, temp
;
2598 register struct buffer
*bp1
, *bp2
;
2599 register Lisp_Object trt
2600 = (!NILP (BVAR (current_buffer
, case_fold_search
))
2601 ? BVAR (current_buffer
, case_canon_table
) : Qnil
);
2602 EMACS_INT chars
= 0;
2603 EMACS_INT i1
, i2
, i1_byte
, i2_byte
;
2605 /* Find the first buffer and its substring. */
2608 bp1
= current_buffer
;
2612 buf1
= Fget_buffer (buffer1
);
2615 bp1
= XBUFFER (buf1
);
2616 if (NILP (BVAR (bp1
, name
)))
2617 error ("Selecting deleted buffer");
2621 begp1
= BUF_BEGV (bp1
);
2624 CHECK_NUMBER_COERCE_MARKER (start1
);
2625 begp1
= XINT (start1
);
2628 endp1
= BUF_ZV (bp1
);
2631 CHECK_NUMBER_COERCE_MARKER (end1
);
2632 endp1
= XINT (end1
);
2636 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
2638 if (!(BUF_BEGV (bp1
) <= begp1
2640 && endp1
<= BUF_ZV (bp1
)))
2641 args_out_of_range (start1
, end1
);
2643 /* Likewise for second substring. */
2646 bp2
= current_buffer
;
2650 buf2
= Fget_buffer (buffer2
);
2653 bp2
= XBUFFER (buf2
);
2654 if (NILP (BVAR (bp2
, name
)))
2655 error ("Selecting deleted buffer");
2659 begp2
= BUF_BEGV (bp2
);
2662 CHECK_NUMBER_COERCE_MARKER (start2
);
2663 begp2
= XINT (start2
);
2666 endp2
= BUF_ZV (bp2
);
2669 CHECK_NUMBER_COERCE_MARKER (end2
);
2670 endp2
= XINT (end2
);
2674 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
2676 if (!(BUF_BEGV (bp2
) <= begp2
2678 && endp2
<= BUF_ZV (bp2
)))
2679 args_out_of_range (start2
, end2
);
2683 i1_byte
= buf_charpos_to_bytepos (bp1
, i1
);
2684 i2_byte
= buf_charpos_to_bytepos (bp2
, i2
);
2686 while (i1
< endp1
&& i2
< endp2
)
2688 /* When we find a mismatch, we must compare the
2689 characters, not just the bytes. */
2694 if (! NILP (BVAR (bp1
, enable_multibyte_characters
)))
2696 c1
= BUF_FETCH_MULTIBYTE_CHAR (bp1
, i1_byte
);
2697 BUF_INC_POS (bp1
, i1_byte
);
2702 c1
= BUF_FETCH_BYTE (bp1
, i1
);
2703 MAKE_CHAR_MULTIBYTE (c1
);
2707 if (! NILP (BVAR (bp2
, enable_multibyte_characters
)))
2709 c2
= BUF_FETCH_MULTIBYTE_CHAR (bp2
, i2_byte
);
2710 BUF_INC_POS (bp2
, i2_byte
);
2715 c2
= BUF_FETCH_BYTE (bp2
, i2
);
2716 MAKE_CHAR_MULTIBYTE (c2
);
2722 c1
= CHAR_TABLE_TRANSLATE (trt
, c1
);
2723 c2
= CHAR_TABLE_TRANSLATE (trt
, c2
);
2726 return make_number (- 1 - chars
);
2728 return make_number (chars
+ 1);
2733 /* The strings match as far as they go.
2734 If one is shorter, that one is less. */
2735 if (chars
< endp1
- begp1
)
2736 return make_number (chars
+ 1);
2737 else if (chars
< endp2
- begp2
)
2738 return make_number (- chars
- 1);
2740 /* Same length too => they are equal. */
2741 return make_number (0);
2745 subst_char_in_region_unwind (Lisp_Object arg
)
2747 return BVAR (current_buffer
, undo_list
) = arg
;
2751 subst_char_in_region_unwind_1 (Lisp_Object arg
)
2753 return BVAR (current_buffer
, filename
) = arg
;
2756 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
2757 Ssubst_char_in_region
, 4, 5, 0,
2758 doc
: /* From START to END, replace FROMCHAR with TOCHAR each time it occurs.
2759 If optional arg NOUNDO is non-nil, don't record this change for undo
2760 and don't mark the buffer as really changed.
2761 Both characters must have the same length of multi-byte form. */)
2762 (Lisp_Object start
, Lisp_Object end
, Lisp_Object fromchar
, Lisp_Object tochar
, Lisp_Object noundo
)
2764 register EMACS_INT pos
, pos_byte
, stop
, i
, len
, end_byte
;
2765 /* Keep track of the first change in the buffer:
2766 if 0 we haven't found it yet.
2767 if < 0 we've found it and we've run the before-change-function.
2768 if > 0 we've actually performed it and the value is its position. */
2769 EMACS_INT changed
= 0;
2770 unsigned char fromstr
[MAX_MULTIBYTE_LENGTH
], tostr
[MAX_MULTIBYTE_LENGTH
];
2772 int count
= SPECPDL_INDEX ();
2773 #define COMBINING_NO 0
2774 #define COMBINING_BEFORE 1
2775 #define COMBINING_AFTER 2
2776 #define COMBINING_BOTH (COMBINING_BEFORE | COMBINING_AFTER)
2777 int maybe_byte_combining
= COMBINING_NO
;
2778 EMACS_INT last_changed
= 0;
2779 int multibyte_p
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
2784 validate_region (&start
, &end
);
2785 CHECK_CHARACTER (fromchar
);
2786 CHECK_CHARACTER (tochar
);
2787 fromc
= XFASTINT (fromchar
);
2788 toc
= XFASTINT (tochar
);
2792 len
= CHAR_STRING (fromc
, fromstr
);
2793 if (CHAR_STRING (toc
, tostr
) != len
)
2794 error ("Characters in `subst-char-in-region' have different byte-lengths");
2795 if (!ASCII_BYTE_P (*tostr
))
2797 /* If *TOSTR is in the range 0x80..0x9F and TOCHAR is not a
2798 complete multibyte character, it may be combined with the
2799 after bytes. If it is in the range 0xA0..0xFF, it may be
2800 combined with the before and after bytes. */
2801 if (!CHAR_HEAD_P (*tostr
))
2802 maybe_byte_combining
= COMBINING_BOTH
;
2803 else if (BYTES_BY_CHAR_HEAD (*tostr
) > len
)
2804 maybe_byte_combining
= COMBINING_AFTER
;
2815 pos_byte
= CHAR_TO_BYTE (pos
);
2816 stop
= CHAR_TO_BYTE (XINT (end
));
2819 /* If we don't want undo, turn off putting stuff on the list.
2820 That's faster than getting rid of things,
2821 and it prevents even the entry for a first change.
2822 Also inhibit locking the file. */
2823 if (!changed
&& !NILP (noundo
))
2825 record_unwind_protect (subst_char_in_region_unwind
,
2826 BVAR (current_buffer
, undo_list
));
2827 BVAR (current_buffer
, undo_list
) = Qt
;
2828 /* Don't do file-locking. */
2829 record_unwind_protect (subst_char_in_region_unwind_1
,
2830 BVAR (current_buffer
, filename
));
2831 BVAR (current_buffer
, filename
) = Qnil
;
2834 if (pos_byte
< GPT_BYTE
)
2835 stop
= min (stop
, GPT_BYTE
);
2838 EMACS_INT pos_byte_next
= pos_byte
;
2840 if (pos_byte
>= stop
)
2842 if (pos_byte
>= end_byte
) break;
2845 p
= BYTE_POS_ADDR (pos_byte
);
2847 INC_POS (pos_byte_next
);
2850 if (pos_byte_next
- pos_byte
== len
2851 && p
[0] == fromstr
[0]
2853 || (p
[1] == fromstr
[1]
2854 && (len
== 2 || (p
[2] == fromstr
[2]
2855 && (len
== 3 || p
[3] == fromstr
[3]))))))
2858 /* We've already seen this and run the before-change-function;
2859 this time we only need to record the actual position. */
2864 modify_region (current_buffer
, pos
, XINT (end
), 0);
2866 if (! NILP (noundo
))
2868 if (MODIFF
- 1 == SAVE_MODIFF
)
2870 if (MODIFF
- 1 == BUF_AUTOSAVE_MODIFF (current_buffer
))
2871 BUF_AUTOSAVE_MODIFF (current_buffer
)++;
2874 /* The before-change-function may have moved the gap
2875 or even modified the buffer so we should start over. */
2879 /* Take care of the case where the new character
2880 combines with neighboring bytes. */
2881 if (maybe_byte_combining
2882 && (maybe_byte_combining
== COMBINING_AFTER
2883 ? (pos_byte_next
< Z_BYTE
2884 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2885 : ((pos_byte_next
< Z_BYTE
2886 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2887 || (pos_byte
> BEG_BYTE
2888 && ! ASCII_BYTE_P (FETCH_BYTE (pos_byte
- 1))))))
2890 Lisp_Object tem
, string
;
2892 struct gcpro gcpro1
;
2894 tem
= BVAR (current_buffer
, undo_list
);
2897 /* Make a multibyte string containing this single character. */
2898 string
= make_multibyte_string ((char *) tostr
, 1, len
);
2899 /* replace_range is less efficient, because it moves the gap,
2900 but it handles combining correctly. */
2901 replace_range (pos
, pos
+ 1, string
,
2903 pos_byte_next
= CHAR_TO_BYTE (pos
);
2904 if (pos_byte_next
> pos_byte
)
2905 /* Before combining happened. We should not increment
2906 POS. So, to cancel the later increment of POS,
2910 INC_POS (pos_byte_next
);
2912 if (! NILP (noundo
))
2913 BVAR (current_buffer
, undo_list
) = tem
;
2920 record_change (pos
, 1);
2921 for (i
= 0; i
< len
; i
++) *p
++ = tostr
[i
];
2923 last_changed
= pos
+ 1;
2925 pos_byte
= pos_byte_next
;
2931 signal_after_change (changed
,
2932 last_changed
- changed
, last_changed
- changed
);
2933 update_compositions (changed
, last_changed
, CHECK_ALL
);
2936 unbind_to (count
, Qnil
);
2941 static Lisp_Object
check_translation (EMACS_INT
, EMACS_INT
, EMACS_INT
,
2944 /* Helper function for Ftranslate_region_internal.
2946 Check if a character sequence at POS (POS_BYTE) matches an element
2947 of VAL. VAL is a list (([FROM-CHAR ...] . TO) ...). If a matching
2948 element is found, return it. Otherwise return Qnil. */
2951 check_translation (EMACS_INT pos
, EMACS_INT pos_byte
, EMACS_INT end
,
2954 int buf_size
= 16, buf_used
= 0;
2955 int *buf
= alloca (sizeof (int) * buf_size
);
2957 for (; CONSP (val
); val
= XCDR (val
))
2966 if (! VECTORP (elt
))
2969 if (len
<= end
- pos
)
2971 for (i
= 0; i
< len
; i
++)
2975 unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
2978 if (buf_used
== buf_size
)
2983 newbuf
= alloca (sizeof (int) * buf_size
);
2984 memcpy (newbuf
, buf
, sizeof (int) * buf_used
);
2987 buf
[buf_used
++] = STRING_CHAR_AND_LENGTH (p
, len1
);
2990 if (XINT (AREF (elt
, i
)) != buf
[i
])
3001 DEFUN ("translate-region-internal", Ftranslate_region_internal
,
3002 Stranslate_region_internal
, 3, 3, 0,
3003 doc
: /* Internal use only.
3004 From START to END, translate characters according to TABLE.
3005 TABLE is a string or a char-table; the Nth character in it is the
3006 mapping for the character with code N.
3007 It returns the number of characters changed. */)
3008 (Lisp_Object start
, Lisp_Object end
, register Lisp_Object table
)
3010 register unsigned char *tt
; /* Trans table. */
3011 register int nc
; /* New character. */
3012 int cnt
; /* Number of changes made. */
3013 EMACS_INT size
; /* Size of translate table. */
3014 EMACS_INT pos
, pos_byte
, end_pos
;
3015 int multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3016 int string_multibyte
IF_LINT (= 0);
3018 validate_region (&start
, &end
);
3019 if (CHAR_TABLE_P (table
))
3021 if (! EQ (XCHAR_TABLE (table
)->purpose
, Qtranslation_table
))
3022 error ("Not a translation table");
3028 CHECK_STRING (table
);
3030 if (! multibyte
&& (SCHARS (table
) < SBYTES (table
)))
3031 table
= string_make_unibyte (table
);
3032 string_multibyte
= SCHARS (table
) < SBYTES (table
);
3033 size
= SBYTES (table
);
3038 pos_byte
= CHAR_TO_BYTE (pos
);
3039 end_pos
= XINT (end
);
3040 modify_region (current_buffer
, pos
, end_pos
, 0);
3043 for (; pos
< end_pos
; )
3045 register unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
3046 unsigned char *str
, buf
[MAX_MULTIBYTE_LENGTH
];
3052 oc
= STRING_CHAR_AND_LENGTH (p
, len
);
3059 /* Reload as signal_after_change in last iteration may GC. */
3061 if (string_multibyte
)
3063 str
= tt
+ string_char_to_byte (table
, oc
);
3064 nc
= STRING_CHAR_AND_LENGTH (str
, str_len
);
3069 if (! ASCII_BYTE_P (nc
) && multibyte
)
3071 str_len
= BYTE8_STRING (nc
, buf
);
3084 val
= CHAR_TABLE_REF (table
, oc
);
3085 if (CHARACTERP (val
))
3087 nc
= XFASTINT (val
);
3088 str_len
= CHAR_STRING (nc
, buf
);
3091 else if (VECTORP (val
) || (CONSP (val
)))
3093 /* VAL is [TO_CHAR ...] or (([FROM-CHAR ...] . TO) ...)
3094 where TO is TO-CHAR or [TO-CHAR ...]. */
3099 if (nc
!= oc
&& nc
>= 0)
3101 /* Simple one char to one char translation. */
3106 /* This is less efficient, because it moves the gap,
3107 but it should handle multibyte characters correctly. */
3108 string
= make_multibyte_string ((char *) str
, 1, str_len
);
3109 replace_range (pos
, pos
+ 1, string
, 1, 0, 1);
3114 record_change (pos
, 1);
3115 while (str_len
-- > 0)
3117 signal_after_change (pos
, 1, 1);
3118 update_compositions (pos
, pos
+ 1, CHECK_BORDER
);
3128 val
= check_translation (pos
, pos_byte
, end_pos
, val
);
3135 /* VAL is ([FROM-CHAR ...] . TO). */
3136 len
= ASIZE (XCAR (val
));
3144 string
= Fconcat (1, &val
);
3148 string
= Fmake_string (make_number (1), val
);
3150 replace_range (pos
, pos
+ len
, string
, 1, 0, 1);
3151 pos_byte
+= SBYTES (string
);
3152 pos
+= SCHARS (string
);
3153 cnt
+= SCHARS (string
);
3154 end_pos
+= SCHARS (string
) - len
;
3162 return make_number (cnt
);
3165 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
3166 doc
: /* Delete the text between START and END.
3167 If called interactively, delete the region between point and mark.
3168 This command deletes buffer text without modifying the kill ring. */)
3169 (Lisp_Object start
, Lisp_Object end
)
3171 validate_region (&start
, &end
);
3172 del_range (XINT (start
), XINT (end
));
3176 DEFUN ("delete-and-extract-region", Fdelete_and_extract_region
,
3177 Sdelete_and_extract_region
, 2, 2, 0,
3178 doc
: /* Delete the text between START and END and return it. */)
3179 (Lisp_Object start
, Lisp_Object end
)
3181 validate_region (&start
, &end
);
3182 if (XINT (start
) == XINT (end
))
3183 return empty_unibyte_string
;
3184 return del_range_1 (XINT (start
), XINT (end
), 1, 1);
3187 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
3188 doc
: /* Remove restrictions (narrowing) from current buffer.
3189 This allows the buffer's full text to be seen and edited. */)
3192 if (BEG
!= BEGV
|| Z
!= ZV
)
3193 current_buffer
->clip_changed
= 1;
3195 BEGV_BYTE
= BEG_BYTE
;
3196 SET_BUF_ZV_BOTH (current_buffer
, Z
, Z_BYTE
);
3197 /* Changing the buffer bounds invalidates any recorded current column. */
3198 invalidate_current_column ();
3202 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
3203 doc
: /* Restrict editing in this buffer to the current region.
3204 The rest of the text becomes temporarily invisible and untouchable
3205 but is not deleted; if you save the buffer in a file, the invisible
3206 text is included in the file. \\[widen] makes all visible again.
3207 See also `save-restriction'.
3209 When calling from a program, pass two arguments; positions (integers
3210 or markers) bounding the text that should remain visible. */)
3211 (register Lisp_Object start
, Lisp_Object end
)
3213 CHECK_NUMBER_COERCE_MARKER (start
);
3214 CHECK_NUMBER_COERCE_MARKER (end
);
3216 if (XINT (start
) > XINT (end
))
3219 tem
= start
; start
= end
; end
= tem
;
3222 if (!(BEG
<= XINT (start
) && XINT (start
) <= XINT (end
) && XINT (end
) <= Z
))
3223 args_out_of_range (start
, end
);
3225 if (BEGV
!= XFASTINT (start
) || ZV
!= XFASTINT (end
))
3226 current_buffer
->clip_changed
= 1;
3228 SET_BUF_BEGV (current_buffer
, XFASTINT (start
));
3229 SET_BUF_ZV (current_buffer
, XFASTINT (end
));
3230 if (PT
< XFASTINT (start
))
3231 SET_PT (XFASTINT (start
));
3232 if (PT
> XFASTINT (end
))
3233 SET_PT (XFASTINT (end
));
3234 /* Changing the buffer bounds invalidates any recorded current column. */
3235 invalidate_current_column ();
3240 save_restriction_save (void)
3242 if (BEGV
== BEG
&& ZV
== Z
)
3243 /* The common case that the buffer isn't narrowed.
3244 We return just the buffer object, which save_restriction_restore
3245 recognizes as meaning `no restriction'. */
3246 return Fcurrent_buffer ();
3248 /* We have to save a restriction, so return a pair of markers, one
3249 for the beginning and one for the end. */
3251 Lisp_Object beg
, end
;
3253 beg
= buildmark (BEGV
, BEGV_BYTE
);
3254 end
= buildmark (ZV
, ZV_BYTE
);
3256 /* END must move forward if text is inserted at its exact location. */
3257 XMARKER (end
)->insertion_type
= 1;
3259 return Fcons (beg
, end
);
3264 save_restriction_restore (Lisp_Object data
)
3266 struct buffer
*cur
= NULL
;
3267 struct buffer
*buf
= (CONSP (data
)
3268 ? XMARKER (XCAR (data
))->buffer
3271 if (buf
&& buf
!= current_buffer
&& !NILP (BVAR (buf
, pt_marker
)))
3272 { /* If `buf' uses markers to keep track of PT, BEGV, and ZV (as
3273 is the case if it is or has an indirect buffer), then make
3274 sure it is current before we update BEGV, so
3275 set_buffer_internal takes care of managing those markers. */
3276 cur
= current_buffer
;
3277 set_buffer_internal (buf
);
3281 /* A pair of marks bounding a saved restriction. */
3283 struct Lisp_Marker
*beg
= XMARKER (XCAR (data
));
3284 struct Lisp_Marker
*end
= XMARKER (XCDR (data
));
3285 eassert (buf
== end
->buffer
);
3287 if (buf
/* Verify marker still points to a buffer. */
3288 && (beg
->charpos
!= BUF_BEGV (buf
) || end
->charpos
!= BUF_ZV (buf
)))
3289 /* The restriction has changed from the saved one, so restore
3290 the saved restriction. */
3292 EMACS_INT pt
= BUF_PT (buf
);
3294 SET_BUF_BEGV_BOTH (buf
, beg
->charpos
, beg
->bytepos
);
3295 SET_BUF_ZV_BOTH (buf
, end
->charpos
, end
->bytepos
);
3297 if (pt
< beg
->charpos
|| pt
> end
->charpos
)
3298 /* The point is outside the new visible range, move it inside. */
3299 SET_BUF_PT_BOTH (buf
,
3300 clip_to_bounds (beg
->charpos
, pt
, end
->charpos
),
3301 clip_to_bounds (beg
->bytepos
, BUF_PT_BYTE (buf
),
3304 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3308 /* A buffer, which means that there was no old restriction. */
3310 if (buf
/* Verify marker still points to a buffer. */
3311 && (BUF_BEGV (buf
) != BUF_BEG (buf
) || BUF_ZV (buf
) != BUF_Z (buf
)))
3312 /* The buffer has been narrowed, get rid of the narrowing. */
3314 SET_BUF_BEGV_BOTH (buf
, BUF_BEG (buf
), BUF_BEG_BYTE (buf
));
3315 SET_BUF_ZV_BOTH (buf
, BUF_Z (buf
), BUF_Z_BYTE (buf
));
3317 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3321 /* Changing the buffer bounds invalidates any recorded current column. */
3322 invalidate_current_column ();
3325 set_buffer_internal (cur
);
3330 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
3331 doc
: /* Execute BODY, saving and restoring current buffer's restrictions.
3332 The buffer's restrictions make parts of the beginning and end invisible.
3333 \(They are set up with `narrow-to-region' and eliminated with `widen'.)
3334 This special form, `save-restriction', saves the current buffer's restrictions
3335 when it is entered, and restores them when it is exited.
3336 So any `narrow-to-region' within BODY lasts only until the end of the form.
3337 The old restrictions settings are restored
3338 even in case of abnormal exit (throw or error).
3340 The value returned is the value of the last form in BODY.
3342 Note: if you are using both `save-excursion' and `save-restriction',
3343 use `save-excursion' outermost:
3344 (save-excursion (save-restriction ...))
3346 usage: (save-restriction &rest BODY) */)
3349 register Lisp_Object val
;
3350 int count
= SPECPDL_INDEX ();
3352 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
3353 val
= Fprogn (body
);
3354 return unbind_to (count
, val
);
3357 /* Buffer for the most recent text displayed by Fmessage_box. */
3358 static char *message_text
;
3360 /* Allocated length of that buffer. */
3361 static ptrdiff_t message_length
;
3363 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
3364 doc
: /* Display a message at the bottom of the screen.
3365 The message also goes into the `*Messages*' buffer.
3366 \(In keyboard macros, that's all it does.)
3369 The first argument is a format control string, and the rest are data
3370 to be formatted under control of the string. See `format' for details.
3372 Note: Use (message "%s" VALUE) to print the value of expressions and
3373 variables to avoid accidentally interpreting `%' as format specifiers.
3375 If the first argument is nil or the empty string, the function clears
3376 any existing message; this lets the minibuffer contents show. See
3377 also `current-message'.
3379 usage: (message FORMAT-STRING &rest ARGS) */)
3380 (ptrdiff_t nargs
, Lisp_Object
*args
)
3383 || (STRINGP (args
[0])
3384 && SBYTES (args
[0]) == 0))
3391 register Lisp_Object val
;
3392 val
= Fformat (nargs
, args
);
3393 message3 (val
, SBYTES (val
), STRING_MULTIBYTE (val
));
3398 DEFUN ("message-box", Fmessage_box
, Smessage_box
, 1, MANY
, 0,
3399 doc
: /* Display a message, in a dialog box if possible.
3400 If a dialog box is not available, use the echo area.
3401 The first argument is a format control string, and the rest are data
3402 to be formatted under control of the string. See `format' for details.
3404 If the first argument is nil or the empty string, clear any existing
3405 message; let the minibuffer contents show.
3407 usage: (message-box FORMAT-STRING &rest ARGS) */)
3408 (ptrdiff_t nargs
, Lisp_Object
*args
)
3417 register Lisp_Object val
;
3418 val
= Fformat (nargs
, args
);
3420 /* The MS-DOS frames support popup menus even though they are
3421 not FRAME_WINDOW_P. */
3422 if (FRAME_WINDOW_P (XFRAME (selected_frame
))
3423 || FRAME_MSDOS_P (XFRAME (selected_frame
)))
3425 Lisp_Object pane
, menu
;
3426 struct gcpro gcpro1
;
3427 pane
= Fcons (Fcons (build_string ("OK"), Qt
), Qnil
);
3429 menu
= Fcons (val
, pane
);
3430 Fx_popup_dialog (Qt
, menu
, Qt
);
3434 #endif /* HAVE_MENUS */
3435 /* Copy the data so that it won't move when we GC. */
3438 message_text
= (char *)xmalloc (80);
3439 message_length
= 80;
3441 if (SBYTES (val
) > message_length
)
3443 message_text
= (char *) xrealloc (message_text
, SBYTES (val
));
3444 message_length
= SBYTES (val
);
3446 memcpy (message_text
, SDATA (val
), SBYTES (val
));
3447 message2 (message_text
, SBYTES (val
),
3448 STRING_MULTIBYTE (val
));
3453 DEFUN ("message-or-box", Fmessage_or_box
, Smessage_or_box
, 1, MANY
, 0,
3454 doc
: /* Display a message in a dialog box or in the echo area.
3455 If this command was invoked with the mouse, use a dialog box if
3456 `use-dialog-box' is non-nil.
3457 Otherwise, use the echo area.
3458 The first argument is a format control string, and the rest are data
3459 to be formatted under control of the string. See `format' for details.
3461 If the first argument is nil or the empty string, clear any existing
3462 message; let the minibuffer contents show.
3464 usage: (message-or-box FORMAT-STRING &rest ARGS) */)
3465 (ptrdiff_t nargs
, Lisp_Object
*args
)
3468 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3470 return Fmessage_box (nargs
, args
);
3472 return Fmessage (nargs
, args
);
3475 DEFUN ("current-message", Fcurrent_message
, Scurrent_message
, 0, 0, 0,
3476 doc
: /* Return the string currently displayed in the echo area, or nil if none. */)
3479 return current_message ();
3483 DEFUN ("propertize", Fpropertize
, Spropertize
, 1, MANY
, 0,
3484 doc
: /* Return a copy of STRING with text properties added.
3485 First argument is the string to copy.
3486 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
3487 properties to add to the result.
3488 usage: (propertize STRING &rest PROPERTIES) */)
3489 (ptrdiff_t nargs
, Lisp_Object
*args
)
3491 Lisp_Object properties
, string
;
3492 struct gcpro gcpro1
, gcpro2
;
3495 /* Number of args must be odd. */
3496 if ((nargs
& 1) == 0)
3497 error ("Wrong number of arguments");
3499 properties
= string
= Qnil
;
3500 GCPRO2 (properties
, string
);
3502 /* First argument must be a string. */
3503 CHECK_STRING (args
[0]);
3504 string
= Fcopy_sequence (args
[0]);
3506 for (i
= 1; i
< nargs
; i
+= 2)
3507 properties
= Fcons (args
[i
], Fcons (args
[i
+ 1], properties
));
3509 Fadd_text_properties (make_number (0),
3510 make_number (SCHARS (string
)),
3511 properties
, string
);
3512 RETURN_UNGCPRO (string
);
3515 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
3516 doc
: /* Format a string out of a format-string and arguments.
3517 The first argument is a format control string.
3518 The other arguments are substituted into it to make the result, a string.
3520 The format control string may contain %-sequences meaning to substitute
3521 the next available argument:
3523 %s means print a string argument. Actually, prints any object, with `princ'.
3524 %d means print as number in decimal (%o octal, %x hex).
3525 %X is like %x, but uses upper case.
3526 %e means print a number in exponential notation.
3527 %f means print a number in decimal-point notation.
3528 %g means print a number in exponential notation
3529 or decimal-point notation, whichever uses fewer characters.
3530 %c means print a number as a single character.
3531 %S means print any object as an s-expression (using `prin1').
3533 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.
3534 Use %% to put a single % into the output.
3536 A %-sequence may contain optional flag, width, and precision
3537 specifiers, as follows:
3539 %<flags><width><precision>character
3541 where flags is [+ #-0]+, width is [0-9]+, and precision is .[0-9]+
3543 The + flag character inserts a + before any positive number, while a
3544 space inserts a space before any positive number; these flags only
3545 affect %d, %e, %f, and %g sequences, and the + flag takes precedence.
3546 The # flag means to use an alternate display form for %o, %x, %X, %e,
3547 %f, and %g sequences. The - and 0 flags affect the width specifier,
3550 The width specifier supplies a lower limit for the length of the
3551 printed representation. The padding, if any, normally goes on the
3552 left, but it goes on the right if the - flag is present. The padding
3553 character is normally a space, but it is 0 if the 0 flag is present.
3554 The 0 flag is ignored if the - flag is present, or the format sequence
3555 is something other than %d, %e, %f, and %g.
3557 For %e, %f, and %g sequences, the number after the "." in the
3558 precision specifier says how many decimal places to show; if zero, the
3559 decimal point itself is omitted. For %s and %S, the precision
3560 specifier truncates the string to the given width.
3562 usage: (format STRING &rest OBJECTS) */)
3563 (ptrdiff_t nargs
, Lisp_Object
*args
)
3565 ptrdiff_t n
; /* The number of the next arg to substitute */
3566 char initial_buffer
[4000];
3567 char *buf
= initial_buffer
;
3568 EMACS_INT bufsize
= sizeof initial_buffer
;
3569 EMACS_INT max_bufsize
= STRING_BYTES_BOUND
+ 1;
3571 Lisp_Object buf_save_value
IF_LINT (= {0});
3572 register char *format
, *end
, *format_start
;
3573 EMACS_INT formatlen
, nchars
;
3574 /* Nonzero if the format is multibyte. */
3575 int multibyte_format
= 0;
3576 /* Nonzero if the output should be a multibyte string,
3577 which is true if any of the inputs is one. */
3579 /* When we make a multibyte string, we must pay attention to the
3580 byte combining problem, i.e., a byte may be combined with a
3581 multibyte character of the previous string. This flag tells if we
3582 must consider such a situation or not. */
3583 int maybe_combine_byte
;
3585 int arg_intervals
= 0;
3588 /* discarded[I] is 1 if byte I of the format
3589 string was not copied into the output.
3590 It is 2 if byte I was not the first byte of its character. */
3593 /* Each element records, for one argument,
3594 the start and end bytepos in the output string,
3595 whether the argument has been converted to string (e.g., due to "%S"),
3596 and whether the argument is a string with intervals.
3597 info[0] is unused. Unused elements have -1 for start. */
3600 EMACS_INT start
, end
;
3601 int converted_to_string
;
3605 /* It should not be necessary to GCPRO ARGS, because
3606 the caller in the interpreter should take care of that. */
3608 CHECK_STRING (args
[0]);
3609 format_start
= SSDATA (args
[0]);
3610 formatlen
= SBYTES (args
[0]);
3612 /* Allocate the info and discarded tables. */
3615 if ((SIZE_MAX
- formatlen
) / sizeof (struct info
) <= nargs
)
3616 memory_full (SIZE_MAX
);
3617 SAFE_ALLOCA (info
, struct info
*, (nargs
+ 1) * sizeof *info
+ formatlen
);
3618 discarded
= (char *) &info
[nargs
+ 1];
3619 for (i
= 0; i
< nargs
+ 1; i
++)
3622 info
[i
].intervals
= info
[i
].converted_to_string
= 0;
3624 memset (discarded
, 0, formatlen
);
3627 /* Try to determine whether the result should be multibyte.
3628 This is not always right; sometimes the result needs to be multibyte
3629 because of an object that we will pass through prin1,
3630 and in that case, we won't know it here. */
3631 multibyte_format
= STRING_MULTIBYTE (args
[0]);
3632 multibyte
= multibyte_format
;
3633 for (n
= 1; !multibyte
&& n
< nargs
; n
++)
3634 if (STRINGP (args
[n
]) && STRING_MULTIBYTE (args
[n
]))
3637 /* If we start out planning a unibyte result,
3638 then discover it has to be multibyte, we jump back to retry. */
3645 /* Scan the format and store result in BUF. */
3646 format
= format_start
;
3647 end
= format
+ formatlen
;
3648 maybe_combine_byte
= 0;
3650 while (format
!= end
)
3652 /* The values of N and FORMAT when the loop body is entered. */
3654 char *format0
= format
;
3656 /* Bytes needed to represent the output of this conversion. */
3657 EMACS_INT convbytes
;
3661 /* General format specifications look like
3663 '%' [flags] [field-width] [precision] format
3668 field-width ::= [0-9]+
3669 precision ::= '.' [0-9]*
3671 If a field-width is specified, it specifies to which width
3672 the output should be padded with blanks, if the output
3673 string is shorter than field-width.
3675 If precision is specified, it specifies the number of
3676 digits to print after the '.' for floats, or the max.
3677 number of chars to print from a string. */
3684 EMACS_INT field_width
;
3685 int precision_given
;
3686 uintmax_t precision
= UINTMAX_MAX
;
3694 case '-': minus_flag
= 1; continue;
3695 case '+': plus_flag
= 1; continue;
3696 case ' ': space_flag
= 1; continue;
3697 case '#': sharp_flag
= 1; continue;
3698 case '0': zero_flag
= 1; continue;
3703 /* Ignore flags when sprintf ignores them. */
3704 space_flag
&= ~ plus_flag
;
3705 zero_flag
&= ~ minus_flag
;
3708 uintmax_t w
= strtoumax (format
, &num_end
, 10);
3709 if (max_bufsize
<= w
)
3713 precision_given
= *num_end
== '.';
3714 if (precision_given
)
3715 precision
= strtoumax (num_end
+ 1, &num_end
, 10);
3719 error ("Format string ends in middle of format specifier");
3721 memset (&discarded
[format0
- format_start
], 1, format
- format0
);
3722 conversion
= *format
;
3723 if (conversion
== '%')
3725 discarded
[format
- format_start
] = 1;
3730 error ("Not enough arguments for format string");
3732 /* For 'S', prin1 the argument, and then treat like 's'.
3733 For 's', princ any argument that is not a string or
3734 symbol. But don't do this conversion twice, which might
3735 happen after retrying. */
3736 if ((conversion
== 'S'
3737 || (conversion
== 's'
3738 && ! STRINGP (args
[n
]) && ! SYMBOLP (args
[n
]))))
3740 if (! info
[n
].converted_to_string
)
3742 Lisp_Object noescape
= conversion
== 'S' ? Qnil
: Qt
;
3743 args
[n
] = Fprin1_to_string (args
[n
], noescape
);
3744 info
[n
].converted_to_string
= 1;
3745 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
3753 else if (conversion
== 'c')
3755 if (FLOATP (args
[n
]))
3757 double d
= XFLOAT_DATA (args
[n
]);
3758 args
[n
] = make_number (FIXNUM_OVERFLOW_P (d
) ? -1 : d
);
3761 if (INTEGERP (args
[n
]) && ! ASCII_CHAR_P (XINT (args
[n
])))
3768 args
[n
] = Fchar_to_string (args
[n
]);
3769 info
[n
].converted_to_string
= 1;
3772 if (info
[n
].converted_to_string
)
3777 if (SYMBOLP (args
[n
]))
3779 args
[n
] = SYMBOL_NAME (args
[n
]);
3780 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
3787 if (conversion
== 's')
3789 /* handle case (precision[n] >= 0) */
3791 EMACS_INT width
, padding
, nbytes
;
3792 EMACS_INT nchars_string
;
3794 EMACS_INT prec
= -1;
3795 if (precision_given
&& precision
<= TYPE_MAXIMUM (EMACS_INT
))
3798 /* lisp_string_width ignores a precision of 0, but GNU
3799 libc functions print 0 characters when the precision
3800 is 0. Imitate libc behavior here. Changing
3801 lisp_string_width is the right thing, and will be
3802 done, but meanwhile we work with it. */
3805 width
= nchars_string
= nbytes
= 0;
3809 width
= lisp_string_width (args
[n
], prec
, &nch
, &nby
);
3812 nchars_string
= SCHARS (args
[n
]);
3813 nbytes
= SBYTES (args
[n
]);
3817 nchars_string
= nch
;
3823 if (convbytes
&& multibyte
&& ! STRING_MULTIBYTE (args
[n
]))
3824 convbytes
= count_size_as_multibyte (SDATA (args
[n
]), nbytes
);
3826 padding
= width
< field_width
? field_width
- width
: 0;
3828 if (max_bufsize
- padding
<= convbytes
)
3830 convbytes
+= padding
;
3831 if (convbytes
<= buf
+ bufsize
- p
)
3835 memset (p
, ' ', padding
);
3842 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3843 && STRING_MULTIBYTE (args
[n
])
3844 && !CHAR_HEAD_P (SREF (args
[n
], 0)))
3845 maybe_combine_byte
= 1;
3847 p
+= copy_text (SDATA (args
[n
]), (unsigned char *) p
,
3849 STRING_MULTIBYTE (args
[n
]), multibyte
);
3851 info
[n
].start
= nchars
;
3852 nchars
+= nchars_string
;
3853 info
[n
].end
= nchars
;
3857 memset (p
, ' ', padding
);
3862 /* If this argument has text properties, record where
3863 in the result string it appears. */
3864 if (STRING_INTERVALS (args
[n
]))
3865 info
[n
].intervals
= arg_intervals
= 1;
3870 else if (! (conversion
== 'c' || conversion
== 'd'
3871 || conversion
== 'e' || conversion
== 'f'
3872 || conversion
== 'g' || conversion
== 'i'
3873 || conversion
== 'o' || conversion
== 'x'
3874 || conversion
== 'X'))
3875 error ("Invalid format operation %%%c",
3876 STRING_CHAR ((unsigned char *) format
- 1));
3877 else if (! (INTEGERP (args
[n
]) || FLOATP (args
[n
])))
3878 error ("Format specifier doesn't match argument type");
3883 /* Maximum precision for a %f conversion such that the
3884 trailing output digit might be nonzero. Any precisions
3885 larger than this will not yield useful information. */
3886 USEFUL_PRECISION_MAX
=
3888 * (FLT_RADIX
== 2 || FLT_RADIX
== 10 ? 1
3889 : FLT_RADIX
== 16 ? 4
3892 /* Maximum number of bytes generated by any format, if
3893 precision is no more than USEFUL_PRECISION_MAX.
3894 On all practical hosts, %f is the worst case. */
3896 sizeof "-." + (DBL_MAX_10_EXP
+ 1) + USEFUL_PRECISION_MAX
,
3898 /* Length of pM (that is, of pMd without the
3900 pMlen
= sizeof pMd
- 2
3902 verify (0 < USEFUL_PRECISION_MAX
);
3905 EMACS_INT padding
, sprintf_bytes
;
3906 uintmax_t excess_precision
, numwidth
;
3907 uintmax_t leading_zeros
= 0, trailing_zeros
= 0;
3909 char sprintf_buf
[SPRINTF_BUFSIZE
];
3911 /* Copy of conversion specification, modified somewhat.
3912 At most three flags F can be specified at once. */
3913 char convspec
[sizeof "%FFF.*d" + pMlen
];
3915 /* Avoid undefined behavior in underlying sprintf. */
3916 if (conversion
== 'd' || conversion
== 'i')
3919 /* Create the copy of the conversion specification, with
3920 any width and precision removed, with ".*" inserted,
3921 and with pM inserted for integer formats. */
3925 *f
= '-'; f
+= minus_flag
;
3926 *f
= '+'; f
+= plus_flag
;
3927 *f
= ' '; f
+= space_flag
;
3928 *f
= '#'; f
+= sharp_flag
;
3929 *f
= '0'; f
+= zero_flag
;
3932 if (conversion
== 'd' || conversion
== 'i'
3933 || conversion
== 'o' || conversion
== 'x'
3934 || conversion
== 'X')
3936 memcpy (f
, pMd
, pMlen
);
3938 zero_flag
&= ~ precision_given
;
3945 if (precision_given
)
3946 prec
= min (precision
, USEFUL_PRECISION_MAX
);
3948 /* Use sprintf to format this number into sprintf_buf. Omit
3949 padding and excess precision, though, because sprintf limits
3950 output length to INT_MAX.
3952 There are four types of conversion: double, unsigned
3953 char (passed as int), wide signed int, and wide
3954 unsigned int. Treat them separately because the
3955 sprintf ABI is sensitive to which type is passed. Be
3956 careful about integer overflow, NaNs, infinities, and
3957 conversions; for example, the min and max macros are
3958 not suitable here. */
3959 if (conversion
== 'e' || conversion
== 'f' || conversion
== 'g')
3961 double x
= (INTEGERP (args
[n
])
3963 : XFLOAT_DATA (args
[n
]));
3964 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
3966 else if (conversion
== 'c')
3968 /* Don't use sprintf here, as it might mishandle prec. */
3969 sprintf_buf
[0] = XINT (args
[n
]);
3970 sprintf_bytes
= prec
!= 0;
3972 else if (conversion
== 'd')
3974 /* For float, maybe we should use "%1.0f"
3975 instead so it also works for values outside
3976 the integer range. */
3978 if (INTEGERP (args
[n
]))
3982 double d
= XFLOAT_DATA (args
[n
]);
3985 x
= TYPE_MINIMUM (printmax_t
);
3991 x
= TYPE_MAXIMUM (printmax_t
);
3996 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4000 /* Don't sign-extend for octal or hex printing. */
4002 if (INTEGERP (args
[n
]))
4003 x
= XUINT (args
[n
]);
4006 double d
= XFLOAT_DATA (args
[n
]);
4011 x
= TYPE_MAXIMUM (uprintmax_t
);
4016 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4019 /* Now the length of the formatted item is known, except it omits
4020 padding and excess precision. Deal with excess precision
4021 first. This happens only when the format specifies
4022 ridiculously large precision. */
4023 excess_precision
= precision
- prec
;
4024 if (excess_precision
)
4026 if (conversion
== 'e' || conversion
== 'f'
4027 || conversion
== 'g')
4029 if ((conversion
== 'g' && ! sharp_flag
)
4030 || ! ('0' <= sprintf_buf
[sprintf_bytes
- 1]
4031 && sprintf_buf
[sprintf_bytes
- 1] <= '9'))
4032 excess_precision
= 0;
4035 if (conversion
== 'g')
4037 char *dot
= strchr (sprintf_buf
, '.');
4039 excess_precision
= 0;
4042 trailing_zeros
= excess_precision
;
4045 leading_zeros
= excess_precision
;
4048 /* Compute the total bytes needed for this item, including
4049 excess precision and padding. */
4050 numwidth
= sprintf_bytes
+ excess_precision
;
4051 padding
= numwidth
< field_width
? field_width
- numwidth
: 0;
4052 if (max_bufsize
- sprintf_bytes
<= excess_precision
4053 || max_bufsize
- padding
<= numwidth
)
4055 convbytes
= numwidth
+ padding
;
4057 if (convbytes
<= buf
+ bufsize
- p
)
4059 /* Copy the formatted item from sprintf_buf into buf,
4060 inserting padding and excess-precision zeros. */
4062 char *src
= sprintf_buf
;
4064 int exponent_bytes
= 0;
4065 int signedp
= src0
== '-' || src0
== '+' || src0
== ' ';
4066 int significand_bytes
;
4068 && ((src
[signedp
] >= '0' && src
[signedp
] <= '9')
4069 || (src
[signedp
] >= 'a' && src
[signedp
] <= 'f')
4070 || (src
[signedp
] >= 'A' && src
[signedp
] <= 'F')))
4072 leading_zeros
+= padding
;
4076 if (excess_precision
4077 && (conversion
== 'e' || conversion
== 'g'))
4079 char *e
= strchr (src
, 'e');
4081 exponent_bytes
= src
+ sprintf_bytes
- e
;
4086 memset (p
, ' ', padding
);
4094 memset (p
, '0', leading_zeros
);
4096 significand_bytes
= sprintf_bytes
- signedp
- exponent_bytes
;
4097 memcpy (p
, src
, significand_bytes
);
4098 p
+= significand_bytes
;
4099 src
+= significand_bytes
;
4100 memset (p
, '0', trailing_zeros
);
4101 p
+= trailing_zeros
;
4102 memcpy (p
, src
, exponent_bytes
);
4103 p
+= exponent_bytes
;
4105 info
[n
].start
= nchars
;
4106 nchars
+= leading_zeros
+ sprintf_bytes
+ trailing_zeros
;
4107 info
[n
].end
= nchars
;
4111 memset (p
, ' ', padding
);
4123 /* Copy a single character from format to buf. */
4126 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
4128 if (multibyte_format
)
4130 /* Copy a whole multibyte character. */
4132 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
4133 && !CHAR_HEAD_P (*format
))
4134 maybe_combine_byte
= 1;
4138 while (! CHAR_HEAD_P (*format
));
4140 convbytes
= format
- src
;
4141 memset (&discarded
[src
+ 1 - format_start
], 2, convbytes
- 1);
4145 unsigned char uc
= *format
++;
4146 if (! multibyte
|| ASCII_BYTE_P (uc
))
4150 int c
= BYTE8_TO_CHAR (uc
);
4151 convbytes
= CHAR_STRING (c
, str
);
4156 if (convbytes
<= buf
+ bufsize
- p
)
4158 memcpy (p
, src
, convbytes
);
4165 /* There wasn't enough room to store this conversion or single
4166 character. CONVBYTES says how much room is needed. Allocate
4167 enough room (and then some) and do it again. */
4169 ptrdiff_t used
= p
- buf
;
4171 if (max_bufsize
- used
< convbytes
)
4173 bufsize
= used
+ convbytes
;
4174 bufsize
= bufsize
< max_bufsize
/ 2 ? bufsize
* 2 : max_bufsize
;
4176 if (buf
== initial_buffer
)
4178 buf
= xmalloc (bufsize
);
4180 buf_save_value
= make_save_value (buf
, 0);
4181 record_unwind_protect (safe_alloca_unwind
, buf_save_value
);
4182 memcpy (buf
, initial_buffer
, used
);
4185 XSAVE_VALUE (buf_save_value
)->pointer
= buf
= xrealloc (buf
, bufsize
);
4194 if (bufsize
< p
- buf
)
4197 if (maybe_combine_byte
)
4198 nchars
= multibyte_chars_in_text ((unsigned char *) buf
, p
- buf
);
4199 val
= make_specified_string (buf
, nchars
, p
- buf
, multibyte
);
4201 /* If we allocated BUF with malloc, free it too. */
4204 /* If the format string has text properties, or any of the string
4205 arguments has text properties, set up text properties of the
4208 if (STRING_INTERVALS (args
[0]) || arg_intervals
)
4210 Lisp_Object len
, new_len
, props
;
4211 struct gcpro gcpro1
;
4213 /* Add text properties from the format string. */
4214 len
= make_number (SCHARS (args
[0]));
4215 props
= text_property_list (args
[0], make_number (0), len
, Qnil
);
4220 EMACS_INT bytepos
= 0, position
= 0, translated
= 0;
4224 /* Adjust the bounds of each text property
4225 to the proper start and end in the output string. */
4227 /* Put the positions in PROPS in increasing order, so that
4228 we can do (effectively) one scan through the position
4229 space of the format string. */
4230 props
= Fnreverse (props
);
4232 /* BYTEPOS is the byte position in the format string,
4233 POSITION is the untranslated char position in it,
4234 TRANSLATED is the translated char position in BUF,
4235 and ARGN is the number of the next arg we will come to. */
4236 for (list
= props
; CONSP (list
); list
= XCDR (list
))
4243 /* First adjust the property start position. */
4244 pos
= XINT (XCAR (item
));
4246 /* Advance BYTEPOS, POSITION, TRANSLATED and ARGN
4247 up to this position. */
4248 for (; position
< pos
; bytepos
++)
4250 if (! discarded
[bytepos
])
4251 position
++, translated
++;
4252 else if (discarded
[bytepos
] == 1)
4255 if (translated
== info
[argn
].start
)
4257 translated
+= info
[argn
].end
- info
[argn
].start
;
4263 XSETCAR (item
, make_number (translated
));
4265 /* Likewise adjust the property end position. */
4266 pos
= XINT (XCAR (XCDR (item
)));
4268 for (; position
< pos
; bytepos
++)
4270 if (! discarded
[bytepos
])
4271 position
++, translated
++;
4272 else if (discarded
[bytepos
] == 1)
4275 if (translated
== info
[argn
].start
)
4277 translated
+= info
[argn
].end
- info
[argn
].start
;
4283 XSETCAR (XCDR (item
), make_number (translated
));
4286 add_text_properties_from_list (val
, props
, make_number (0));
4289 /* Add text properties from arguments. */
4291 for (n
= 1; n
< nargs
; ++n
)
4292 if (info
[n
].intervals
)
4294 len
= make_number (SCHARS (args
[n
]));
4295 new_len
= make_number (info
[n
].end
- info
[n
].start
);
4296 props
= text_property_list (args
[n
], make_number (0), len
, Qnil
);
4297 props
= extend_property_ranges (props
, new_len
);
4298 /* If successive arguments have properties, be sure that
4299 the value of `composition' property be the copy. */
4300 if (n
> 1 && info
[n
- 1].end
)
4301 make_composition_value_copy (props
);
4302 add_text_properties_from_list (val
, props
,
4303 make_number (info
[n
].start
));
4313 format2 (const char *string1
, Lisp_Object arg0
, Lisp_Object arg1
)
4315 Lisp_Object args
[3];
4316 args
[0] = build_string (string1
);
4319 return Fformat (3, args
);
4322 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
4323 doc
: /* Return t if two characters match, optionally ignoring case.
4324 Both arguments must be characters (i.e. integers).
4325 Case is ignored if `case-fold-search' is non-nil in the current buffer. */)
4326 (register Lisp_Object c1
, Lisp_Object c2
)
4329 /* Check they're chars, not just integers, otherwise we could get array
4330 bounds violations in downcase. */
4331 CHECK_CHARACTER (c1
);
4332 CHECK_CHARACTER (c2
);
4334 if (XINT (c1
) == XINT (c2
))
4336 if (NILP (BVAR (current_buffer
, case_fold_search
)))
4340 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
))
4341 && ! ASCII_CHAR_P (i1
))
4343 MAKE_CHAR_MULTIBYTE (i1
);
4346 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
))
4347 && ! ASCII_CHAR_P (i2
))
4349 MAKE_CHAR_MULTIBYTE (i2
);
4351 return (downcase (i1
) == downcase (i2
) ? Qt
: Qnil
);
4354 /* Transpose the markers in two regions of the current buffer, and
4355 adjust the ones between them if necessary (i.e.: if the regions
4358 START1, END1 are the character positions of the first region.
4359 START1_BYTE, END1_BYTE are the byte positions.
4360 START2, END2 are the character positions of the second region.
4361 START2_BYTE, END2_BYTE are the byte positions.
4363 Traverses the entire marker list of the buffer to do so, adding an
4364 appropriate amount to some, subtracting from some, and leaving the
4365 rest untouched. Most of this is copied from adjust_markers in insdel.c.
4367 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
4370 transpose_markers (EMACS_INT start1
, EMACS_INT end1
,
4371 EMACS_INT start2
, EMACS_INT end2
,
4372 EMACS_INT start1_byte
, EMACS_INT end1_byte
,
4373 EMACS_INT start2_byte
, EMACS_INT end2_byte
)
4375 register EMACS_INT amt1
, amt1_byte
, amt2
, amt2_byte
, diff
, diff_byte
, mpos
;
4376 register struct Lisp_Marker
*marker
;
4378 /* Update point as if it were a marker. */
4382 TEMP_SET_PT_BOTH (PT
+ (end2
- end1
),
4383 PT_BYTE
+ (end2_byte
- end1_byte
));
4384 else if (PT
< start2
)
4385 TEMP_SET_PT_BOTH (PT
+ (end2
- start2
) - (end1
- start1
),
4386 (PT_BYTE
+ (end2_byte
- start2_byte
)
4387 - (end1_byte
- start1_byte
)));
4389 TEMP_SET_PT_BOTH (PT
- (start2
- start1
),
4390 PT_BYTE
- (start2_byte
- start1_byte
));
4392 /* We used to adjust the endpoints here to account for the gap, but that
4393 isn't good enough. Even if we assume the caller has tried to move the
4394 gap out of our way, it might still be at start1 exactly, for example;
4395 and that places it `inside' the interval, for our purposes. The amount
4396 of adjustment is nontrivial if there's a `denormalized' marker whose
4397 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
4398 the dirty work to Fmarker_position, below. */
4400 /* The difference between the region's lengths */
4401 diff
= (end2
- start2
) - (end1
- start1
);
4402 diff_byte
= (end2_byte
- start2_byte
) - (end1_byte
- start1_byte
);
4404 /* For shifting each marker in a region by the length of the other
4405 region plus the distance between the regions. */
4406 amt1
= (end2
- start2
) + (start2
- end1
);
4407 amt2
= (end1
- start1
) + (start2
- end1
);
4408 amt1_byte
= (end2_byte
- start2_byte
) + (start2_byte
- end1_byte
);
4409 amt2_byte
= (end1_byte
- start1_byte
) + (start2_byte
- end1_byte
);
4411 for (marker
= BUF_MARKERS (current_buffer
); marker
; marker
= marker
->next
)
4413 mpos
= marker
->bytepos
;
4414 if (mpos
>= start1_byte
&& mpos
< end2_byte
)
4416 if (mpos
< end1_byte
)
4418 else if (mpos
< start2_byte
)
4422 marker
->bytepos
= mpos
;
4424 mpos
= marker
->charpos
;
4425 if (mpos
>= start1
&& mpos
< end2
)
4429 else if (mpos
< start2
)
4434 marker
->charpos
= mpos
;
4438 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
4439 doc
: /* Transpose region STARTR1 to ENDR1 with STARTR2 to ENDR2.
4440 The regions should not be overlapping, because the size of the buffer is
4441 never changed in a transposition.
4443 Optional fifth arg LEAVE-MARKERS, if non-nil, means don't update
4444 any markers that happen to be located in the regions.
4446 Transposing beyond buffer boundaries is an error. */)
4447 (Lisp_Object startr1
, Lisp_Object endr1
, Lisp_Object startr2
, Lisp_Object endr2
, Lisp_Object leave_markers
)
4449 register EMACS_INT start1
, end1
, start2
, end2
;
4450 EMACS_INT start1_byte
, start2_byte
, len1_byte
, len2_byte
;
4451 EMACS_INT gap
, len1
, len_mid
, len2
;
4452 unsigned char *start1_addr
, *start2_addr
, *temp
;
4454 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
, tmp_interval3
;
4457 XSETBUFFER (buf
, current_buffer
);
4458 cur_intv
= BUF_INTERVALS (current_buffer
);
4460 validate_region (&startr1
, &endr1
);
4461 validate_region (&startr2
, &endr2
);
4463 start1
= XFASTINT (startr1
);
4464 end1
= XFASTINT (endr1
);
4465 start2
= XFASTINT (startr2
);
4466 end2
= XFASTINT (endr2
);
4469 /* Swap the regions if they're reversed. */
4472 register EMACS_INT glumph
= start1
;
4480 len1
= end1
- start1
;
4481 len2
= end2
- start2
;
4484 error ("Transposed regions overlap");
4485 /* Nothing to change for adjacent regions with one being empty */
4486 else if ((start1
== end1
|| start2
== end2
) && end1
== start2
)
4489 /* The possibilities are:
4490 1. Adjacent (contiguous) regions, or separate but equal regions
4491 (no, really equal, in this case!), or
4492 2. Separate regions of unequal size.
4494 The worst case is usually No. 2. It means that (aside from
4495 potential need for getting the gap out of the way), there also
4496 needs to be a shifting of the text between the two regions. So
4497 if they are spread far apart, we are that much slower... sigh. */
4499 /* It must be pointed out that the really studly thing to do would
4500 be not to move the gap at all, but to leave it in place and work
4501 around it if necessary. This would be extremely efficient,
4502 especially considering that people are likely to do
4503 transpositions near where they are working interactively, which
4504 is exactly where the gap would be found. However, such code
4505 would be much harder to write and to read. So, if you are
4506 reading this comment and are feeling squirrely, by all means have
4507 a go! I just didn't feel like doing it, so I will simply move
4508 the gap the minimum distance to get it out of the way, and then
4509 deal with an unbroken array. */
4511 /* Make sure the gap won't interfere, by moving it out of the text
4512 we will operate on. */
4513 if (start1
< gap
&& gap
< end2
)
4515 if (gap
- start1
< end2
- gap
)
4521 start1_byte
= CHAR_TO_BYTE (start1
);
4522 start2_byte
= CHAR_TO_BYTE (start2
);
4523 len1_byte
= CHAR_TO_BYTE (end1
) - start1_byte
;
4524 len2_byte
= CHAR_TO_BYTE (end2
) - start2_byte
;
4526 #ifdef BYTE_COMBINING_DEBUG
4529 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4530 len2_byte
, start1
, start1_byte
)
4531 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4532 len1_byte
, end2
, start2_byte
+ len2_byte
)
4533 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4534 len1_byte
, end2
, start2_byte
+ len2_byte
))
4539 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4540 len2_byte
, start1
, start1_byte
)
4541 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4542 len1_byte
, start2
, start2_byte
)
4543 || count_combining_after (BYTE_POS_ADDR (start2_byte
),
4544 len2_byte
, end1
, start1_byte
+ len1_byte
)
4545 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4546 len1_byte
, end2
, start2_byte
+ len2_byte
))
4551 /* Hmmm... how about checking to see if the gap is large
4552 enough to use as the temporary storage? That would avoid an
4553 allocation... interesting. Later, don't fool with it now. */
4555 /* Working without memmove, for portability (sigh), so must be
4556 careful of overlapping subsections of the array... */
4558 if (end1
== start2
) /* adjacent regions */
4560 modify_region (current_buffer
, start1
, end2
, 0);
4561 record_change (start1
, len1
+ len2
);
4563 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4564 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4565 /* Don't use Fset_text_properties: that can cause GC, which can
4566 clobber objects stored in the tmp_intervals. */
4567 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4568 if (!NULL_INTERVAL_P (tmp_interval3
))
4569 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4571 /* First region smaller than second. */
4572 if (len1_byte
< len2_byte
)
4576 SAFE_ALLOCA (temp
, unsigned char *, len2_byte
);
4578 /* Don't precompute these addresses. We have to compute them
4579 at the last minute, because the relocating allocator might
4580 have moved the buffer around during the xmalloc. */
4581 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4582 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4584 memcpy (temp
, start2_addr
, len2_byte
);
4585 memcpy (start1_addr
+ len2_byte
, start1_addr
, len1_byte
);
4586 memcpy (start1_addr
, temp
, len2_byte
);
4590 /* First region not smaller than second. */
4594 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4595 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4596 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4597 memcpy (temp
, start1_addr
, len1_byte
);
4598 memcpy (start1_addr
, start2_addr
, len2_byte
);
4599 memcpy (start1_addr
+ len2_byte
, temp
, len1_byte
);
4602 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
4603 len1
, current_buffer
, 0);
4604 graft_intervals_into_buffer (tmp_interval2
, start1
,
4605 len2
, current_buffer
, 0);
4606 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4607 update_compositions (start1
+ len2
, end2
, CHECK_TAIL
);
4609 /* Non-adjacent regions, because end1 != start2, bleagh... */
4612 len_mid
= start2_byte
- (start1_byte
+ len1_byte
);
4614 if (len1_byte
== len2_byte
)
4615 /* Regions are same size, though, how nice. */
4619 modify_region (current_buffer
, start1
, end1
, 0);
4620 modify_region (current_buffer
, start2
, end2
, 0);
4621 record_change (start1
, len1
);
4622 record_change (start2
, len2
);
4623 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4624 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4626 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr1
, 0);
4627 if (!NULL_INTERVAL_P (tmp_interval3
))
4628 set_text_properties_1 (startr1
, endr1
, Qnil
, buf
, tmp_interval3
);
4630 tmp_interval3
= validate_interval_range (buf
, &startr2
, &endr2
, 0);
4631 if (!NULL_INTERVAL_P (tmp_interval3
))
4632 set_text_properties_1 (startr2
, endr2
, Qnil
, buf
, tmp_interval3
);
4634 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4635 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4636 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4637 memcpy (temp
, start1_addr
, len1_byte
);
4638 memcpy (start1_addr
, start2_addr
, len2_byte
);
4639 memcpy (start2_addr
, temp
, len1_byte
);
4642 graft_intervals_into_buffer (tmp_interval1
, start2
,
4643 len1
, current_buffer
, 0);
4644 graft_intervals_into_buffer (tmp_interval2
, start1
,
4645 len2
, current_buffer
, 0);
4648 else if (len1_byte
< len2_byte
) /* Second region larger than first */
4649 /* Non-adjacent & unequal size, area between must also be shifted. */
4653 modify_region (current_buffer
, start1
, end2
, 0);
4654 record_change (start1
, (end2
- start1
));
4655 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4656 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4657 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4659 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4660 if (!NULL_INTERVAL_P (tmp_interval3
))
4661 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4663 /* holds region 2 */
4664 SAFE_ALLOCA (temp
, unsigned char *, len2_byte
);
4665 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4666 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4667 memcpy (temp
, start2_addr
, len2_byte
);
4668 memcpy (start1_addr
+ len_mid
+ len2_byte
, start1_addr
, len1_byte
);
4669 memmove (start1_addr
+ len2_byte
, start1_addr
+ len1_byte
, len_mid
);
4670 memcpy (start1_addr
, temp
, len2_byte
);
4673 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4674 len1
, current_buffer
, 0);
4675 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4676 len_mid
, current_buffer
, 0);
4677 graft_intervals_into_buffer (tmp_interval2
, start1
,
4678 len2
, current_buffer
, 0);
4681 /* Second region smaller than first. */
4685 record_change (start1
, (end2
- start1
));
4686 modify_region (current_buffer
, start1
, end2
, 0);
4688 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4689 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4690 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4692 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4693 if (!NULL_INTERVAL_P (tmp_interval3
))
4694 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4696 /* holds region 1 */
4697 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4698 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4699 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4700 memcpy (temp
, start1_addr
, len1_byte
);
4701 memcpy (start1_addr
, start2_addr
, len2_byte
);
4702 memcpy (start1_addr
+ len2_byte
, start1_addr
+ len1_byte
, len_mid
);
4703 memcpy (start1_addr
+ len2_byte
+ len_mid
, temp
, len1_byte
);
4706 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4707 len1
, current_buffer
, 0);
4708 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4709 len_mid
, current_buffer
, 0);
4710 graft_intervals_into_buffer (tmp_interval2
, start1
,
4711 len2
, current_buffer
, 0);
4714 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4715 update_compositions (end2
- len1
, end2
, CHECK_BORDER
);
4718 /* When doing multiple transpositions, it might be nice
4719 to optimize this. Perhaps the markers in any one buffer
4720 should be organized in some sorted data tree. */
4721 if (NILP (leave_markers
))
4723 transpose_markers (start1
, end1
, start2
, end2
,
4724 start1_byte
, start1_byte
+ len1_byte
,
4725 start2_byte
, start2_byte
+ len2_byte
);
4726 fix_start_end_in_overlays (start1
, end2
);
4729 signal_after_change (start1
, end2
- start1
, end2
- start1
);
4735 syms_of_editfns (void)
4740 DEFSYM (Qbuffer_access_fontify_functions
, "buffer-access-fontify-functions");
4742 DEFVAR_LISP ("inhibit-field-text-motion", Vinhibit_field_text_motion
,
4743 doc
: /* Non-nil means text motion commands don't notice fields. */);
4744 Vinhibit_field_text_motion
= Qnil
;
4746 DEFVAR_LISP ("buffer-access-fontify-functions",
4747 Vbuffer_access_fontify_functions
,
4748 doc
: /* List of functions called by `buffer-substring' to fontify if necessary.
4749 Each function is called with two arguments which specify the range
4750 of the buffer being accessed. */);
4751 Vbuffer_access_fontify_functions
= Qnil
;
4755 obuf
= Fcurrent_buffer ();
4756 /* Do this here, because init_buffer_once is too early--it won't work. */
4757 Fset_buffer (Vprin1_to_string_buffer
);
4758 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
4759 Fset (Fmake_local_variable (intern_c_string ("buffer-access-fontify-functions")),
4764 DEFVAR_LISP ("buffer-access-fontified-property",
4765 Vbuffer_access_fontified_property
,
4766 doc
: /* Property which (if non-nil) indicates text has been fontified.
4767 `buffer-substring' need not call the `buffer-access-fontify-functions'
4768 functions if all the text being accessed has this property. */);
4769 Vbuffer_access_fontified_property
= Qnil
;
4771 DEFVAR_LISP ("system-name", Vsystem_name
,
4772 doc
: /* The host name of the machine Emacs is running on. */);
4774 DEFVAR_LISP ("user-full-name", Vuser_full_name
,
4775 doc
: /* The full name of the user logged in. */);
4777 DEFVAR_LISP ("user-login-name", Vuser_login_name
,
4778 doc
: /* The user's name, taken from environment variables if possible. */);
4780 DEFVAR_LISP ("user-real-login-name", Vuser_real_login_name
,
4781 doc
: /* The user's name, based upon the real uid only. */);
4783 DEFVAR_LISP ("operating-system-release", Voperating_system_release
,
4784 doc
: /* The release of the operating system Emacs is running on. */);
4786 defsubr (&Spropertize
);
4787 defsubr (&Schar_equal
);
4788 defsubr (&Sgoto_char
);
4789 defsubr (&Sstring_to_char
);
4790 defsubr (&Schar_to_string
);
4791 defsubr (&Sbyte_to_string
);
4792 defsubr (&Sbuffer_substring
);
4793 defsubr (&Sbuffer_substring_no_properties
);
4794 defsubr (&Sbuffer_string
);
4796 defsubr (&Spoint_marker
);
4797 defsubr (&Smark_marker
);
4799 defsubr (&Sregion_beginning
);
4800 defsubr (&Sregion_end
);
4802 DEFSYM (Qfield
, "field");
4803 DEFSYM (Qboundary
, "boundary");
4804 defsubr (&Sfield_beginning
);
4805 defsubr (&Sfield_end
);
4806 defsubr (&Sfield_string
);
4807 defsubr (&Sfield_string_no_properties
);
4808 defsubr (&Sdelete_field
);
4809 defsubr (&Sconstrain_to_field
);
4811 defsubr (&Sline_beginning_position
);
4812 defsubr (&Sline_end_position
);
4814 /* defsubr (&Smark); */
4815 /* defsubr (&Sset_mark); */
4816 defsubr (&Ssave_excursion
);
4817 defsubr (&Ssave_current_buffer
);
4819 defsubr (&Sbufsize
);
4820 defsubr (&Spoint_max
);
4821 defsubr (&Spoint_min
);
4822 defsubr (&Spoint_min_marker
);
4823 defsubr (&Spoint_max_marker
);
4824 defsubr (&Sgap_position
);
4825 defsubr (&Sgap_size
);
4826 defsubr (&Sposition_bytes
);
4827 defsubr (&Sbyte_to_position
);
4833 defsubr (&Sfollowing_char
);
4834 defsubr (&Sprevious_char
);
4835 defsubr (&Schar_after
);
4836 defsubr (&Schar_before
);
4838 defsubr (&Sinsert_before_markers
);
4839 defsubr (&Sinsert_and_inherit
);
4840 defsubr (&Sinsert_and_inherit_before_markers
);
4841 defsubr (&Sinsert_char
);
4842 defsubr (&Sinsert_byte
);
4844 defsubr (&Suser_login_name
);
4845 defsubr (&Suser_real_login_name
);
4846 defsubr (&Suser_uid
);
4847 defsubr (&Suser_real_uid
);
4848 defsubr (&Suser_full_name
);
4849 defsubr (&Semacs_pid
);
4850 defsubr (&Scurrent_time
);
4851 defsubr (&Sget_internal_run_time
);
4852 defsubr (&Sformat_time_string
);
4853 defsubr (&Sfloat_time
);
4854 defsubr (&Sdecode_time
);
4855 defsubr (&Sencode_time
);
4856 defsubr (&Scurrent_time_string
);
4857 defsubr (&Scurrent_time_zone
);
4858 defsubr (&Sset_time_zone_rule
);
4859 defsubr (&Ssystem_name
);
4860 defsubr (&Smessage
);
4861 defsubr (&Smessage_box
);
4862 defsubr (&Smessage_or_box
);
4863 defsubr (&Scurrent_message
);
4866 defsubr (&Sinsert_buffer_substring
);
4867 defsubr (&Scompare_buffer_substrings
);
4868 defsubr (&Ssubst_char_in_region
);
4869 defsubr (&Stranslate_region_internal
);
4870 defsubr (&Sdelete_region
);
4871 defsubr (&Sdelete_and_extract_region
);
4873 defsubr (&Snarrow_to_region
);
4874 defsubr (&Ssave_restriction
);
4875 defsubr (&Stranspose_regions
);