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 (ptrdiff_t, ptrdiff_t);
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
);
150 tem
= Vuser_login_name
;
153 uid_t euid
= geteuid ();
154 tem
= make_fixnum_or_float (euid
);
156 Vuser_full_name
= Fuser_full_name (tem
);
160 Vuser_full_name
= build_string (p
);
161 else if (NILP (Vuser_full_name
))
162 Vuser_full_name
= build_string ("unknown");
164 #ifdef HAVE_SYS_UTSNAME_H
168 Voperating_system_release
= build_string (uts
.release
);
171 Voperating_system_release
= Qnil
;
175 DEFUN ("char-to-string", Fchar_to_string
, Schar_to_string
, 1, 1, 0,
176 doc
: /* Convert arg CHAR to a string containing that character.
177 usage: (char-to-string CHAR) */)
178 (Lisp_Object character
)
181 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
183 CHECK_CHARACTER (character
);
184 c
= XFASTINT (character
);
186 len
= CHAR_STRING (c
, str
);
187 return make_string_from_bytes ((char *) str
, 1, len
);
190 DEFUN ("byte-to-string", Fbyte_to_string
, Sbyte_to_string
, 1, 1, 0,
191 doc
: /* Convert arg BYTE to a unibyte string containing that byte. */)
196 if (XINT (byte
) < 0 || XINT (byte
) > 255)
197 error ("Invalid byte");
199 return make_string_from_bytes ((char *) &b
, 1, 1);
202 DEFUN ("string-to-char", Fstring_to_char
, Sstring_to_char
, 1, 1, 0,
203 doc
: /* Return the first character in STRING. */)
204 (register Lisp_Object string
)
206 register Lisp_Object val
;
207 CHECK_STRING (string
);
210 if (STRING_MULTIBYTE (string
))
211 XSETFASTINT (val
, STRING_CHAR (SDATA (string
)));
213 XSETFASTINT (val
, SREF (string
, 0));
216 XSETFASTINT (val
, 0);
221 buildmark (ptrdiff_t charpos
, ptrdiff_t bytepos
)
223 register Lisp_Object mark
;
224 mark
= Fmake_marker ();
225 set_marker_both (mark
, Qnil
, charpos
, bytepos
);
229 DEFUN ("point", Fpoint
, Spoint
, 0, 0, 0,
230 doc
: /* Return value of point, as an integer.
231 Beginning of buffer is position (point-min). */)
235 XSETFASTINT (temp
, PT
);
239 DEFUN ("point-marker", Fpoint_marker
, Spoint_marker
, 0, 0, 0,
240 doc
: /* Return value of point, as a marker object. */)
243 return buildmark (PT
, PT_BYTE
);
246 DEFUN ("goto-char", Fgoto_char
, Sgoto_char
, 1, 1, "NGoto char: ",
247 doc
: /* Set point to POSITION, a number or marker.
248 Beginning of buffer is position (point-min), end is (point-max).
250 The return value is POSITION. */)
251 (register Lisp_Object position
)
255 if (MARKERP (position
)
256 && current_buffer
== XMARKER (position
)->buffer
)
258 pos
= marker_position (position
);
260 SET_PT_BOTH (BEGV
, BEGV_BYTE
);
262 SET_PT_BOTH (ZV
, ZV_BYTE
);
264 SET_PT_BOTH (pos
, marker_byte_position (position
));
269 CHECK_NUMBER_COERCE_MARKER (position
);
271 pos
= clip_to_bounds (BEGV
, XINT (position
), ZV
);
277 /* Return the start or end position of the region.
278 BEGINNINGP non-zero means return the start.
279 If there is no region active, signal an error. */
282 region_limit (int beginningp
)
286 if (!NILP (Vtransient_mark_mode
)
287 && NILP (Vmark_even_if_inactive
)
288 && NILP (BVAR (current_buffer
, mark_active
)))
289 xsignal0 (Qmark_inactive
);
291 m
= Fmarker_position (BVAR (current_buffer
, mark
));
293 error ("The mark is not set now, so there is no region");
295 if ((PT
< XFASTINT (m
)) == (beginningp
!= 0))
296 m
= make_number (PT
);
300 DEFUN ("region-beginning", Fregion_beginning
, Sregion_beginning
, 0, 0, 0,
301 doc
: /* Return the integer value of point or mark, whichever is smaller. */)
304 return region_limit (1);
307 DEFUN ("region-end", Fregion_end
, Sregion_end
, 0, 0, 0,
308 doc
: /* Return the integer value of point or mark, whichever is larger. */)
311 return region_limit (0);
314 DEFUN ("mark-marker", Fmark_marker
, Smark_marker
, 0, 0, 0,
315 doc
: /* Return this buffer's mark, as a marker object.
316 Watch out! Moving this marker changes the mark position.
317 If you set the marker not to point anywhere, the buffer will have no mark. */)
320 return BVAR (current_buffer
, mark
);
324 /* Find all the overlays in the current buffer that touch position POS.
325 Return the number found, and store them in a vector in VEC
329 overlays_around (EMACS_INT pos
, Lisp_Object
*vec
, ptrdiff_t len
)
331 Lisp_Object overlay
, start
, end
;
332 struct Lisp_Overlay
*tail
;
333 ptrdiff_t startpos
, endpos
;
336 for (tail
= current_buffer
->overlays_before
; tail
; tail
= tail
->next
)
338 XSETMISC (overlay
, tail
);
340 end
= OVERLAY_END (overlay
);
341 endpos
= OVERLAY_POSITION (end
);
344 start
= OVERLAY_START (overlay
);
345 startpos
= OVERLAY_POSITION (start
);
350 /* Keep counting overlays even if we can't return them all. */
355 for (tail
= current_buffer
->overlays_after
; tail
; tail
= tail
->next
)
357 XSETMISC (overlay
, tail
);
359 start
= OVERLAY_START (overlay
);
360 startpos
= OVERLAY_POSITION (start
);
363 end
= OVERLAY_END (overlay
);
364 endpos
= OVERLAY_POSITION (end
);
376 /* Return the value of property PROP, in OBJECT at POSITION.
377 It's the value of PROP that a char inserted at POSITION would get.
378 OBJECT is optional and defaults to the current buffer.
379 If OBJECT is a buffer, then overlay properties are considered as well as
381 If OBJECT is a window, then that window's buffer is used, but
382 window-specific overlays are considered only if they are associated
385 get_pos_property (Lisp_Object position
, register Lisp_Object prop
, Lisp_Object object
)
387 CHECK_NUMBER_COERCE_MARKER (position
);
390 XSETBUFFER (object
, current_buffer
);
391 else if (WINDOWP (object
))
392 object
= XWINDOW (object
)->buffer
;
394 if (!BUFFERP (object
))
395 /* pos-property only makes sense in buffers right now, since strings
396 have no overlays and no notion of insertion for which stickiness
398 return Fget_text_property (position
, prop
, object
);
401 EMACS_INT posn
= XINT (position
);
403 Lisp_Object
*overlay_vec
, tem
;
404 struct buffer
*obuf
= current_buffer
;
406 set_buffer_temp (XBUFFER (object
));
408 /* First try with room for 40 overlays. */
410 overlay_vec
= (Lisp_Object
*) alloca (noverlays
* sizeof (Lisp_Object
));
411 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
413 /* If there are more than 40,
414 make enough space for all, and try again. */
417 overlay_vec
= (Lisp_Object
*) alloca (noverlays
* sizeof (Lisp_Object
));
418 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
420 noverlays
= sort_overlays (overlay_vec
, noverlays
, NULL
);
422 set_buffer_temp (obuf
);
424 /* Now check the overlays in order of decreasing priority. */
425 while (--noverlays
>= 0)
427 Lisp_Object ol
= overlay_vec
[noverlays
];
428 tem
= Foverlay_get (ol
, prop
);
431 /* Check the overlay is indeed active at point. */
432 Lisp_Object start
= OVERLAY_START (ol
), finish
= OVERLAY_END (ol
);
433 if ((OVERLAY_POSITION (start
) == posn
434 && XMARKER (start
)->insertion_type
== 1)
435 || (OVERLAY_POSITION (finish
) == posn
436 && XMARKER (finish
)->insertion_type
== 0))
437 ; /* The overlay will not cover a char inserted at point. */
445 { /* Now check the text properties. */
446 int stickiness
= text_property_stickiness (prop
, position
, object
);
448 return Fget_text_property (position
, prop
, object
);
449 else if (stickiness
< 0
450 && XINT (position
) > BUF_BEGV (XBUFFER (object
)))
451 return Fget_text_property (make_number (XINT (position
) - 1),
459 /* Find the field surrounding POS in *BEG and *END. If POS is nil,
460 the value of point is used instead. If BEG or END is null,
461 means don't store the beginning or end of the field.
463 BEG_LIMIT and END_LIMIT serve to limit the ranged of the returned
464 results; they do not effect boundary behavior.
466 If MERGE_AT_BOUNDARY is nonzero, then if POS is at the very first
467 position of a field, then the beginning of the previous field is
468 returned instead of the beginning of POS's field (since the end of a
469 field is actually also the beginning of the next input field, this
470 behavior is sometimes useful). Additionally in the MERGE_AT_BOUNDARY
471 true case, if two fields are separated by a field with the special
472 value `boundary', and POS lies within it, then the two separated
473 fields are considered to be adjacent, and POS between them, when
474 finding the beginning and ending of the "merged" field.
476 Either BEG or END may be 0, in which case the corresponding value
480 find_field (Lisp_Object pos
, Lisp_Object merge_at_boundary
,
481 Lisp_Object beg_limit
,
482 ptrdiff_t *beg
, Lisp_Object end_limit
, ptrdiff_t *end
)
484 /* Fields right before and after the point. */
485 Lisp_Object before_field
, after_field
;
486 /* 1 if POS counts as the start of a field. */
487 int at_field_start
= 0;
488 /* 1 if POS counts as the end of a field. */
489 int at_field_end
= 0;
492 XSETFASTINT (pos
, PT
);
494 CHECK_NUMBER_COERCE_MARKER (pos
);
497 = get_char_property_and_overlay (pos
, Qfield
, Qnil
, NULL
);
499 = (XFASTINT (pos
) > BEGV
500 ? get_char_property_and_overlay (make_number (XINT (pos
) - 1),
502 /* Using nil here would be a more obvious choice, but it would
503 fail when the buffer starts with a non-sticky field. */
506 /* See if we need to handle the case where MERGE_AT_BOUNDARY is nil
507 and POS is at beginning of a field, which can also be interpreted
508 as the end of the previous field. Note that the case where if
509 MERGE_AT_BOUNDARY is non-nil (see function comment) is actually the
510 more natural one; then we avoid treating the beginning of a field
512 if (NILP (merge_at_boundary
))
514 Lisp_Object field
= get_pos_property (pos
, Qfield
, Qnil
);
515 if (!EQ (field
, after_field
))
517 if (!EQ (field
, before_field
))
519 if (NILP (field
) && at_field_start
&& at_field_end
)
520 /* If an inserted char would have a nil field while the surrounding
521 text is non-nil, we're probably not looking at a
522 zero-length field, but instead at a non-nil field that's
523 not intended for editing (such as comint's prompts). */
524 at_field_end
= at_field_start
= 0;
527 /* Note about special `boundary' fields:
529 Consider the case where the point (`.') is between the fields `x' and `y':
533 In this situation, if merge_at_boundary is true, we consider the
534 `x' and `y' fields as forming one big merged field, and so the end
535 of the field is the end of `y'.
537 However, if `x' and `y' are separated by a special `boundary' field
538 (a field with a `field' char-property of 'boundary), then we ignore
539 this special field when merging adjacent fields. Here's the same
540 situation, but with a `boundary' field between the `x' and `y' fields:
544 Here, if point is at the end of `x', the beginning of `y', or
545 anywhere in-between (within the `boundary' field), we merge all
546 three fields and consider the beginning as being the beginning of
547 the `x' field, and the end as being the end of the `y' field. */
552 /* POS is at the edge of a field, and we should consider it as
553 the beginning of the following field. */
554 *beg
= XFASTINT (pos
);
556 /* Find the previous field boundary. */
559 if (!NILP (merge_at_boundary
) && EQ (before_field
, Qboundary
))
560 /* Skip a `boundary' field. */
561 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
564 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
566 *beg
= NILP (p
) ? BEGV
: XFASTINT (p
);
573 /* POS is at the edge of a field, and we should consider it as
574 the end of the previous field. */
575 *end
= XFASTINT (pos
);
577 /* Find the next field boundary. */
579 if (!NILP (merge_at_boundary
) && EQ (after_field
, Qboundary
))
580 /* Skip a `boundary' field. */
581 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
584 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
586 *end
= NILP (pos
) ? ZV
: XFASTINT (pos
);
592 DEFUN ("delete-field", Fdelete_field
, Sdelete_field
, 0, 1, 0,
593 doc
: /* Delete the field surrounding POS.
594 A field is a region of text with the same `field' property.
595 If POS is nil, the value of point is used for POS. */)
599 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
601 del_range (beg
, end
);
605 DEFUN ("field-string", Ffield_string
, Sfield_string
, 0, 1, 0,
606 doc
: /* Return the contents of the field surrounding POS as a string.
607 A field is a region of text with the same `field' property.
608 If POS is nil, the value of point is used for POS. */)
612 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
613 return make_buffer_string (beg
, end
, 1);
616 DEFUN ("field-string-no-properties", Ffield_string_no_properties
, Sfield_string_no_properties
, 0, 1, 0,
617 doc
: /* Return the contents of the field around POS, without text properties.
618 A field is a region of text with the same `field' property.
619 If POS is nil, the value of point is used for POS. */)
623 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
624 return make_buffer_string (beg
, end
, 0);
627 DEFUN ("field-beginning", Ffield_beginning
, Sfield_beginning
, 0, 3, 0,
628 doc
: /* Return the beginning of the field surrounding POS.
629 A field is a region of text with the same `field' property.
630 If POS is nil, the value of point is used for POS.
631 If ESCAPE-FROM-EDGE is non-nil and POS is at the beginning of its
632 field, then the beginning of the *previous* field is returned.
633 If LIMIT is non-nil, it is a buffer position; if the beginning of the field
634 is before LIMIT, then LIMIT will be returned instead. */)
635 (Lisp_Object pos
, Lisp_Object escape_from_edge
, Lisp_Object limit
)
638 find_field (pos
, escape_from_edge
, limit
, &beg
, Qnil
, 0);
639 return make_number (beg
);
642 DEFUN ("field-end", Ffield_end
, Sfield_end
, 0, 3, 0,
643 doc
: /* Return the end of the field surrounding POS.
644 A field is a region of text with the same `field' property.
645 If POS is nil, the value of point is used for POS.
646 If ESCAPE-FROM-EDGE is non-nil and POS is at the end of its field,
647 then the end of the *following* field is returned.
648 If LIMIT is non-nil, it is a buffer position; if the end of the field
649 is after LIMIT, then LIMIT will be returned instead. */)
650 (Lisp_Object pos
, Lisp_Object escape_from_edge
, Lisp_Object limit
)
653 find_field (pos
, escape_from_edge
, Qnil
, 0, limit
, &end
);
654 return make_number (end
);
657 DEFUN ("constrain-to-field", Fconstrain_to_field
, Sconstrain_to_field
, 2, 5, 0,
658 doc
: /* Return the position closest to NEW-POS that is in the same field as OLD-POS.
660 A field is a region of text with the same `field' property.
661 If NEW-POS is nil, then the current point is used instead, and set to the
662 constrained position if that is different.
664 If OLD-POS is at the boundary of two fields, then the allowable
665 positions for NEW-POS depends on the value of the optional argument
666 ESCAPE-FROM-EDGE: If ESCAPE-FROM-EDGE is nil, then NEW-POS is
667 constrained to the field that has the same `field' char-property
668 as any new characters inserted at OLD-POS, whereas if ESCAPE-FROM-EDGE
669 is non-nil, NEW-POS is constrained to the union of the two adjacent
670 fields. Additionally, if two fields are separated by another field with
671 the special value `boundary', then any point within this special field is
672 also considered to be `on the boundary'.
674 If the optional argument ONLY-IN-LINE is non-nil and constraining
675 NEW-POS would move it to a different line, NEW-POS is returned
676 unconstrained. This useful for commands that move by line, like
677 \\[next-line] or \\[beginning-of-line], which should generally respect field boundaries
678 only in the case where they can still move to the right line.
680 If the optional argument INHIBIT-CAPTURE-PROPERTY is non-nil, and OLD-POS has
681 a non-nil property of that name, then any field boundaries are ignored.
683 Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */)
684 (Lisp_Object new_pos
, Lisp_Object old_pos
, Lisp_Object escape_from_edge
, Lisp_Object only_in_line
, Lisp_Object inhibit_capture_property
)
686 /* If non-zero, then the original point, before re-positioning. */
687 ptrdiff_t orig_point
= 0;
689 Lisp_Object prev_old
, prev_new
;
692 /* Use the current point, and afterwards, set it. */
695 XSETFASTINT (new_pos
, PT
);
698 CHECK_NUMBER_COERCE_MARKER (new_pos
);
699 CHECK_NUMBER_COERCE_MARKER (old_pos
);
701 fwd
= (XINT (new_pos
) > XINT (old_pos
));
703 prev_old
= make_number (XINT (old_pos
) - 1);
704 prev_new
= make_number (XINT (new_pos
) - 1);
706 if (NILP (Vinhibit_field_text_motion
)
707 && !EQ (new_pos
, old_pos
)
708 && (!NILP (Fget_char_property (new_pos
, Qfield
, Qnil
))
709 || !NILP (Fget_char_property (old_pos
, Qfield
, Qnil
))
710 /* To recognize field boundaries, we must also look at the
711 previous positions; we could use `get_pos_property'
712 instead, but in itself that would fail inside non-sticky
713 fields (like comint prompts). */
714 || (XFASTINT (new_pos
) > BEGV
715 && !NILP (Fget_char_property (prev_new
, Qfield
, Qnil
)))
716 || (XFASTINT (old_pos
) > BEGV
717 && !NILP (Fget_char_property (prev_old
, Qfield
, Qnil
))))
718 && (NILP (inhibit_capture_property
)
719 /* Field boundaries are again a problem; but now we must
720 decide the case exactly, so we need to call
721 `get_pos_property' as well. */
722 || (NILP (get_pos_property (old_pos
, inhibit_capture_property
, Qnil
))
723 && (XFASTINT (old_pos
) <= BEGV
724 || NILP (Fget_char_property (old_pos
, inhibit_capture_property
, Qnil
))
725 || NILP (Fget_char_property (prev_old
, inhibit_capture_property
, Qnil
))))))
726 /* It is possible that NEW_POS is not within the same field as
727 OLD_POS; try to move NEW_POS so that it is. */
730 Lisp_Object field_bound
;
733 field_bound
= Ffield_end (old_pos
, escape_from_edge
, new_pos
);
735 field_bound
= Ffield_beginning (old_pos
, escape_from_edge
, new_pos
);
737 if (/* See if ESCAPE_FROM_EDGE caused FIELD_BOUND to jump to the
738 other side of NEW_POS, which would mean that NEW_POS is
739 already acceptable, and it's not necessary to constrain it
741 ((XFASTINT (field_bound
) < XFASTINT (new_pos
)) ? fwd
: !fwd
)
742 /* NEW_POS should be constrained, but only if either
743 ONLY_IN_LINE is nil (in which case any constraint is OK),
744 or NEW_POS and FIELD_BOUND are on the same line (in which
745 case the constraint is OK even if ONLY_IN_LINE is non-nil). */
746 && (NILP (only_in_line
)
747 /* This is the ONLY_IN_LINE case, check that NEW_POS and
748 FIELD_BOUND are on the same line by seeing whether
749 there's an intervening newline or not. */
750 || (scan_buffer ('\n',
751 XFASTINT (new_pos
), XFASTINT (field_bound
),
752 fwd
? -1 : 1, &shortage
, 1),
754 /* Constrain NEW_POS to FIELD_BOUND. */
755 new_pos
= field_bound
;
757 if (orig_point
&& XFASTINT (new_pos
) != orig_point
)
758 /* The NEW_POS argument was originally nil, so automatically set PT. */
759 SET_PT (XFASTINT (new_pos
));
766 DEFUN ("line-beginning-position",
767 Fline_beginning_position
, Sline_beginning_position
, 0, 1, 0,
768 doc
: /* Return the character position of the first character on the current line.
769 With argument N not nil or 1, move forward N - 1 lines first.
770 If scan reaches end of buffer, return that position.
772 The returned position is of the first character in the logical order,
773 i.e. the one that has the smallest character position.
775 This function constrains the returned position to the current field
776 unless that would be on a different line than the original,
777 unconstrained result. If N is nil or 1, and a front-sticky field
778 starts at point, the scan stops as soon as it starts. To ignore field
779 boundaries bind `inhibit-field-text-motion' to t.
781 This function does not move point. */)
784 ptrdiff_t orig
, orig_byte
, end
;
785 ptrdiff_t count
= SPECPDL_INDEX ();
786 specbind (Qinhibit_point_motion_hooks
, Qt
);
795 Fforward_line (make_number (XINT (n
) - 1));
798 SET_PT_BOTH (orig
, orig_byte
);
800 unbind_to (count
, Qnil
);
802 /* Return END constrained to the current input field. */
803 return Fconstrain_to_field (make_number (end
), make_number (orig
),
804 XINT (n
) != 1 ? Qt
: Qnil
,
808 DEFUN ("line-end-position", Fline_end_position
, Sline_end_position
, 0, 1, 0,
809 doc
: /* Return the character position of the last character on the current line.
810 With argument N not nil or 1, move forward N - 1 lines first.
811 If scan reaches end of buffer, return that position.
813 The returned position is of the last character in the logical order,
814 i.e. the character whose buffer position is the largest one.
816 This function constrains the returned position to the current field
817 unless that would be on a different line than the original,
818 unconstrained result. If N is nil or 1, and a rear-sticky field ends
819 at point, the scan stops as soon as it starts. To ignore field
820 boundaries bind `inhibit-field-text-motion' to t.
822 This function does not move point. */)
834 clipped_n
= clip_to_bounds (PTRDIFF_MIN
+ 1, XINT (n
), PTRDIFF_MAX
);
835 end_pos
= find_before_next_newline (orig
, 0, clipped_n
- (clipped_n
<= 0));
837 /* Return END_POS constrained to the current input field. */
838 return Fconstrain_to_field (make_number (end_pos
), make_number (orig
),
844 save_excursion_save (void)
846 int visible
= (XBUFFER (XWINDOW (selected_window
)->buffer
)
849 return Fcons (Fpoint_marker (),
850 Fcons (Fcopy_marker (BVAR (current_buffer
, mark
), Qnil
),
851 Fcons (visible
? Qt
: Qnil
,
852 Fcons (BVAR (current_buffer
, mark_active
),
857 save_excursion_restore (Lisp_Object info
)
859 Lisp_Object tem
, tem1
, omark
, nmark
;
860 struct gcpro gcpro1
, gcpro2
, gcpro3
;
863 tem
= Fmarker_buffer (XCAR (info
));
864 /* If buffer being returned to is now deleted, avoid error */
865 /* Otherwise could get error here while unwinding to top level
867 /* In that case, Fmarker_buffer returns nil now. */
871 omark
= nmark
= Qnil
;
872 GCPRO3 (info
, omark
, nmark
);
879 unchain_marker (XMARKER (tem
));
884 omark
= Fmarker_position (BVAR (current_buffer
, mark
));
885 Fset_marker (BVAR (current_buffer
, mark
), tem
, Fcurrent_buffer ());
886 nmark
= Fmarker_position (tem
);
887 unchain_marker (XMARKER (tem
));
891 visible_p
= !NILP (XCAR (info
));
893 #if 0 /* We used to make the current buffer visible in the selected window
894 if that was true previously. That avoids some anomalies.
895 But it creates others, and it wasn't documented, and it is simpler
896 and cleaner never to alter the window/buffer connections. */
899 && current_buffer
!= XBUFFER (XWINDOW (selected_window
)->buffer
))
900 Fswitch_to_buffer (Fcurrent_buffer (), Qnil
);
906 tem1
= BVAR (current_buffer
, mark_active
);
907 BVAR (current_buffer
, mark_active
) = tem
;
909 /* If mark is active now, and either was not active
910 or was at a different place, run the activate hook. */
913 if (! EQ (omark
, nmark
))
915 tem
= intern ("activate-mark-hook");
916 Frun_hooks (1, &tem
);
919 /* If mark has ceased to be active, run deactivate hook. */
920 else if (! NILP (tem1
))
922 tem
= intern ("deactivate-mark-hook");
923 Frun_hooks (1, &tem
);
926 /* If buffer was visible in a window, and a different window was
927 selected, and the old selected window is still showing this
928 buffer, restore point in that window. */
931 && !EQ (tem
, selected_window
)
932 && (tem1
= XWINDOW (tem
)->buffer
,
933 (/* Window is live... */
935 /* ...and it shows the current buffer. */
936 && XBUFFER (tem1
) == current_buffer
)))
937 Fset_window_point (tem
, make_number (PT
));
943 DEFUN ("save-excursion", Fsave_excursion
, Ssave_excursion
, 0, UNEVALLED
, 0,
944 doc
: /* Save point, mark, and current buffer; execute BODY; restore those things.
945 Executes BODY just like `progn'.
946 The values of point, mark and the current buffer are restored
947 even in case of abnormal exit (throw or error).
948 The state of activation of the mark is also restored.
950 This construct does not save `deactivate-mark', and therefore
951 functions that change the buffer will still cause deactivation
952 of the mark at the end of the command. To prevent that, bind
953 `deactivate-mark' with `let'.
955 If you only want to save the current buffer but not point nor mark,
956 then just use `save-current-buffer', or even `with-current-buffer'.
958 usage: (save-excursion &rest BODY) */)
961 register Lisp_Object val
;
962 ptrdiff_t count
= SPECPDL_INDEX ();
964 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
967 return unbind_to (count
, val
);
970 DEFUN ("save-current-buffer", Fsave_current_buffer
, Ssave_current_buffer
, 0, UNEVALLED
, 0,
971 doc
: /* Save the current buffer; execute BODY; restore the current buffer.
972 Executes BODY just like `progn'.
973 usage: (save-current-buffer &rest BODY) */)
977 ptrdiff_t count
= SPECPDL_INDEX ();
979 record_unwind_protect (set_buffer_if_live
, Fcurrent_buffer ());
982 return unbind_to (count
, val
);
985 DEFUN ("buffer-size", Fbufsize
, Sbufsize
, 0, 1, 0,
986 doc
: /* Return the number of characters in the current buffer.
987 If BUFFER, return the number of characters in that buffer instead. */)
991 return make_number (Z
- BEG
);
994 CHECK_BUFFER (buffer
);
995 return make_number (BUF_Z (XBUFFER (buffer
))
996 - BUF_BEG (XBUFFER (buffer
)));
1000 DEFUN ("point-min", Fpoint_min
, Spoint_min
, 0, 0, 0,
1001 doc
: /* Return the minimum permissible value of point in the current buffer.
1002 This is 1, unless narrowing (a buffer restriction) is in effect. */)
1006 XSETFASTINT (temp
, BEGV
);
1010 DEFUN ("point-min-marker", Fpoint_min_marker
, Spoint_min_marker
, 0, 0, 0,
1011 doc
: /* Return a marker to the minimum permissible value of point in this buffer.
1012 This is the beginning, unless narrowing (a buffer restriction) is in effect. */)
1015 return buildmark (BEGV
, BEGV_BYTE
);
1018 DEFUN ("point-max", Fpoint_max
, Spoint_max
, 0, 0, 0,
1019 doc
: /* Return the maximum permissible value of point in the current buffer.
1020 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1021 is in effect, in which case it is less. */)
1025 XSETFASTINT (temp
, ZV
);
1029 DEFUN ("point-max-marker", Fpoint_max_marker
, Spoint_max_marker
, 0, 0, 0,
1030 doc
: /* Return a marker to the maximum permissible value of point in this buffer.
1031 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1032 is in effect, in which case it is less. */)
1035 return buildmark (ZV
, ZV_BYTE
);
1038 DEFUN ("gap-position", Fgap_position
, Sgap_position
, 0, 0, 0,
1039 doc
: /* Return the position of the gap, in the current buffer.
1040 See also `gap-size'. */)
1044 XSETFASTINT (temp
, GPT
);
1048 DEFUN ("gap-size", Fgap_size
, Sgap_size
, 0, 0, 0,
1049 doc
: /* Return the size of the current buffer's gap.
1050 See also `gap-position'. */)
1054 XSETFASTINT (temp
, GAP_SIZE
);
1058 DEFUN ("position-bytes", Fposition_bytes
, Sposition_bytes
, 1, 1, 0,
1059 doc
: /* Return the byte position for character position POSITION.
1060 If POSITION is out of range, the value is nil. */)
1061 (Lisp_Object position
)
1063 CHECK_NUMBER_COERCE_MARKER (position
);
1064 if (XINT (position
) < BEG
|| XINT (position
) > Z
)
1066 return make_number (CHAR_TO_BYTE (XINT (position
)));
1069 DEFUN ("byte-to-position", Fbyte_to_position
, Sbyte_to_position
, 1, 1, 0,
1070 doc
: /* Return the character position for byte position BYTEPOS.
1071 If BYTEPOS is out of range, the value is nil. */)
1072 (Lisp_Object bytepos
)
1074 CHECK_NUMBER (bytepos
);
1075 if (XINT (bytepos
) < BEG_BYTE
|| XINT (bytepos
) > Z_BYTE
)
1077 return make_number (BYTE_TO_CHAR (XINT (bytepos
)));
1080 DEFUN ("following-char", Ffollowing_char
, Sfollowing_char
, 0, 0, 0,
1081 doc
: /* Return the character following point, as a number.
1082 At the end of the buffer or accessible region, return 0. */)
1087 XSETFASTINT (temp
, 0);
1089 XSETFASTINT (temp
, FETCH_CHAR (PT_BYTE
));
1093 DEFUN ("preceding-char", Fprevious_char
, Sprevious_char
, 0, 0, 0,
1094 doc
: /* Return the character preceding point, as a number.
1095 At the beginning of the buffer or accessible region, return 0. */)
1100 XSETFASTINT (temp
, 0);
1101 else if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
1103 ptrdiff_t pos
= PT_BYTE
;
1105 XSETFASTINT (temp
, FETCH_CHAR (pos
));
1108 XSETFASTINT (temp
, FETCH_BYTE (PT_BYTE
- 1));
1112 DEFUN ("bobp", Fbobp
, Sbobp
, 0, 0, 0,
1113 doc
: /* Return t if point is at the beginning of the buffer.
1114 If the buffer is narrowed, this means the beginning of the narrowed part. */)
1122 DEFUN ("eobp", Feobp
, Seobp
, 0, 0, 0,
1123 doc
: /* Return t if point is at the end of the buffer.
1124 If the buffer is narrowed, this means the end of the narrowed part. */)
1132 DEFUN ("bolp", Fbolp
, Sbolp
, 0, 0, 0,
1133 doc
: /* Return t if point is at the beginning of a line. */)
1136 if (PT
== BEGV
|| FETCH_BYTE (PT_BYTE
- 1) == '\n')
1141 DEFUN ("eolp", Feolp
, Seolp
, 0, 0, 0,
1142 doc
: /* Return t if point is at the end of a line.
1143 `End of a line' includes point being at the end of the buffer. */)
1146 if (PT
== ZV
|| FETCH_BYTE (PT_BYTE
) == '\n')
1151 DEFUN ("char-after", Fchar_after
, Schar_after
, 0, 1, 0,
1152 doc
: /* Return character in current buffer at position POS.
1153 POS is an integer or a marker and defaults to point.
1154 If POS is out of range, the value is nil. */)
1157 register ptrdiff_t pos_byte
;
1162 XSETFASTINT (pos
, PT
);
1167 pos_byte
= marker_byte_position (pos
);
1168 if (pos_byte
< BEGV_BYTE
|| pos_byte
>= ZV_BYTE
)
1173 CHECK_NUMBER_COERCE_MARKER (pos
);
1174 if (XINT (pos
) < BEGV
|| XINT (pos
) >= ZV
)
1177 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1180 return make_number (FETCH_CHAR (pos_byte
));
1183 DEFUN ("char-before", Fchar_before
, Schar_before
, 0, 1, 0,
1184 doc
: /* Return character in current buffer preceding position POS.
1185 POS is an integer or a marker and defaults to point.
1186 If POS is out of range, the value is nil. */)
1189 register Lisp_Object val
;
1190 register ptrdiff_t pos_byte
;
1195 XSETFASTINT (pos
, PT
);
1200 pos_byte
= marker_byte_position (pos
);
1202 if (pos_byte
<= BEGV_BYTE
|| pos_byte
> ZV_BYTE
)
1207 CHECK_NUMBER_COERCE_MARKER (pos
);
1209 if (XINT (pos
) <= BEGV
|| XINT (pos
) > ZV
)
1212 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1215 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
1218 XSETFASTINT (val
, FETCH_CHAR (pos_byte
));
1223 XSETFASTINT (val
, FETCH_BYTE (pos_byte
));
1228 DEFUN ("user-login-name", Fuser_login_name
, Suser_login_name
, 0, 1, 0,
1229 doc
: /* Return the name under which the user logged in, as a string.
1230 This is based on the effective uid, not the real uid.
1231 Also, if the environment variables LOGNAME or USER are set,
1232 that determines the value of this function.
1234 If optional argument UID is an integer or a float, return the login name
1235 of the user with that uid, or nil if there is no such user. */)
1241 /* Set up the user name info if we didn't do it before.
1242 (That can happen if Emacs is dumpable
1243 but you decide to run `temacs -l loadup' and not dump. */
1244 if (INTEGERP (Vuser_login_name
))
1248 return Vuser_login_name
;
1250 CONS_TO_INTEGER (uid
, uid_t
, id
);
1254 return (pw
? build_string (pw
->pw_name
) : Qnil
);
1257 DEFUN ("user-real-login-name", Fuser_real_login_name
, Suser_real_login_name
,
1259 doc
: /* Return the name of the user's real uid, as a string.
1260 This ignores the environment variables LOGNAME and USER, so it differs from
1261 `user-login-name' when running under `su'. */)
1264 /* Set up the user name info if we didn't do it before.
1265 (That can happen if Emacs is dumpable
1266 but you decide to run `temacs -l loadup' and not dump. */
1267 if (INTEGERP (Vuser_login_name
))
1269 return Vuser_real_login_name
;
1272 DEFUN ("user-uid", Fuser_uid
, Suser_uid
, 0, 0, 0,
1273 doc
: /* Return the effective uid of Emacs.
1274 Value is an integer or a float, depending on the value. */)
1277 uid_t euid
= geteuid ();
1278 return make_fixnum_or_float (euid
);
1281 DEFUN ("user-real-uid", Fuser_real_uid
, Suser_real_uid
, 0, 0, 0,
1282 doc
: /* Return the real uid of Emacs.
1283 Value is an integer or a float, depending on the value. */)
1286 uid_t uid
= getuid ();
1287 return make_fixnum_or_float (uid
);
1290 DEFUN ("user-full-name", Fuser_full_name
, Suser_full_name
, 0, 1, 0,
1291 doc
: /* Return the full name of the user logged in, as a string.
1292 If the full name corresponding to Emacs's userid is not known,
1295 If optional argument UID is an integer or float, return the full name
1296 of the user with that uid, or nil if there is no such user.
1297 If UID is a string, return the full name of the user with that login
1298 name, or nil if there is no such user. */)
1302 register char *p
, *q
;
1306 return Vuser_full_name
;
1307 else if (NUMBERP (uid
))
1310 CONS_TO_INTEGER (uid
, uid_t
, u
);
1315 else if (STRINGP (uid
))
1318 pw
= getpwnam (SSDATA (uid
));
1322 error ("Invalid UID specification");
1328 /* Chop off everything after the first comma. */
1329 q
= strchr (p
, ',');
1330 full
= make_string (p
, q
? q
- p
: strlen (p
));
1332 #ifdef AMPERSAND_FULL_NAME
1334 q
= strchr (p
, '&');
1335 /* Substitute the login name for the &, upcasing the first character. */
1341 login
= Fuser_login_name (make_number (pw
->pw_uid
));
1342 r
= (char *) alloca (strlen (p
) + SCHARS (login
) + 1);
1343 memcpy (r
, p
, q
- p
);
1345 strcat (r
, SSDATA (login
));
1346 r
[q
- p
] = upcase ((unsigned char) r
[q
- p
]);
1348 full
= build_string (r
);
1350 #endif /* AMPERSAND_FULL_NAME */
1355 DEFUN ("system-name", Fsystem_name
, Ssystem_name
, 0, 0, 0,
1356 doc
: /* Return the host name of the machine you are running on, as a string. */)
1359 return Vsystem_name
;
1363 get_system_name (void)
1365 if (STRINGP (Vsystem_name
))
1366 return SSDATA (Vsystem_name
);
1371 DEFUN ("emacs-pid", Femacs_pid
, Semacs_pid
, 0, 0, 0,
1372 doc
: /* Return the process ID of Emacs, as a number. */)
1375 pid_t pid
= getpid ();
1376 return make_fixnum_or_float (pid
);
1382 # define TIME_T_MIN TYPE_MINIMUM (time_t)
1385 # define TIME_T_MAX TYPE_MAXIMUM (time_t)
1388 /* Report that a time value is out of range for Emacs. */
1390 time_overflow (void)
1392 error ("Specified time is not representable");
1395 /* Return the upper part of the time T (everything but the bottom 16 bits),
1396 making sure that it is representable. */
1400 time_t hi
= t
>> 16;
1402 /* Check for overflow, helping the compiler for common cases where
1403 no runtime check is needed, and taking care not to convert
1404 negative numbers to unsigned before comparing them. */
1405 if (! ((! TYPE_SIGNED (time_t)
1406 || MOST_NEGATIVE_FIXNUM
<= TIME_T_MIN
>> 16
1407 || MOST_NEGATIVE_FIXNUM
<= hi
)
1408 && (TIME_T_MAX
>> 16 <= MOST_POSITIVE_FIXNUM
1409 || hi
<= MOST_POSITIVE_FIXNUM
)))
1415 /* Return the bottom 16 bits of the time T. */
1419 return t
& ((1 << 16) - 1);
1422 DEFUN ("current-time", Fcurrent_time
, Scurrent_time
, 0, 0, 0,
1423 doc
: /* Return the current time, as the number of seconds since 1970-01-01 00:00:00.
1424 The time is returned as a list of three integers. The first has the
1425 most significant 16 bits of the seconds, while the second has the
1426 least significant 16 bits. The third integer gives the microsecond
1429 The microsecond count is zero on systems that do not provide
1430 resolution finer than a second. */)
1436 return list3 (make_number (hi_time (EMACS_SECS (t
))),
1437 make_number (lo_time (EMACS_SECS (t
))),
1438 make_number (EMACS_USECS (t
)));
1441 DEFUN ("get-internal-run-time", Fget_internal_run_time
, Sget_internal_run_time
,
1443 doc
: /* Return the current run time used by Emacs.
1444 The time is returned as a list of three integers. The first has the
1445 most significant 16 bits of the seconds, while the second has the
1446 least significant 16 bits. The third integer gives the microsecond
1449 On systems that can't determine the run time, `get-internal-run-time'
1450 does the same thing as `current-time'. The microsecond count is zero
1451 on systems that do not provide resolution finer than a second. */)
1454 #ifdef HAVE_GETRUSAGE
1455 struct rusage usage
;
1459 if (getrusage (RUSAGE_SELF
, &usage
) < 0)
1460 /* This shouldn't happen. What action is appropriate? */
1463 /* Sum up user time and system time. */
1464 secs
= usage
.ru_utime
.tv_sec
+ usage
.ru_stime
.tv_sec
;
1465 usecs
= usage
.ru_utime
.tv_usec
+ usage
.ru_stime
.tv_usec
;
1466 if (usecs
>= 1000000)
1472 return list3 (make_number (hi_time (secs
)),
1473 make_number (lo_time (secs
)),
1474 make_number (usecs
));
1475 #else /* ! HAVE_GETRUSAGE */
1477 return w32_get_internal_run_time ();
1478 #else /* ! WINDOWSNT */
1479 return Fcurrent_time ();
1480 #endif /* WINDOWSNT */
1481 #endif /* HAVE_GETRUSAGE */
1485 /* Make a Lisp list that represents the time T. */
1487 make_time (time_t t
)
1489 return list2 (make_number (hi_time (t
)),
1490 make_number (lo_time (t
)));
1493 /* Decode a Lisp list SPECIFIED_TIME that represents a time.
1494 If SPECIFIED_TIME is nil, use the current time.
1495 Set *RESULT to seconds since the Epoch.
1496 If USEC is not null, set *USEC to the microseconds component.
1497 Return nonzero if successful. */
1499 lisp_time_argument (Lisp_Object specified_time
, time_t *result
, int *usec
)
1501 if (NILP (specified_time
))
1508 *usec
= EMACS_USECS (t
);
1509 *result
= EMACS_SECS (t
);
1513 return time (result
) != -1;
1517 Lisp_Object high
, low
;
1519 high
= Fcar (specified_time
);
1520 CHECK_NUMBER (high
);
1521 low
= Fcdr (specified_time
);
1526 Lisp_Object usec_l
= Fcdr (low
);
1528 usec_l
= Fcar (usec_l
);
1533 CHECK_NUMBER (usec_l
);
1534 if (! (0 <= XINT (usec_l
) && XINT (usec_l
) < 1000000))
1536 *usec
= XINT (usec_l
);
1546 /* Check for overflow, helping the compiler for common cases
1547 where no runtime check is needed, and taking care not to
1548 convert negative numbers to unsigned before comparing them. */
1549 if (! ((TYPE_SIGNED (time_t)
1550 ? (TIME_T_MIN
>> 16 <= MOST_NEGATIVE_FIXNUM
1551 || TIME_T_MIN
>> 16 <= hi
)
1553 && (MOST_POSITIVE_FIXNUM
<= TIME_T_MAX
>> 16
1554 || hi
<= TIME_T_MAX
>> 16)))
1557 *result
= (hi
<< 16) + (XINT (low
) & 0xffff);
1562 DEFUN ("float-time", Ffloat_time
, Sfloat_time
, 0, 1, 0,
1563 doc
: /* Return the current time, as a float number of seconds since the epoch.
1564 If SPECIFIED-TIME is given, it is the time to convert to float
1565 instead of the current time. The argument should have the form
1566 (HIGH LOW) or (HIGH LOW USEC). Thus, you can use times obtained from
1567 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
1568 have the form (HIGH . LOW), but this is considered obsolete.
1570 WARNING: Since the result is floating point, it may not be exact.
1571 If precise time stamps are required, use either `current-time',
1572 or (if you need time as a string) `format-time-string'. */)
1573 (Lisp_Object specified_time
)
1578 if (! lisp_time_argument (specified_time
, &sec
, &usec
))
1579 error ("Invalid time specification");
1581 return make_float ((sec
* 1e6
+ usec
) / 1e6
);
1584 /* Write information into buffer S of size MAXSIZE, according to the
1585 FORMAT of length FORMAT_LEN, using time information taken from *TP.
1586 Default to Universal Time if UT is nonzero, local time otherwise.
1587 Use NS as the number of nanoseconds in the %N directive.
1588 Return the number of bytes written, not including the terminating
1589 '\0'. If S is NULL, nothing will be written anywhere; so to
1590 determine how many bytes would be written, use NULL for S and
1591 ((size_t) -1) for MAXSIZE.
1593 This function behaves like nstrftime, except it allows null
1594 bytes in FORMAT and it does not support nanoseconds. */
1596 emacs_nmemftime (char *s
, size_t maxsize
, const char *format
,
1597 size_t format_len
, const struct tm
*tp
, int ut
, int ns
)
1601 /* Loop through all the null-terminated strings in the format
1602 argument. Normally there's just one null-terminated string, but
1603 there can be arbitrarily many, concatenated together, if the
1604 format contains '\0' bytes. nstrftime stops at the first
1605 '\0' byte so we must invoke it separately for each such string. */
1614 result
= nstrftime (s
, maxsize
, format
, tp
, ut
, ns
);
1618 if (result
== 0 && s
[0] != '\0')
1623 maxsize
-= result
+ 1;
1625 len
= strlen (format
);
1626 if (len
== format_len
)
1630 format_len
-= len
+ 1;
1634 DEFUN ("format-time-string", Fformat_time_string
, Sformat_time_string
, 1, 3, 0,
1635 doc
: /* Use FORMAT-STRING to format the time TIME, or now if omitted.
1636 TIME is specified as (HIGH LOW . IGNORED), as returned by
1637 `current-time' or `file-attributes'. The obsolete form (HIGH . LOW)
1638 is also still accepted.
1639 The third, optional, argument UNIVERSAL, if non-nil, means describe TIME
1640 as Universal Time; nil means describe TIME in the local time zone.
1641 The value is a copy of FORMAT-STRING, but with certain constructs replaced
1642 by text that describes the specified date and time in TIME:
1644 %Y is the year, %y within the century, %C the century.
1645 %G is the year corresponding to the ISO week, %g within the century.
1646 %m is the numeric month.
1647 %b and %h are the locale's abbreviated month name, %B the full name.
1648 %d is the day of the month, zero-padded, %e is blank-padded.
1649 %u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.
1650 %a is the locale's abbreviated name of the day of week, %A the full name.
1651 %U is the week number starting on Sunday, %W starting on Monday,
1652 %V according to ISO 8601.
1653 %j is the day of the year.
1655 %H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H
1656 only blank-padded, %l is like %I blank-padded.
1657 %p is the locale's equivalent of either AM or PM.
1660 %N is the nanosecond, %6N the microsecond, %3N the millisecond, etc.
1661 %Z is the time zone name, %z is the numeric form.
1662 %s is the number of seconds since 1970-01-01 00:00:00 +0000.
1664 %c is the locale's date and time format.
1665 %x is the locale's "preferred" date format.
1666 %D is like "%m/%d/%y".
1668 %R is like "%H:%M", %T is like "%H:%M:%S", %r is like "%I:%M:%S %p".
1669 %X is the locale's "preferred" time format.
1671 Finally, %n is a newline, %t is a tab, %% is a literal %.
1673 Certain flags and modifiers are available with some format controls.
1674 The flags are `_', `-', `^' and `#'. For certain characters X,
1675 %_X is like %X, but padded with blanks; %-X is like %X,
1676 but without padding. %^X is like %X, but with all textual
1677 characters up-cased; %#X is like %X, but with letter-case of
1678 all textual characters reversed.
1679 %NX (where N stands for an integer) is like %X,
1680 but takes up at least N (a number) positions.
1681 The modifiers are `E' and `O'. For certain characters X,
1682 %EX is a locale's alternative version of %X;
1683 %OX is like %X, but uses the locale's number symbols.
1685 For example, to produce full ISO 8601 format, use "%Y-%m-%dT%T%z".
1687 usage: (format-time-string FORMAT-STRING &optional TIME UNIVERSAL) */)
1688 (Lisp_Object format_string
, Lisp_Object timeval
, Lisp_Object universal
)
1695 int ut
= ! NILP (universal
);
1697 CHECK_STRING (format_string
);
1699 if (! lisp_time_argument (timeval
, &value
, &usec
))
1700 error ("Invalid time specification");
1703 format_string
= code_convert_string_norecord (format_string
,
1704 Vlocale_coding_system
, 1);
1706 /* This is probably enough. */
1707 size
= SBYTES (format_string
);
1708 if (size
<= (STRING_BYTES_BOUND
- 50) / 6)
1709 size
= size
* 6 + 50;
1712 tm
= ut
? gmtime (&value
) : localtime (&value
);
1717 synchronize_system_time_locale ();
1721 char *buf
= (char *) alloca (size
+ 1);
1726 result
= emacs_nmemftime (buf
, size
, SSDATA (format_string
),
1727 SBYTES (format_string
),
1730 if ((result
> 0 && result
< size
) || (result
== 0 && buf
[0] == '\0'))
1731 return code_convert_string_norecord (make_unibyte_string (buf
, result
),
1732 Vlocale_coding_system
, 0);
1734 /* If buffer was too small, make it bigger and try again. */
1736 result
= emacs_nmemftime (NULL
, (size_t) -1,
1737 SSDATA (format_string
),
1738 SBYTES (format_string
),
1741 if (STRING_BYTES_BOUND
<= result
)
1747 DEFUN ("decode-time", Fdecode_time
, Sdecode_time
, 0, 1, 0,
1748 doc
: /* Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST ZONE).
1749 The optional SPECIFIED-TIME should be a list of (HIGH LOW . IGNORED),
1750 as from `current-time' and `file-attributes', or nil to use the
1751 current time. The obsolete form (HIGH . LOW) is also still accepted.
1752 The list has the following nine members: SEC is an integer between 0
1753 and 60; SEC is 60 for a leap second, which only some operating systems
1754 support. MINUTE is an integer between 0 and 59. HOUR is an integer
1755 between 0 and 23. DAY is an integer between 1 and 31. MONTH is an
1756 integer between 1 and 12. YEAR is an integer indicating the
1757 four-digit year. DOW is the day of week, an integer between 0 and 6,
1758 where 0 is Sunday. DST is t if daylight saving time is in effect,
1759 otherwise nil. ZONE is an integer indicating the number of seconds
1760 east of Greenwich. (Note that Common Lisp has different meanings for
1762 (Lisp_Object specified_time
)
1766 struct tm
*decoded_time
;
1767 Lisp_Object list_args
[9];
1769 if (! lisp_time_argument (specified_time
, &time_spec
, NULL
))
1770 error ("Invalid time specification");
1773 decoded_time
= localtime (&time_spec
);
1776 && MOST_NEGATIVE_FIXNUM
- TM_YEAR_BASE
<= decoded_time
->tm_year
1777 && decoded_time
->tm_year
<= MOST_POSITIVE_FIXNUM
- TM_YEAR_BASE
))
1779 XSETFASTINT (list_args
[0], decoded_time
->tm_sec
);
1780 XSETFASTINT (list_args
[1], decoded_time
->tm_min
);
1781 XSETFASTINT (list_args
[2], decoded_time
->tm_hour
);
1782 XSETFASTINT (list_args
[3], decoded_time
->tm_mday
);
1783 XSETFASTINT (list_args
[4], decoded_time
->tm_mon
+ 1);
1784 /* On 64-bit machines an int is narrower than EMACS_INT, thus the
1785 cast below avoids overflow in int arithmetics. */
1786 XSETINT (list_args
[5], TM_YEAR_BASE
+ (EMACS_INT
) decoded_time
->tm_year
);
1787 XSETFASTINT (list_args
[6], decoded_time
->tm_wday
);
1788 list_args
[7] = (decoded_time
->tm_isdst
)? Qt
: Qnil
;
1790 /* Make a copy, in case gmtime modifies the struct. */
1791 save_tm
= *decoded_time
;
1793 decoded_time
= gmtime (&time_spec
);
1795 if (decoded_time
== 0)
1796 list_args
[8] = Qnil
;
1798 XSETINT (list_args
[8], tm_diff (&save_tm
, decoded_time
));
1799 return Flist (9, list_args
);
1802 /* Return OBJ - OFFSET, checking that OBJ is a valid fixnum and that
1803 the result is representable as an int. Assume OFFSET is small and
1806 check_tm_member (Lisp_Object obj
, int offset
)
1811 if (! (INT_MIN
+ offset
<= n
&& n
- offset
<= INT_MAX
))
1816 DEFUN ("encode-time", Fencode_time
, Sencode_time
, 6, MANY
, 0,
1817 doc
: /* Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.
1818 This is the reverse operation of `decode-time', which see.
1819 ZONE defaults to the current time zone rule. This can
1820 be a string or t (as from `set-time-zone-rule'), or it can be a list
1821 \(as from `current-time-zone') or an integer (as from `decode-time')
1822 applied without consideration for daylight saving time.
1824 You can pass more than 7 arguments; then the first six arguments
1825 are used as SECOND through YEAR, and the *last* argument is used as ZONE.
1826 The intervening arguments are ignored.
1827 This feature lets (apply 'encode-time (decode-time ...)) work.
1829 Out-of-range values for SECOND, MINUTE, HOUR, DAY, or MONTH are allowed;
1830 for example, a DAY of 0 means the day preceding the given month.
1831 Year numbers less than 100 are treated just like other year numbers.
1832 If you want them to stand for years in this century, you must do that yourself.
1834 Years before 1970 are not guaranteed to work. On some systems,
1835 year values as low as 1901 do work.
1837 usage: (encode-time SECOND MINUTE HOUR DAY MONTH YEAR &optional ZONE) */)
1838 (ptrdiff_t nargs
, Lisp_Object
*args
)
1842 Lisp_Object zone
= (nargs
> 6 ? args
[nargs
- 1] : Qnil
);
1844 tm
.tm_sec
= check_tm_member (args
[0], 0);
1845 tm
.tm_min
= check_tm_member (args
[1], 0);
1846 tm
.tm_hour
= check_tm_member (args
[2], 0);
1847 tm
.tm_mday
= check_tm_member (args
[3], 0);
1848 tm
.tm_mon
= check_tm_member (args
[4], 1);
1849 tm
.tm_year
= check_tm_member (args
[5], TM_YEAR_BASE
);
1857 value
= mktime (&tm
);
1863 const char *tzstring
;
1864 char **oldenv
= environ
, **newenv
;
1868 else if (STRINGP (zone
))
1869 tzstring
= SSDATA (zone
);
1870 else if (INTEGERP (zone
))
1872 EMACS_INT abszone
= eabs (XINT (zone
));
1873 EMACS_INT zone_hr
= abszone
/ (60*60);
1874 int zone_min
= (abszone
/60) % 60;
1875 int zone_sec
= abszone
% 60;
1876 sprintf (tzbuf
, "XXX%s%"pI
"d:%02d:%02d", "-" + (XINT (zone
) < 0),
1877 zone_hr
, zone_min
, zone_sec
);
1881 error ("Invalid time zone specification");
1883 /* Set TZ before calling mktime; merely adjusting mktime's returned
1884 value doesn't suffice, since that would mishandle leap seconds. */
1885 set_time_zone_rule (tzstring
);
1888 value
= mktime (&tm
);
1891 /* Restore TZ to previous value. */
1895 #ifdef LOCALTIME_CACHE
1900 if (value
== (time_t) -1)
1903 return make_time (value
);
1906 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
, 0, 1, 0,
1907 doc
: /* Return the current local time, as a human-readable string.
1908 Programs can use this function to decode a time,
1909 since the number of columns in each field is fixed
1910 if the year is in the range 1000-9999.
1911 The format is `Sun Sep 16 01:03:52 1973'.
1912 However, see also the functions `decode-time' and `format-time-string'
1913 which provide a much more powerful and general facility.
1915 If SPECIFIED-TIME is given, it is a time to format instead of the
1916 current time. The argument should have the form (HIGH LOW . IGNORED).
1917 Thus, you can use times obtained from `current-time' and from
1918 `file-attributes'. SPECIFIED-TIME can also have the form (HIGH . LOW),
1919 but this is considered obsolete. */)
1920 (Lisp_Object specified_time
)
1926 if (! lisp_time_argument (specified_time
, &value
, NULL
))
1927 error ("Invalid time specification");
1929 /* Convert to a string, checking for out-of-range time stamps.
1930 Don't use 'ctime', as that might dump core if VALUE is out of
1933 tm
= localtime (&value
);
1935 if (! (tm
&& TM_YEAR_IN_ASCTIME_RANGE (tm
->tm_year
) && (tem
= asctime (tm
))))
1938 /* Remove the trailing newline. */
1939 tem
[strlen (tem
) - 1] = '\0';
1941 return build_string (tem
);
1944 /* Yield A - B, measured in seconds.
1945 This function is copied from the GNU C Library. */
1947 tm_diff (struct tm
*a
, struct tm
*b
)
1949 /* Compute intervening leap days correctly even if year is negative.
1950 Take care to avoid int overflow in leap day calculations,
1951 but it's OK to assume that A and B are close to each other. */
1952 int a4
= (a
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (a
->tm_year
& 3);
1953 int b4
= (b
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (b
->tm_year
& 3);
1954 int a100
= a4
/ 25 - (a4
% 25 < 0);
1955 int b100
= b4
/ 25 - (b4
% 25 < 0);
1956 int a400
= a100
>> 2;
1957 int b400
= b100
>> 2;
1958 int intervening_leap_days
= (a4
- b4
) - (a100
- b100
) + (a400
- b400
);
1959 int years
= a
->tm_year
- b
->tm_year
;
1960 int days
= (365 * years
+ intervening_leap_days
1961 + (a
->tm_yday
- b
->tm_yday
));
1962 return (60 * (60 * (24 * days
+ (a
->tm_hour
- b
->tm_hour
))
1963 + (a
->tm_min
- b
->tm_min
))
1964 + (a
->tm_sec
- b
->tm_sec
));
1967 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 1, 0,
1968 doc
: /* Return the offset and name for the local time zone.
1969 This returns a list of the form (OFFSET NAME).
1970 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).
1971 A negative value means west of Greenwich.
1972 NAME is a string giving the name of the time zone.
1973 If SPECIFIED-TIME is given, the time zone offset is determined from it
1974 instead of using the current time. The argument should have the form
1975 (HIGH LOW . IGNORED). Thus, you can use times obtained from
1976 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
1977 have the form (HIGH . LOW), but this is considered obsolete.
1979 Some operating systems cannot provide all this information to Emacs;
1980 in this case, `current-time-zone' returns a list containing nil for
1981 the data it can't find. */)
1982 (Lisp_Object specified_time
)
1988 if (!lisp_time_argument (specified_time
, &value
, NULL
))
1993 t
= gmtime (&value
);
1997 t
= localtime (&value
);
2004 int offset
= tm_diff (t
, &gmt
);
2006 char buf
[sizeof "+00" + INT_STRLEN_BOUND (int)];
2010 s
= (char *)t
->tm_zone
;
2011 #else /* not HAVE_TM_ZONE */
2013 if (t
->tm_isdst
== 0 || t
->tm_isdst
== 1)
2014 s
= tzname
[t
->tm_isdst
];
2016 #endif /* not HAVE_TM_ZONE */
2020 /* No local time zone name is available; use "+-NNNN" instead. */
2021 int m
= offset
/ 60;
2022 int am
= offset
< 0 ? - m
: m
;
2023 sprintf (buf
, "%c%02d%02d", (offset
< 0 ? '-' : '+'), am
/60, am
%60);
2027 return Fcons (make_number (offset
), Fcons (build_string (s
), Qnil
));
2030 return Fmake_list (make_number (2), Qnil
);
2033 /* This holds the value of `environ' produced by the previous
2034 call to Fset_time_zone_rule, or 0 if Fset_time_zone_rule
2035 has never been called. */
2036 static char **environbuf
;
2038 /* This holds the startup value of the TZ environment variable so it
2039 can be restored if the user calls set-time-zone-rule with a nil
2041 static char *initial_tz
;
2043 DEFUN ("set-time-zone-rule", Fset_time_zone_rule
, Sset_time_zone_rule
, 1, 1, 0,
2044 doc
: /* Set the local time zone using TZ, a string specifying a time zone rule.
2045 If TZ is nil, use implementation-defined default time zone information.
2046 If TZ is t, use Universal Time.
2048 Instead of calling this function, you typically want (setenv "TZ" TZ).
2049 That changes both the environment of the Emacs process and the
2050 variable `process-environment', whereas `set-time-zone-rule' affects
2051 only the former. */)
2054 const char *tzstring
;
2056 /* When called for the first time, save the original TZ. */
2058 initial_tz
= (char *) getenv ("TZ");
2061 tzstring
= initial_tz
;
2062 else if (EQ (tz
, Qt
))
2067 tzstring
= SSDATA (tz
);
2070 set_time_zone_rule (tzstring
);
2072 environbuf
= environ
;
2077 #ifdef LOCALTIME_CACHE
2079 /* These two values are known to load tz files in buggy implementations,
2080 i.e. Solaris 1 executables running under either Solaris 1 or Solaris 2.
2081 Their values shouldn't matter in non-buggy implementations.
2082 We don't use string literals for these strings,
2083 since if a string in the environment is in readonly
2084 storage, it runs afoul of bugs in SVR4 and Solaris 2.3.
2085 See Sun bugs 1113095 and 1114114, ``Timezone routines
2086 improperly modify environment''. */
2088 static char set_time_zone_rule_tz1
[] = "TZ=GMT+0";
2089 static char set_time_zone_rule_tz2
[] = "TZ=GMT+1";
2093 /* Set the local time zone rule to TZSTRING.
2094 This allocates memory into `environ', which it is the caller's
2095 responsibility to free. */
2098 set_time_zone_rule (const char *tzstring
)
2101 char **from
, **to
, **newenv
;
2103 /* Make the ENVIRON vector longer with room for TZSTRING. */
2104 for (from
= environ
; *from
; from
++)
2106 envptrs
= from
- environ
+ 2;
2107 newenv
= to
= (char **) xmalloc (envptrs
* sizeof (char *)
2108 + (tzstring
? strlen (tzstring
) + 4 : 0));
2110 /* Add TZSTRING to the end of environ, as a value for TZ. */
2113 char *t
= (char *) (to
+ envptrs
);
2115 strcat (t
, tzstring
);
2119 /* Copy the old environ vector elements into NEWENV,
2120 but don't copy the TZ variable.
2121 So we have only one definition of TZ, which came from TZSTRING. */
2122 for (from
= environ
; *from
; from
++)
2123 if (strncmp (*from
, "TZ=", 3) != 0)
2129 /* If we do have a TZSTRING, NEWENV points to the vector slot where
2130 the TZ variable is stored. If we do not have a TZSTRING,
2131 TO points to the vector slot which has the terminating null. */
2133 #ifdef LOCALTIME_CACHE
2135 /* In SunOS 4.1.3_U1 and 4.1.4, if TZ has a value like
2136 "US/Pacific" that loads a tz file, then changes to a value like
2137 "XXX0" that does not load a tz file, and then changes back to
2138 its original value, the last change is (incorrectly) ignored.
2139 Also, if TZ changes twice in succession to values that do
2140 not load a tz file, tzset can dump core (see Sun bug#1225179).
2141 The following code works around these bugs. */
2145 /* Temporarily set TZ to a value that loads a tz file
2146 and that differs from tzstring. */
2148 *newenv
= (strcmp (tzstring
, set_time_zone_rule_tz1
+ 3) == 0
2149 ? set_time_zone_rule_tz2
: set_time_zone_rule_tz1
);
2155 /* The implied tzstring is unknown, so temporarily set TZ to
2156 two different values that each load a tz file. */
2157 *to
= set_time_zone_rule_tz1
;
2160 *to
= set_time_zone_rule_tz2
;
2165 /* Now TZ has the desired value, and tzset can be invoked safely. */
2172 /* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC
2173 (if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a
2174 type of object is Lisp_String). INHERIT is passed to
2175 INSERT_FROM_STRING_FUNC as the last argument. */
2178 general_insert_function (void (*insert_func
)
2179 (const char *, ptrdiff_t),
2180 void (*insert_from_string_func
)
2181 (Lisp_Object
, ptrdiff_t, ptrdiff_t,
2182 ptrdiff_t, ptrdiff_t, int),
2183 int inherit
, ptrdiff_t nargs
, Lisp_Object
*args
)
2186 register Lisp_Object val
;
2188 for (argnum
= 0; argnum
< nargs
; argnum
++)
2191 if (CHARACTERP (val
))
2193 int c
= XFASTINT (val
);
2194 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2197 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2198 len
= CHAR_STRING (c
, str
);
2201 str
[0] = ASCII_CHAR_P (c
) ? c
: multibyte_char_to_unibyte (c
);
2204 (*insert_func
) ((char *) str
, len
);
2206 else if (STRINGP (val
))
2208 (*insert_from_string_func
) (val
, 0, 0,
2214 wrong_type_argument (Qchar_or_string_p
, val
);
2219 insert1 (Lisp_Object arg
)
2225 /* Callers passing one argument to Finsert need not gcpro the
2226 argument "array", since the only element of the array will
2227 not be used after calling insert or insert_from_string, so
2228 we don't care if it gets trashed. */
2230 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
2231 doc
: /* Insert the arguments, either strings or characters, at point.
2232 Point and before-insertion markers move forward to end up
2233 after the inserted text.
2234 Any other markers at the point of insertion remain before the text.
2236 If the current buffer is multibyte, unibyte strings are converted
2237 to multibyte for insertion (see `string-make-multibyte').
2238 If the current buffer is unibyte, multibyte strings are converted
2239 to unibyte for insertion (see `string-make-unibyte').
2241 When operating on binary data, it may be necessary to preserve the
2242 original bytes of a unibyte string when inserting it into a multibyte
2243 buffer; to accomplish this, apply `string-as-multibyte' to the string
2244 and insert the result.
2246 usage: (insert &rest ARGS) */)
2247 (ptrdiff_t nargs
, Lisp_Object
*args
)
2249 general_insert_function (insert
, insert_from_string
, 0, nargs
, args
);
2253 DEFUN ("insert-and-inherit", Finsert_and_inherit
, Sinsert_and_inherit
,
2255 doc
: /* Insert the arguments at point, inheriting properties from adjoining text.
2256 Point and before-insertion markers move forward to end up
2257 after the inserted text.
2258 Any other markers at the point of insertion remain before the text.
2260 If the current buffer is multibyte, unibyte strings are converted
2261 to multibyte for insertion (see `unibyte-char-to-multibyte').
2262 If the current buffer is unibyte, multibyte strings are converted
2263 to unibyte for insertion.
2265 usage: (insert-and-inherit &rest ARGS) */)
2266 (ptrdiff_t nargs
, Lisp_Object
*args
)
2268 general_insert_function (insert_and_inherit
, insert_from_string
, 1,
2273 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
2274 doc
: /* Insert strings or characters at point, relocating markers after the text.
2275 Point and markers move forward to end up after the inserted text.
2277 If the current buffer is multibyte, unibyte strings are converted
2278 to multibyte for insertion (see `unibyte-char-to-multibyte').
2279 If the current buffer is unibyte, multibyte strings are converted
2280 to unibyte for insertion.
2282 usage: (insert-before-markers &rest ARGS) */)
2283 (ptrdiff_t nargs
, Lisp_Object
*args
)
2285 general_insert_function (insert_before_markers
,
2286 insert_from_string_before_markers
, 0,
2291 DEFUN ("insert-before-markers-and-inherit", Finsert_and_inherit_before_markers
,
2292 Sinsert_and_inherit_before_markers
, 0, MANY
, 0,
2293 doc
: /* Insert text at point, relocating markers and inheriting properties.
2294 Point and markers move forward to end up after the inserted text.
2296 If the current buffer is multibyte, unibyte strings are converted
2297 to multibyte for insertion (see `unibyte-char-to-multibyte').
2298 If the current buffer is unibyte, multibyte strings are converted
2299 to unibyte for insertion.
2301 usage: (insert-before-markers-and-inherit &rest ARGS) */)
2302 (ptrdiff_t nargs
, Lisp_Object
*args
)
2304 general_insert_function (insert_before_markers_and_inherit
,
2305 insert_from_string_before_markers
, 1,
2310 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 2, 3, 0,
2311 doc
: /* Insert COUNT copies of CHARACTER.
2312 Point, and before-insertion markers, are relocated as in the function `insert'.
2313 The optional third arg INHERIT, if non-nil, says to inherit text properties
2314 from adjoining text, if those properties are sticky. */)
2315 (Lisp_Object character
, Lisp_Object count
, Lisp_Object inherit
)
2318 register ptrdiff_t n
;
2320 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2323 CHECK_CHARACTER (character
);
2324 CHECK_NUMBER (count
);
2325 c
= XFASTINT (character
);
2327 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2328 len
= CHAR_STRING (c
, str
);
2330 str
[0] = c
, len
= 1;
2331 if (XINT (count
) <= 0)
2333 if (BUF_BYTES_MAX
/ len
< XINT (count
))
2335 n
= XINT (count
) * len
;
2336 stringlen
= min (n
, sizeof string
- sizeof string
% len
);
2337 for (i
= 0; i
< stringlen
; i
++)
2338 string
[i
] = str
[i
% len
];
2339 while (n
> stringlen
)
2342 if (!NILP (inherit
))
2343 insert_and_inherit (string
, stringlen
);
2345 insert (string
, stringlen
);
2348 if (!NILP (inherit
))
2349 insert_and_inherit (string
, n
);
2355 DEFUN ("insert-byte", Finsert_byte
, Sinsert_byte
, 2, 3, 0,
2356 doc
: /* Insert COUNT (second arg) copies of BYTE (first arg).
2357 Both arguments are required.
2358 BYTE is a number of the range 0..255.
2360 If BYTE is 128..255 and the current buffer is multibyte, the
2361 corresponding eight-bit character is inserted.
2363 Point, and before-insertion markers, are relocated as in the function `insert'.
2364 The optional third arg INHERIT, if non-nil, says to inherit text properties
2365 from adjoining text, if those properties are sticky. */)
2366 (Lisp_Object byte
, Lisp_Object count
, Lisp_Object inherit
)
2368 CHECK_NUMBER (byte
);
2369 if (XINT (byte
) < 0 || XINT (byte
) > 255)
2370 args_out_of_range_3 (byte
, make_number (0), make_number (255));
2371 if (XINT (byte
) >= 128
2372 && ! NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2373 XSETFASTINT (byte
, BYTE8_TO_CHAR (XINT (byte
)));
2374 return Finsert_char (byte
, count
, inherit
);
2378 /* Making strings from buffer contents. */
2380 /* Return a Lisp_String containing the text of the current buffer from
2381 START to END. If text properties are in use and the current buffer
2382 has properties in the range specified, the resulting string will also
2383 have them, if PROPS is nonzero.
2385 We don't want to use plain old make_string here, because it calls
2386 make_uninit_string, which can cause the buffer arena to be
2387 compacted. make_string has no way of knowing that the data has
2388 been moved, and thus copies the wrong data into the string. This
2389 doesn't effect most of the other users of make_string, so it should
2390 be left as is. But we should use this function when conjuring
2391 buffer substrings. */
2394 make_buffer_string (ptrdiff_t start
, ptrdiff_t end
, int props
)
2396 ptrdiff_t start_byte
= CHAR_TO_BYTE (start
);
2397 ptrdiff_t end_byte
= CHAR_TO_BYTE (end
);
2399 return make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
);
2402 /* Return a Lisp_String containing the text of the current buffer from
2403 START / START_BYTE to END / END_BYTE.
2405 If text properties are in use and the current buffer
2406 has properties in the range specified, the resulting string will also
2407 have them, if PROPS is nonzero.
2409 We don't want to use plain old make_string here, because it calls
2410 make_uninit_string, which can cause the buffer arena to be
2411 compacted. make_string has no way of knowing that the data has
2412 been moved, and thus copies the wrong data into the string. This
2413 doesn't effect most of the other users of make_string, so it should
2414 be left as is. But we should use this function when conjuring
2415 buffer substrings. */
2418 make_buffer_string_both (ptrdiff_t start
, ptrdiff_t start_byte
,
2419 ptrdiff_t end
, ptrdiff_t end_byte
, int props
)
2421 Lisp_Object result
, tem
, tem1
;
2423 if (start
< GPT
&& GPT
< end
)
2426 if (! NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2427 result
= make_uninit_multibyte_string (end
- start
, end_byte
- start_byte
);
2429 result
= make_uninit_string (end
- start
);
2430 memcpy (SDATA (result
), BYTE_POS_ADDR (start_byte
), end_byte
- start_byte
);
2432 /* If desired, update and copy the text properties. */
2435 update_buffer_properties (start
, end
);
2437 tem
= Fnext_property_change (make_number (start
), Qnil
, make_number (end
));
2438 tem1
= Ftext_properties_at (make_number (start
), Qnil
);
2440 if (XINT (tem
) != end
|| !NILP (tem1
))
2441 copy_intervals_to_string (result
, current_buffer
, start
,
2448 /* Call Vbuffer_access_fontify_functions for the range START ... END
2449 in the current buffer, if necessary. */
2452 update_buffer_properties (ptrdiff_t start
, ptrdiff_t end
)
2454 /* If this buffer has some access functions,
2455 call them, specifying the range of the buffer being accessed. */
2456 if (!NILP (Vbuffer_access_fontify_functions
))
2458 Lisp_Object args
[3];
2461 args
[0] = Qbuffer_access_fontify_functions
;
2462 XSETINT (args
[1], start
);
2463 XSETINT (args
[2], end
);
2465 /* But don't call them if we can tell that the work
2466 has already been done. */
2467 if (!NILP (Vbuffer_access_fontified_property
))
2469 tem
= Ftext_property_any (args
[1], args
[2],
2470 Vbuffer_access_fontified_property
,
2473 Frun_hook_with_args (3, args
);
2476 Frun_hook_with_args (3, args
);
2480 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
2481 doc
: /* Return the contents of part of the current buffer as a string.
2482 The two arguments START and END are character positions;
2483 they can be in either order.
2484 The string returned is multibyte if the buffer is multibyte.
2486 This function copies the text properties of that part of the buffer
2487 into the result string; if you don't want the text properties,
2488 use `buffer-substring-no-properties' instead. */)
2489 (Lisp_Object start
, Lisp_Object end
)
2491 register ptrdiff_t b
, e
;
2493 validate_region (&start
, &end
);
2497 return make_buffer_string (b
, e
, 1);
2500 DEFUN ("buffer-substring-no-properties", Fbuffer_substring_no_properties
,
2501 Sbuffer_substring_no_properties
, 2, 2, 0,
2502 doc
: /* Return the characters of part of the buffer, without the text properties.
2503 The two arguments START and END are character positions;
2504 they can be in either order. */)
2505 (Lisp_Object start
, Lisp_Object end
)
2507 register ptrdiff_t b
, e
;
2509 validate_region (&start
, &end
);
2513 return make_buffer_string (b
, e
, 0);
2516 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
2517 doc
: /* Return the contents of the current buffer as a string.
2518 If narrowing is in effect, this function returns only the visible part
2522 return make_buffer_string (BEGV
, ZV
, 1);
2525 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
2527 doc
: /* Insert before point a substring of the contents of BUFFER.
2528 BUFFER may be a buffer or a buffer name.
2529 Arguments START and END are character positions specifying the substring.
2530 They default to the values of (point-min) and (point-max) in BUFFER. */)
2531 (Lisp_Object buffer
, Lisp_Object start
, Lisp_Object end
)
2533 register EMACS_INT b
, e
, temp
;
2534 register struct buffer
*bp
, *obuf
;
2537 buf
= Fget_buffer (buffer
);
2541 if (NILP (BVAR (bp
, name
)))
2542 error ("Selecting deleted buffer");
2548 CHECK_NUMBER_COERCE_MARKER (start
);
2555 CHECK_NUMBER_COERCE_MARKER (end
);
2560 temp
= b
, b
= e
, e
= temp
;
2562 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
2563 args_out_of_range (start
, end
);
2565 obuf
= current_buffer
;
2566 set_buffer_internal_1 (bp
);
2567 update_buffer_properties (b
, e
);
2568 set_buffer_internal_1 (obuf
);
2570 insert_from_buffer (bp
, b
, e
- b
, 0);
2574 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
2576 doc
: /* Compare two substrings of two buffers; return result as number.
2577 the value is -N if first string is less after N-1 chars,
2578 +N if first string is greater after N-1 chars, or 0 if strings match.
2579 Each substring is represented as three arguments: BUFFER, START and END.
2580 That makes six args in all, three for each substring.
2582 The value of `case-fold-search' in the current buffer
2583 determines whether case is significant or ignored. */)
2584 (Lisp_Object buffer1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object buffer2
, Lisp_Object start2
, Lisp_Object end2
)
2586 register EMACS_INT begp1
, endp1
, begp2
, endp2
, temp
;
2587 register struct buffer
*bp1
, *bp2
;
2588 register Lisp_Object trt
2589 = (!NILP (BVAR (current_buffer
, case_fold_search
))
2590 ? BVAR (current_buffer
, case_canon_table
) : Qnil
);
2591 ptrdiff_t chars
= 0;
2592 ptrdiff_t i1
, i2
, i1_byte
, i2_byte
;
2594 /* Find the first buffer and its substring. */
2597 bp1
= current_buffer
;
2601 buf1
= Fget_buffer (buffer1
);
2604 bp1
= XBUFFER (buf1
);
2605 if (NILP (BVAR (bp1
, name
)))
2606 error ("Selecting deleted buffer");
2610 begp1
= BUF_BEGV (bp1
);
2613 CHECK_NUMBER_COERCE_MARKER (start1
);
2614 begp1
= XINT (start1
);
2617 endp1
= BUF_ZV (bp1
);
2620 CHECK_NUMBER_COERCE_MARKER (end1
);
2621 endp1
= XINT (end1
);
2625 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
2627 if (!(BUF_BEGV (bp1
) <= begp1
2629 && endp1
<= BUF_ZV (bp1
)))
2630 args_out_of_range (start1
, end1
);
2632 /* Likewise for second substring. */
2635 bp2
= current_buffer
;
2639 buf2
= Fget_buffer (buffer2
);
2642 bp2
= XBUFFER (buf2
);
2643 if (NILP (BVAR (bp2
, name
)))
2644 error ("Selecting deleted buffer");
2648 begp2
= BUF_BEGV (bp2
);
2651 CHECK_NUMBER_COERCE_MARKER (start2
);
2652 begp2
= XINT (start2
);
2655 endp2
= BUF_ZV (bp2
);
2658 CHECK_NUMBER_COERCE_MARKER (end2
);
2659 endp2
= XINT (end2
);
2663 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
2665 if (!(BUF_BEGV (bp2
) <= begp2
2667 && endp2
<= BUF_ZV (bp2
)))
2668 args_out_of_range (start2
, end2
);
2672 i1_byte
= buf_charpos_to_bytepos (bp1
, i1
);
2673 i2_byte
= buf_charpos_to_bytepos (bp2
, i2
);
2675 while (i1
< endp1
&& i2
< endp2
)
2677 /* When we find a mismatch, we must compare the
2678 characters, not just the bytes. */
2683 if (! NILP (BVAR (bp1
, enable_multibyte_characters
)))
2685 c1
= BUF_FETCH_MULTIBYTE_CHAR (bp1
, i1_byte
);
2686 BUF_INC_POS (bp1
, i1_byte
);
2691 c1
= BUF_FETCH_BYTE (bp1
, i1
);
2692 MAKE_CHAR_MULTIBYTE (c1
);
2696 if (! NILP (BVAR (bp2
, enable_multibyte_characters
)))
2698 c2
= BUF_FETCH_MULTIBYTE_CHAR (bp2
, i2_byte
);
2699 BUF_INC_POS (bp2
, i2_byte
);
2704 c2
= BUF_FETCH_BYTE (bp2
, i2
);
2705 MAKE_CHAR_MULTIBYTE (c2
);
2711 c1
= CHAR_TABLE_TRANSLATE (trt
, c1
);
2712 c2
= CHAR_TABLE_TRANSLATE (trt
, c2
);
2715 return make_number (- 1 - chars
);
2717 return make_number (chars
+ 1);
2722 /* The strings match as far as they go.
2723 If one is shorter, that one is less. */
2724 if (chars
< endp1
- begp1
)
2725 return make_number (chars
+ 1);
2726 else if (chars
< endp2
- begp2
)
2727 return make_number (- chars
- 1);
2729 /* Same length too => they are equal. */
2730 return make_number (0);
2734 subst_char_in_region_unwind (Lisp_Object arg
)
2736 return BVAR (current_buffer
, undo_list
) = arg
;
2740 subst_char_in_region_unwind_1 (Lisp_Object arg
)
2742 return BVAR (current_buffer
, filename
) = arg
;
2745 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
2746 Ssubst_char_in_region
, 4, 5, 0,
2747 doc
: /* From START to END, replace FROMCHAR with TOCHAR each time it occurs.
2748 If optional arg NOUNDO is non-nil, don't record this change for undo
2749 and don't mark the buffer as really changed.
2750 Both characters must have the same length of multi-byte form. */)
2751 (Lisp_Object start
, Lisp_Object end
, Lisp_Object fromchar
, Lisp_Object tochar
, Lisp_Object noundo
)
2753 register ptrdiff_t pos
, pos_byte
, stop
, i
, len
, end_byte
;
2754 /* Keep track of the first change in the buffer:
2755 if 0 we haven't found it yet.
2756 if < 0 we've found it and we've run the before-change-function.
2757 if > 0 we've actually performed it and the value is its position. */
2758 ptrdiff_t changed
= 0;
2759 unsigned char fromstr
[MAX_MULTIBYTE_LENGTH
], tostr
[MAX_MULTIBYTE_LENGTH
];
2761 ptrdiff_t count
= SPECPDL_INDEX ();
2762 #define COMBINING_NO 0
2763 #define COMBINING_BEFORE 1
2764 #define COMBINING_AFTER 2
2765 #define COMBINING_BOTH (COMBINING_BEFORE | COMBINING_AFTER)
2766 int maybe_byte_combining
= COMBINING_NO
;
2767 ptrdiff_t last_changed
= 0;
2768 int multibyte_p
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
2773 validate_region (&start
, &end
);
2774 CHECK_CHARACTER (fromchar
);
2775 CHECK_CHARACTER (tochar
);
2776 fromc
= XFASTINT (fromchar
);
2777 toc
= XFASTINT (tochar
);
2781 len
= CHAR_STRING (fromc
, fromstr
);
2782 if (CHAR_STRING (toc
, tostr
) != len
)
2783 error ("Characters in `subst-char-in-region' have different byte-lengths");
2784 if (!ASCII_BYTE_P (*tostr
))
2786 /* If *TOSTR is in the range 0x80..0x9F and TOCHAR is not a
2787 complete multibyte character, it may be combined with the
2788 after bytes. If it is in the range 0xA0..0xFF, it may be
2789 combined with the before and after bytes. */
2790 if (!CHAR_HEAD_P (*tostr
))
2791 maybe_byte_combining
= COMBINING_BOTH
;
2792 else if (BYTES_BY_CHAR_HEAD (*tostr
) > len
)
2793 maybe_byte_combining
= COMBINING_AFTER
;
2804 pos_byte
= CHAR_TO_BYTE (pos
);
2805 stop
= CHAR_TO_BYTE (XINT (end
));
2808 /* If we don't want undo, turn off putting stuff on the list.
2809 That's faster than getting rid of things,
2810 and it prevents even the entry for a first change.
2811 Also inhibit locking the file. */
2812 if (!changed
&& !NILP (noundo
))
2814 record_unwind_protect (subst_char_in_region_unwind
,
2815 BVAR (current_buffer
, undo_list
));
2816 BVAR (current_buffer
, undo_list
) = Qt
;
2817 /* Don't do file-locking. */
2818 record_unwind_protect (subst_char_in_region_unwind_1
,
2819 BVAR (current_buffer
, filename
));
2820 BVAR (current_buffer
, filename
) = Qnil
;
2823 if (pos_byte
< GPT_BYTE
)
2824 stop
= min (stop
, GPT_BYTE
);
2827 ptrdiff_t pos_byte_next
= pos_byte
;
2829 if (pos_byte
>= stop
)
2831 if (pos_byte
>= end_byte
) break;
2834 p
= BYTE_POS_ADDR (pos_byte
);
2836 INC_POS (pos_byte_next
);
2839 if (pos_byte_next
- pos_byte
== len
2840 && p
[0] == fromstr
[0]
2842 || (p
[1] == fromstr
[1]
2843 && (len
== 2 || (p
[2] == fromstr
[2]
2844 && (len
== 3 || p
[3] == fromstr
[3]))))))
2847 /* We've already seen this and run the before-change-function;
2848 this time we only need to record the actual position. */
2853 modify_region (current_buffer
, pos
, XINT (end
), 0);
2855 if (! NILP (noundo
))
2857 if (MODIFF
- 1 == SAVE_MODIFF
)
2859 if (MODIFF
- 1 == BUF_AUTOSAVE_MODIFF (current_buffer
))
2860 BUF_AUTOSAVE_MODIFF (current_buffer
)++;
2863 /* The before-change-function may have moved the gap
2864 or even modified the buffer so we should start over. */
2868 /* Take care of the case where the new character
2869 combines with neighboring bytes. */
2870 if (maybe_byte_combining
2871 && (maybe_byte_combining
== COMBINING_AFTER
2872 ? (pos_byte_next
< Z_BYTE
2873 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2874 : ((pos_byte_next
< Z_BYTE
2875 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2876 || (pos_byte
> BEG_BYTE
2877 && ! ASCII_BYTE_P (FETCH_BYTE (pos_byte
- 1))))))
2879 Lisp_Object tem
, string
;
2881 struct gcpro gcpro1
;
2883 tem
= BVAR (current_buffer
, undo_list
);
2886 /* Make a multibyte string containing this single character. */
2887 string
= make_multibyte_string ((char *) tostr
, 1, len
);
2888 /* replace_range is less efficient, because it moves the gap,
2889 but it handles combining correctly. */
2890 replace_range (pos
, pos
+ 1, string
,
2892 pos_byte_next
= CHAR_TO_BYTE (pos
);
2893 if (pos_byte_next
> pos_byte
)
2894 /* Before combining happened. We should not increment
2895 POS. So, to cancel the later increment of POS,
2899 INC_POS (pos_byte_next
);
2901 if (! NILP (noundo
))
2902 BVAR (current_buffer
, undo_list
) = tem
;
2909 record_change (pos
, 1);
2910 for (i
= 0; i
< len
; i
++) *p
++ = tostr
[i
];
2912 last_changed
= pos
+ 1;
2914 pos_byte
= pos_byte_next
;
2920 signal_after_change (changed
,
2921 last_changed
- changed
, last_changed
- changed
);
2922 update_compositions (changed
, last_changed
, CHECK_ALL
);
2925 unbind_to (count
, Qnil
);
2930 static Lisp_Object
check_translation (ptrdiff_t, ptrdiff_t, ptrdiff_t,
2933 /* Helper function for Ftranslate_region_internal.
2935 Check if a character sequence at POS (POS_BYTE) matches an element
2936 of VAL. VAL is a list (([FROM-CHAR ...] . TO) ...). If a matching
2937 element is found, return it. Otherwise return Qnil. */
2940 check_translation (ptrdiff_t pos
, ptrdiff_t pos_byte
, ptrdiff_t end
,
2943 int buf_size
= 16, buf_used
= 0;
2944 int *buf
= alloca (sizeof (int) * buf_size
);
2946 for (; CONSP (val
); val
= XCDR (val
))
2955 if (! VECTORP (elt
))
2958 if (len
<= end
- pos
)
2960 for (i
= 0; i
< len
; i
++)
2964 unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
2967 if (buf_used
== buf_size
)
2972 newbuf
= alloca (sizeof (int) * buf_size
);
2973 memcpy (newbuf
, buf
, sizeof (int) * buf_used
);
2976 buf
[buf_used
++] = STRING_CHAR_AND_LENGTH (p
, len1
);
2979 if (XINT (AREF (elt
, i
)) != buf
[i
])
2990 DEFUN ("translate-region-internal", Ftranslate_region_internal
,
2991 Stranslate_region_internal
, 3, 3, 0,
2992 doc
: /* Internal use only.
2993 From START to END, translate characters according to TABLE.
2994 TABLE is a string or a char-table; the Nth character in it is the
2995 mapping for the character with code N.
2996 It returns the number of characters changed. */)
2997 (Lisp_Object start
, Lisp_Object end
, register Lisp_Object table
)
2999 register unsigned char *tt
; /* Trans table. */
3000 register int nc
; /* New character. */
3001 int cnt
; /* Number of changes made. */
3002 ptrdiff_t size
; /* Size of translate table. */
3003 ptrdiff_t pos
, pos_byte
, end_pos
;
3004 int multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3005 int string_multibyte
IF_LINT (= 0);
3007 validate_region (&start
, &end
);
3008 if (CHAR_TABLE_P (table
))
3010 if (! EQ (XCHAR_TABLE (table
)->purpose
, Qtranslation_table
))
3011 error ("Not a translation table");
3017 CHECK_STRING (table
);
3019 if (! multibyte
&& (SCHARS (table
) < SBYTES (table
)))
3020 table
= string_make_unibyte (table
);
3021 string_multibyte
= SCHARS (table
) < SBYTES (table
);
3022 size
= SBYTES (table
);
3027 pos_byte
= CHAR_TO_BYTE (pos
);
3028 end_pos
= XINT (end
);
3029 modify_region (current_buffer
, pos
, end_pos
, 0);
3032 for (; pos
< end_pos
; )
3034 register unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
3035 unsigned char *str
, buf
[MAX_MULTIBYTE_LENGTH
];
3041 oc
= STRING_CHAR_AND_LENGTH (p
, len
);
3048 /* Reload as signal_after_change in last iteration may GC. */
3050 if (string_multibyte
)
3052 str
= tt
+ string_char_to_byte (table
, oc
);
3053 nc
= STRING_CHAR_AND_LENGTH (str
, str_len
);
3058 if (! ASCII_BYTE_P (nc
) && multibyte
)
3060 str_len
= BYTE8_STRING (nc
, buf
);
3073 val
= CHAR_TABLE_REF (table
, oc
);
3074 if (CHARACTERP (val
))
3076 nc
= XFASTINT (val
);
3077 str_len
= CHAR_STRING (nc
, buf
);
3080 else if (VECTORP (val
) || (CONSP (val
)))
3082 /* VAL is [TO_CHAR ...] or (([FROM-CHAR ...] . TO) ...)
3083 where TO is TO-CHAR or [TO-CHAR ...]. */
3088 if (nc
!= oc
&& nc
>= 0)
3090 /* Simple one char to one char translation. */
3095 /* This is less efficient, because it moves the gap,
3096 but it should handle multibyte characters correctly. */
3097 string
= make_multibyte_string ((char *) str
, 1, str_len
);
3098 replace_range (pos
, pos
+ 1, string
, 1, 0, 1);
3103 record_change (pos
, 1);
3104 while (str_len
-- > 0)
3106 signal_after_change (pos
, 1, 1);
3107 update_compositions (pos
, pos
+ 1, CHECK_BORDER
);
3117 val
= check_translation (pos
, pos_byte
, end_pos
, val
);
3124 /* VAL is ([FROM-CHAR ...] . TO). */
3125 len
= ASIZE (XCAR (val
));
3133 string
= Fconcat (1, &val
);
3137 string
= Fmake_string (make_number (1), val
);
3139 replace_range (pos
, pos
+ len
, string
, 1, 0, 1);
3140 pos_byte
+= SBYTES (string
);
3141 pos
+= SCHARS (string
);
3142 cnt
+= SCHARS (string
);
3143 end_pos
+= SCHARS (string
) - len
;
3151 return make_number (cnt
);
3154 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
3155 doc
: /* Delete the text between START and END.
3156 If called interactively, delete the region between point and mark.
3157 This command deletes buffer text without modifying the kill ring. */)
3158 (Lisp_Object start
, Lisp_Object end
)
3160 validate_region (&start
, &end
);
3161 del_range (XINT (start
), XINT (end
));
3165 DEFUN ("delete-and-extract-region", Fdelete_and_extract_region
,
3166 Sdelete_and_extract_region
, 2, 2, 0,
3167 doc
: /* Delete the text between START and END and return it. */)
3168 (Lisp_Object start
, Lisp_Object end
)
3170 validate_region (&start
, &end
);
3171 if (XINT (start
) == XINT (end
))
3172 return empty_unibyte_string
;
3173 return del_range_1 (XINT (start
), XINT (end
), 1, 1);
3176 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
3177 doc
: /* Remove restrictions (narrowing) from current buffer.
3178 This allows the buffer's full text to be seen and edited. */)
3181 if (BEG
!= BEGV
|| Z
!= ZV
)
3182 current_buffer
->clip_changed
= 1;
3184 BEGV_BYTE
= BEG_BYTE
;
3185 SET_BUF_ZV_BOTH (current_buffer
, Z
, Z_BYTE
);
3186 /* Changing the buffer bounds invalidates any recorded current column. */
3187 invalidate_current_column ();
3191 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
3192 doc
: /* Restrict editing in this buffer to the current region.
3193 The rest of the text becomes temporarily invisible and untouchable
3194 but is not deleted; if you save the buffer in a file, the invisible
3195 text is included in the file. \\[widen] makes all visible again.
3196 See also `save-restriction'.
3198 When calling from a program, pass two arguments; positions (integers
3199 or markers) bounding the text that should remain visible. */)
3200 (register Lisp_Object start
, Lisp_Object end
)
3202 CHECK_NUMBER_COERCE_MARKER (start
);
3203 CHECK_NUMBER_COERCE_MARKER (end
);
3205 if (XINT (start
) > XINT (end
))
3208 tem
= start
; start
= end
; end
= tem
;
3211 if (!(BEG
<= XINT (start
) && XINT (start
) <= XINT (end
) && XINT (end
) <= Z
))
3212 args_out_of_range (start
, end
);
3214 if (BEGV
!= XFASTINT (start
) || ZV
!= XFASTINT (end
))
3215 current_buffer
->clip_changed
= 1;
3217 SET_BUF_BEGV (current_buffer
, XFASTINT (start
));
3218 SET_BUF_ZV (current_buffer
, XFASTINT (end
));
3219 if (PT
< XFASTINT (start
))
3220 SET_PT (XFASTINT (start
));
3221 if (PT
> XFASTINT (end
))
3222 SET_PT (XFASTINT (end
));
3223 /* Changing the buffer bounds invalidates any recorded current column. */
3224 invalidate_current_column ();
3229 save_restriction_save (void)
3231 if (BEGV
== BEG
&& ZV
== Z
)
3232 /* The common case that the buffer isn't narrowed.
3233 We return just the buffer object, which save_restriction_restore
3234 recognizes as meaning `no restriction'. */
3235 return Fcurrent_buffer ();
3237 /* We have to save a restriction, so return a pair of markers, one
3238 for the beginning and one for the end. */
3240 Lisp_Object beg
, end
;
3242 beg
= buildmark (BEGV
, BEGV_BYTE
);
3243 end
= buildmark (ZV
, ZV_BYTE
);
3245 /* END must move forward if text is inserted at its exact location. */
3246 XMARKER (end
)->insertion_type
= 1;
3248 return Fcons (beg
, end
);
3253 save_restriction_restore (Lisp_Object data
)
3255 struct buffer
*cur
= NULL
;
3256 struct buffer
*buf
= (CONSP (data
)
3257 ? XMARKER (XCAR (data
))->buffer
3260 if (buf
&& buf
!= current_buffer
&& !NILP (BVAR (buf
, pt_marker
)))
3261 { /* If `buf' uses markers to keep track of PT, BEGV, and ZV (as
3262 is the case if it is or has an indirect buffer), then make
3263 sure it is current before we update BEGV, so
3264 set_buffer_internal takes care of managing those markers. */
3265 cur
= current_buffer
;
3266 set_buffer_internal (buf
);
3270 /* A pair of marks bounding a saved restriction. */
3272 struct Lisp_Marker
*beg
= XMARKER (XCAR (data
));
3273 struct Lisp_Marker
*end
= XMARKER (XCDR (data
));
3274 eassert (buf
== end
->buffer
);
3276 if (buf
/* Verify marker still points to a buffer. */
3277 && (beg
->charpos
!= BUF_BEGV (buf
) || end
->charpos
!= BUF_ZV (buf
)))
3278 /* The restriction has changed from the saved one, so restore
3279 the saved restriction. */
3281 ptrdiff_t pt
= BUF_PT (buf
);
3283 SET_BUF_BEGV_BOTH (buf
, beg
->charpos
, beg
->bytepos
);
3284 SET_BUF_ZV_BOTH (buf
, end
->charpos
, end
->bytepos
);
3286 if (pt
< beg
->charpos
|| pt
> end
->charpos
)
3287 /* The point is outside the new visible range, move it inside. */
3288 SET_BUF_PT_BOTH (buf
,
3289 clip_to_bounds (beg
->charpos
, pt
, end
->charpos
),
3290 clip_to_bounds (beg
->bytepos
, BUF_PT_BYTE (buf
),
3293 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3297 /* A buffer, which means that there was no old restriction. */
3299 if (buf
/* Verify marker still points to a buffer. */
3300 && (BUF_BEGV (buf
) != BUF_BEG (buf
) || BUF_ZV (buf
) != BUF_Z (buf
)))
3301 /* The buffer has been narrowed, get rid of the narrowing. */
3303 SET_BUF_BEGV_BOTH (buf
, BUF_BEG (buf
), BUF_BEG_BYTE (buf
));
3304 SET_BUF_ZV_BOTH (buf
, BUF_Z (buf
), BUF_Z_BYTE (buf
));
3306 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3310 /* Changing the buffer bounds invalidates any recorded current column. */
3311 invalidate_current_column ();
3314 set_buffer_internal (cur
);
3319 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
3320 doc
: /* Execute BODY, saving and restoring current buffer's restrictions.
3321 The buffer's restrictions make parts of the beginning and end invisible.
3322 \(They are set up with `narrow-to-region' and eliminated with `widen'.)
3323 This special form, `save-restriction', saves the current buffer's restrictions
3324 when it is entered, and restores them when it is exited.
3325 So any `narrow-to-region' within BODY lasts only until the end of the form.
3326 The old restrictions settings are restored
3327 even in case of abnormal exit (throw or error).
3329 The value returned is the value of the last form in BODY.
3331 Note: if you are using both `save-excursion' and `save-restriction',
3332 use `save-excursion' outermost:
3333 (save-excursion (save-restriction ...))
3335 usage: (save-restriction &rest BODY) */)
3338 register Lisp_Object val
;
3339 ptrdiff_t count
= SPECPDL_INDEX ();
3341 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
3342 val
= Fprogn (body
);
3343 return unbind_to (count
, val
);
3346 /* Buffer for the most recent text displayed by Fmessage_box. */
3347 static char *message_text
;
3349 /* Allocated length of that buffer. */
3350 static ptrdiff_t message_length
;
3352 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
3353 doc
: /* Display a message at the bottom of the screen.
3354 The message also goes into the `*Messages*' buffer.
3355 \(In keyboard macros, that's all it does.)
3358 The first argument is a format control string, and the rest are data
3359 to be formatted under control of the string. See `format' for details.
3361 Note: Use (message "%s" VALUE) to print the value of expressions and
3362 variables to avoid accidentally interpreting `%' as format specifiers.
3364 If the first argument is nil or the empty string, the function clears
3365 any existing message; this lets the minibuffer contents show. See
3366 also `current-message'.
3368 usage: (message FORMAT-STRING &rest ARGS) */)
3369 (ptrdiff_t nargs
, Lisp_Object
*args
)
3372 || (STRINGP (args
[0])
3373 && SBYTES (args
[0]) == 0))
3380 register Lisp_Object val
;
3381 val
= Fformat (nargs
, args
);
3382 message3 (val
, SBYTES (val
), STRING_MULTIBYTE (val
));
3387 DEFUN ("message-box", Fmessage_box
, Smessage_box
, 1, MANY
, 0,
3388 doc
: /* Display a message, in a dialog box if possible.
3389 If a dialog box is not available, use the echo area.
3390 The first argument is a format control string, and the rest are data
3391 to be formatted under control of the string. See `format' for details.
3393 If the first argument is nil or the empty string, clear any existing
3394 message; let the minibuffer contents show.
3396 usage: (message-box FORMAT-STRING &rest ARGS) */)
3397 (ptrdiff_t nargs
, Lisp_Object
*args
)
3406 register Lisp_Object val
;
3407 val
= Fformat (nargs
, args
);
3409 /* The MS-DOS frames support popup menus even though they are
3410 not FRAME_WINDOW_P. */
3411 if (FRAME_WINDOW_P (XFRAME (selected_frame
))
3412 || FRAME_MSDOS_P (XFRAME (selected_frame
)))
3414 Lisp_Object pane
, menu
;
3415 struct gcpro gcpro1
;
3416 pane
= Fcons (Fcons (build_string ("OK"), Qt
), Qnil
);
3418 menu
= Fcons (val
, pane
);
3419 Fx_popup_dialog (Qt
, menu
, Qt
);
3423 #endif /* HAVE_MENUS */
3424 /* Copy the data so that it won't move when we GC. */
3427 message_text
= (char *)xmalloc (80);
3428 message_length
= 80;
3430 if (SBYTES (val
) > message_length
)
3432 message_text
= (char *) xrealloc (message_text
, SBYTES (val
));
3433 message_length
= SBYTES (val
);
3435 memcpy (message_text
, SDATA (val
), SBYTES (val
));
3436 message2 (message_text
, SBYTES (val
),
3437 STRING_MULTIBYTE (val
));
3442 DEFUN ("message-or-box", Fmessage_or_box
, Smessage_or_box
, 1, MANY
, 0,
3443 doc
: /* Display a message in a dialog box or in the echo area.
3444 If this command was invoked with the mouse, use a dialog box if
3445 `use-dialog-box' is non-nil.
3446 Otherwise, use the echo area.
3447 The first argument is a format control string, and the rest are data
3448 to be formatted under control of the string. See `format' for details.
3450 If the first argument is nil or the empty string, clear any existing
3451 message; let the minibuffer contents show.
3453 usage: (message-or-box FORMAT-STRING &rest ARGS) */)
3454 (ptrdiff_t nargs
, Lisp_Object
*args
)
3457 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3459 return Fmessage_box (nargs
, args
);
3461 return Fmessage (nargs
, args
);
3464 DEFUN ("current-message", Fcurrent_message
, Scurrent_message
, 0, 0, 0,
3465 doc
: /* Return the string currently displayed in the echo area, or nil if none. */)
3468 return current_message ();
3472 DEFUN ("propertize", Fpropertize
, Spropertize
, 1, MANY
, 0,
3473 doc
: /* Return a copy of STRING with text properties added.
3474 First argument is the string to copy.
3475 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
3476 properties to add to the result.
3477 usage: (propertize STRING &rest PROPERTIES) */)
3478 (ptrdiff_t nargs
, Lisp_Object
*args
)
3480 Lisp_Object properties
, string
;
3481 struct gcpro gcpro1
, gcpro2
;
3484 /* Number of args must be odd. */
3485 if ((nargs
& 1) == 0)
3486 error ("Wrong number of arguments");
3488 properties
= string
= Qnil
;
3489 GCPRO2 (properties
, string
);
3491 /* First argument must be a string. */
3492 CHECK_STRING (args
[0]);
3493 string
= Fcopy_sequence (args
[0]);
3495 for (i
= 1; i
< nargs
; i
+= 2)
3496 properties
= Fcons (args
[i
], Fcons (args
[i
+ 1], properties
));
3498 Fadd_text_properties (make_number (0),
3499 make_number (SCHARS (string
)),
3500 properties
, string
);
3501 RETURN_UNGCPRO (string
);
3504 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
3505 doc
: /* Format a string out of a format-string and arguments.
3506 The first argument is a format control string.
3507 The other arguments are substituted into it to make the result, a string.
3509 The format control string may contain %-sequences meaning to substitute
3510 the next available argument:
3512 %s means print a string argument. Actually, prints any object, with `princ'.
3513 %d means print as number in decimal (%o octal, %x hex).
3514 %X is like %x, but uses upper case.
3515 %e means print a number in exponential notation.
3516 %f means print a number in decimal-point notation.
3517 %g means print a number in exponential notation
3518 or decimal-point notation, whichever uses fewer characters.
3519 %c means print a number as a single character.
3520 %S means print any object as an s-expression (using `prin1').
3522 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.
3523 Use %% to put a single % into the output.
3525 A %-sequence may contain optional flag, width, and precision
3526 specifiers, as follows:
3528 %<flags><width><precision>character
3530 where flags is [+ #-0]+, width is [0-9]+, and precision is .[0-9]+
3532 The + flag character inserts a + before any positive number, while a
3533 space inserts a space before any positive number; these flags only
3534 affect %d, %e, %f, and %g sequences, and the + flag takes precedence.
3535 The # flag means to use an alternate display form for %o, %x, %X, %e,
3536 %f, and %g sequences. The - and 0 flags affect the width specifier,
3539 The width specifier supplies a lower limit for the length of the
3540 printed representation. The padding, if any, normally goes on the
3541 left, but it goes on the right if the - flag is present. The padding
3542 character is normally a space, but it is 0 if the 0 flag is present.
3543 The 0 flag is ignored if the - flag is present, or the format sequence
3544 is something other than %d, %e, %f, and %g.
3546 For %e, %f, and %g sequences, the number after the "." in the
3547 precision specifier says how many decimal places to show; if zero, the
3548 decimal point itself is omitted. For %s and %S, the precision
3549 specifier truncates the string to the given width.
3551 usage: (format STRING &rest OBJECTS) */)
3552 (ptrdiff_t nargs
, Lisp_Object
*args
)
3554 ptrdiff_t n
; /* The number of the next arg to substitute */
3555 char initial_buffer
[4000];
3556 char *buf
= initial_buffer
;
3557 ptrdiff_t bufsize
= sizeof initial_buffer
;
3558 ptrdiff_t max_bufsize
= STRING_BYTES_BOUND
+ 1;
3560 Lisp_Object buf_save_value
IF_LINT (= {0});
3561 register char *format
, *end
, *format_start
;
3562 ptrdiff_t formatlen
, nchars
;
3563 /* Nonzero if the format is multibyte. */
3564 int multibyte_format
= 0;
3565 /* Nonzero if the output should be a multibyte string,
3566 which is true if any of the inputs is one. */
3568 /* When we make a multibyte string, we must pay attention to the
3569 byte combining problem, i.e., a byte may be combined with a
3570 multibyte character of the previous string. This flag tells if we
3571 must consider such a situation or not. */
3572 int maybe_combine_byte
;
3574 int arg_intervals
= 0;
3577 /* discarded[I] is 1 if byte I of the format
3578 string was not copied into the output.
3579 It is 2 if byte I was not the first byte of its character. */
3582 /* Each element records, for one argument,
3583 the start and end bytepos in the output string,
3584 whether the argument has been converted to string (e.g., due to "%S"),
3585 and whether the argument is a string with intervals.
3586 info[0] is unused. Unused elements have -1 for start. */
3589 ptrdiff_t start
, end
;
3590 int converted_to_string
;
3594 /* It should not be necessary to GCPRO ARGS, because
3595 the caller in the interpreter should take care of that. */
3597 CHECK_STRING (args
[0]);
3598 format_start
= SSDATA (args
[0]);
3599 formatlen
= SBYTES (args
[0]);
3601 /* Allocate the info and discarded tables. */
3604 if ((SIZE_MAX
- formatlen
) / sizeof (struct info
) <= nargs
)
3605 memory_full (SIZE_MAX
);
3606 SAFE_ALLOCA (info
, struct info
*, (nargs
+ 1) * sizeof *info
+ formatlen
);
3607 discarded
= (char *) &info
[nargs
+ 1];
3608 for (i
= 0; i
< nargs
+ 1; i
++)
3611 info
[i
].intervals
= info
[i
].converted_to_string
= 0;
3613 memset (discarded
, 0, formatlen
);
3616 /* Try to determine whether the result should be multibyte.
3617 This is not always right; sometimes the result needs to be multibyte
3618 because of an object that we will pass through prin1,
3619 and in that case, we won't know it here. */
3620 multibyte_format
= STRING_MULTIBYTE (args
[0]);
3621 multibyte
= multibyte_format
;
3622 for (n
= 1; !multibyte
&& n
< nargs
; n
++)
3623 if (STRINGP (args
[n
]) && STRING_MULTIBYTE (args
[n
]))
3626 /* If we start out planning a unibyte result,
3627 then discover it has to be multibyte, we jump back to retry. */
3634 /* Scan the format and store result in BUF. */
3635 format
= format_start
;
3636 end
= format
+ formatlen
;
3637 maybe_combine_byte
= 0;
3639 while (format
!= end
)
3641 /* The values of N and FORMAT when the loop body is entered. */
3643 char *format0
= format
;
3645 /* Bytes needed to represent the output of this conversion. */
3646 ptrdiff_t convbytes
;
3650 /* General format specifications look like
3652 '%' [flags] [field-width] [precision] format
3657 field-width ::= [0-9]+
3658 precision ::= '.' [0-9]*
3660 If a field-width is specified, it specifies to which width
3661 the output should be padded with blanks, if the output
3662 string is shorter than field-width.
3664 If precision is specified, it specifies the number of
3665 digits to print after the '.' for floats, or the max.
3666 number of chars to print from a string. */
3673 ptrdiff_t field_width
;
3674 int precision_given
;
3675 uintmax_t precision
= UINTMAX_MAX
;
3683 case '-': minus_flag
= 1; continue;
3684 case '+': plus_flag
= 1; continue;
3685 case ' ': space_flag
= 1; continue;
3686 case '#': sharp_flag
= 1; continue;
3687 case '0': zero_flag
= 1; continue;
3692 /* Ignore flags when sprintf ignores them. */
3693 space_flag
&= ~ plus_flag
;
3694 zero_flag
&= ~ minus_flag
;
3697 uintmax_t w
= strtoumax (format
, &num_end
, 10);
3698 if (max_bufsize
<= w
)
3702 precision_given
= *num_end
== '.';
3703 if (precision_given
)
3704 precision
= strtoumax (num_end
+ 1, &num_end
, 10);
3708 error ("Format string ends in middle of format specifier");
3710 memset (&discarded
[format0
- format_start
], 1, format
- format0
);
3711 conversion
= *format
;
3712 if (conversion
== '%')
3714 discarded
[format
- format_start
] = 1;
3719 error ("Not enough arguments for format string");
3721 /* For 'S', prin1 the argument, and then treat like 's'.
3722 For 's', princ any argument that is not a string or
3723 symbol. But don't do this conversion twice, which might
3724 happen after retrying. */
3725 if ((conversion
== 'S'
3726 || (conversion
== 's'
3727 && ! STRINGP (args
[n
]) && ! SYMBOLP (args
[n
]))))
3729 if (! info
[n
].converted_to_string
)
3731 Lisp_Object noescape
= conversion
== 'S' ? Qnil
: Qt
;
3732 args
[n
] = Fprin1_to_string (args
[n
], noescape
);
3733 info
[n
].converted_to_string
= 1;
3734 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
3742 else if (conversion
== 'c')
3744 if (FLOATP (args
[n
]))
3746 double d
= XFLOAT_DATA (args
[n
]);
3747 args
[n
] = make_number (FIXNUM_OVERFLOW_P (d
) ? -1 : d
);
3750 if (INTEGERP (args
[n
]) && ! ASCII_CHAR_P (XINT (args
[n
])))
3757 args
[n
] = Fchar_to_string (args
[n
]);
3758 info
[n
].converted_to_string
= 1;
3761 if (info
[n
].converted_to_string
)
3766 if (SYMBOLP (args
[n
]))
3768 args
[n
] = SYMBOL_NAME (args
[n
]);
3769 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
3776 if (conversion
== 's')
3778 /* handle case (precision[n] >= 0) */
3780 ptrdiff_t width
, padding
, nbytes
;
3781 ptrdiff_t nchars_string
;
3783 ptrdiff_t prec
= -1;
3784 if (precision_given
&& precision
<= TYPE_MAXIMUM (ptrdiff_t))
3787 /* lisp_string_width ignores a precision of 0, but GNU
3788 libc functions print 0 characters when the precision
3789 is 0. Imitate libc behavior here. Changing
3790 lisp_string_width is the right thing, and will be
3791 done, but meanwhile we work with it. */
3794 width
= nchars_string
= nbytes
= 0;
3798 width
= lisp_string_width (args
[n
], prec
, &nch
, &nby
);
3801 nchars_string
= SCHARS (args
[n
]);
3802 nbytes
= SBYTES (args
[n
]);
3806 nchars_string
= nch
;
3812 if (convbytes
&& multibyte
&& ! STRING_MULTIBYTE (args
[n
]))
3813 convbytes
= count_size_as_multibyte (SDATA (args
[n
]), nbytes
);
3815 padding
= width
< field_width
? field_width
- width
: 0;
3817 if (max_bufsize
- padding
<= convbytes
)
3819 convbytes
+= padding
;
3820 if (convbytes
<= buf
+ bufsize
- p
)
3824 memset (p
, ' ', padding
);
3831 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3832 && STRING_MULTIBYTE (args
[n
])
3833 && !CHAR_HEAD_P (SREF (args
[n
], 0)))
3834 maybe_combine_byte
= 1;
3836 p
+= copy_text (SDATA (args
[n
]), (unsigned char *) p
,
3838 STRING_MULTIBYTE (args
[n
]), multibyte
);
3840 info
[n
].start
= nchars
;
3841 nchars
+= nchars_string
;
3842 info
[n
].end
= nchars
;
3846 memset (p
, ' ', padding
);
3851 /* If this argument has text properties, record where
3852 in the result string it appears. */
3853 if (STRING_INTERVALS (args
[n
]))
3854 info
[n
].intervals
= arg_intervals
= 1;
3859 else if (! (conversion
== 'c' || conversion
== 'd'
3860 || conversion
== 'e' || conversion
== 'f'
3861 || conversion
== 'g' || conversion
== 'i'
3862 || conversion
== 'o' || conversion
== 'x'
3863 || conversion
== 'X'))
3864 error ("Invalid format operation %%%c",
3865 STRING_CHAR ((unsigned char *) format
- 1));
3866 else if (! (INTEGERP (args
[n
]) || FLOATP (args
[n
])))
3867 error ("Format specifier doesn't match argument type");
3872 /* Maximum precision for a %f conversion such that the
3873 trailing output digit might be nonzero. Any precisions
3874 larger than this will not yield useful information. */
3875 USEFUL_PRECISION_MAX
=
3877 * (FLT_RADIX
== 2 || FLT_RADIX
== 10 ? 1
3878 : FLT_RADIX
== 16 ? 4
3881 /* Maximum number of bytes generated by any format, if
3882 precision is no more than USEFUL_PRECISION_MAX.
3883 On all practical hosts, %f is the worst case. */
3885 sizeof "-." + (DBL_MAX_10_EXP
+ 1) + USEFUL_PRECISION_MAX
,
3887 /* Length of pM (that is, of pMd without the
3889 pMlen
= sizeof pMd
- 2
3891 verify (0 < USEFUL_PRECISION_MAX
);
3894 ptrdiff_t padding
, sprintf_bytes
;
3895 uintmax_t excess_precision
, numwidth
;
3896 uintmax_t leading_zeros
= 0, trailing_zeros
= 0;
3898 char sprintf_buf
[SPRINTF_BUFSIZE
];
3900 /* Copy of conversion specification, modified somewhat.
3901 At most three flags F can be specified at once. */
3902 char convspec
[sizeof "%FFF.*d" + pMlen
];
3904 /* Avoid undefined behavior in underlying sprintf. */
3905 if (conversion
== 'd' || conversion
== 'i')
3908 /* Create the copy of the conversion specification, with
3909 any width and precision removed, with ".*" inserted,
3910 and with pM inserted for integer formats. */
3914 *f
= '-'; f
+= minus_flag
;
3915 *f
= '+'; f
+= plus_flag
;
3916 *f
= ' '; f
+= space_flag
;
3917 *f
= '#'; f
+= sharp_flag
;
3918 *f
= '0'; f
+= zero_flag
;
3921 if (conversion
== 'd' || conversion
== 'i'
3922 || conversion
== 'o' || conversion
== 'x'
3923 || conversion
== 'X')
3925 memcpy (f
, pMd
, pMlen
);
3927 zero_flag
&= ~ precision_given
;
3934 if (precision_given
)
3935 prec
= min (precision
, USEFUL_PRECISION_MAX
);
3937 /* Use sprintf to format this number into sprintf_buf. Omit
3938 padding and excess precision, though, because sprintf limits
3939 output length to INT_MAX.
3941 There are four types of conversion: double, unsigned
3942 char (passed as int), wide signed int, and wide
3943 unsigned int. Treat them separately because the
3944 sprintf ABI is sensitive to which type is passed. Be
3945 careful about integer overflow, NaNs, infinities, and
3946 conversions; for example, the min and max macros are
3947 not suitable here. */
3948 if (conversion
== 'e' || conversion
== 'f' || conversion
== 'g')
3950 double x
= (INTEGERP (args
[n
])
3952 : XFLOAT_DATA (args
[n
]));
3953 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
3955 else if (conversion
== 'c')
3957 /* Don't use sprintf here, as it might mishandle prec. */
3958 sprintf_buf
[0] = XINT (args
[n
]);
3959 sprintf_bytes
= prec
!= 0;
3961 else if (conversion
== 'd')
3963 /* For float, maybe we should use "%1.0f"
3964 instead so it also works for values outside
3965 the integer range. */
3967 if (INTEGERP (args
[n
]))
3971 double d
= XFLOAT_DATA (args
[n
]);
3974 x
= TYPE_MINIMUM (printmax_t
);
3980 x
= TYPE_MAXIMUM (printmax_t
);
3985 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
3989 /* Don't sign-extend for octal or hex printing. */
3991 if (INTEGERP (args
[n
]))
3992 x
= XUINT (args
[n
]);
3995 double d
= XFLOAT_DATA (args
[n
]);
4000 x
= TYPE_MAXIMUM (uprintmax_t
);
4005 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4008 /* Now the length of the formatted item is known, except it omits
4009 padding and excess precision. Deal with excess precision
4010 first. This happens only when the format specifies
4011 ridiculously large precision. */
4012 excess_precision
= precision
- prec
;
4013 if (excess_precision
)
4015 if (conversion
== 'e' || conversion
== 'f'
4016 || conversion
== 'g')
4018 if ((conversion
== 'g' && ! sharp_flag
)
4019 || ! ('0' <= sprintf_buf
[sprintf_bytes
- 1]
4020 && sprintf_buf
[sprintf_bytes
- 1] <= '9'))
4021 excess_precision
= 0;
4024 if (conversion
== 'g')
4026 char *dot
= strchr (sprintf_buf
, '.');
4028 excess_precision
= 0;
4031 trailing_zeros
= excess_precision
;
4034 leading_zeros
= excess_precision
;
4037 /* Compute the total bytes needed for this item, including
4038 excess precision and padding. */
4039 numwidth
= sprintf_bytes
+ excess_precision
;
4040 padding
= numwidth
< field_width
? field_width
- numwidth
: 0;
4041 if (max_bufsize
- sprintf_bytes
<= excess_precision
4042 || max_bufsize
- padding
<= numwidth
)
4044 convbytes
= numwidth
+ padding
;
4046 if (convbytes
<= buf
+ bufsize
- p
)
4048 /* Copy the formatted item from sprintf_buf into buf,
4049 inserting padding and excess-precision zeros. */
4051 char *src
= sprintf_buf
;
4053 int exponent_bytes
= 0;
4054 int signedp
= src0
== '-' || src0
== '+' || src0
== ' ';
4055 int significand_bytes
;
4057 && ((src
[signedp
] >= '0' && src
[signedp
] <= '9')
4058 || (src
[signedp
] >= 'a' && src
[signedp
] <= 'f')
4059 || (src
[signedp
] >= 'A' && src
[signedp
] <= 'F')))
4061 leading_zeros
+= padding
;
4065 if (excess_precision
4066 && (conversion
== 'e' || conversion
== 'g'))
4068 char *e
= strchr (src
, 'e');
4070 exponent_bytes
= src
+ sprintf_bytes
- e
;
4075 memset (p
, ' ', padding
);
4083 memset (p
, '0', leading_zeros
);
4085 significand_bytes
= sprintf_bytes
- signedp
- exponent_bytes
;
4086 memcpy (p
, src
, significand_bytes
);
4087 p
+= significand_bytes
;
4088 src
+= significand_bytes
;
4089 memset (p
, '0', trailing_zeros
);
4090 p
+= trailing_zeros
;
4091 memcpy (p
, src
, exponent_bytes
);
4092 p
+= exponent_bytes
;
4094 info
[n
].start
= nchars
;
4095 nchars
+= leading_zeros
+ sprintf_bytes
+ trailing_zeros
;
4096 info
[n
].end
= nchars
;
4100 memset (p
, ' ', padding
);
4112 /* Copy a single character from format to buf. */
4115 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
4117 if (multibyte_format
)
4119 /* Copy a whole multibyte character. */
4121 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
4122 && !CHAR_HEAD_P (*format
))
4123 maybe_combine_byte
= 1;
4127 while (! CHAR_HEAD_P (*format
));
4129 convbytes
= format
- src
;
4130 memset (&discarded
[src
+ 1 - format_start
], 2, convbytes
- 1);
4134 unsigned char uc
= *format
++;
4135 if (! multibyte
|| ASCII_BYTE_P (uc
))
4139 int c
= BYTE8_TO_CHAR (uc
);
4140 convbytes
= CHAR_STRING (c
, str
);
4145 if (convbytes
<= buf
+ bufsize
- p
)
4147 memcpy (p
, src
, convbytes
);
4154 /* There wasn't enough room to store this conversion or single
4155 character. CONVBYTES says how much room is needed. Allocate
4156 enough room (and then some) and do it again. */
4158 ptrdiff_t used
= p
- buf
;
4160 if (max_bufsize
- used
< convbytes
)
4162 bufsize
= used
+ convbytes
;
4163 bufsize
= bufsize
< max_bufsize
/ 2 ? bufsize
* 2 : max_bufsize
;
4165 if (buf
== initial_buffer
)
4167 buf
= xmalloc (bufsize
);
4169 buf_save_value
= make_save_value (buf
, 0);
4170 record_unwind_protect (safe_alloca_unwind
, buf_save_value
);
4171 memcpy (buf
, initial_buffer
, used
);
4174 XSAVE_VALUE (buf_save_value
)->pointer
= buf
= xrealloc (buf
, bufsize
);
4183 if (bufsize
< p
- buf
)
4186 if (maybe_combine_byte
)
4187 nchars
= multibyte_chars_in_text ((unsigned char *) buf
, p
- buf
);
4188 val
= make_specified_string (buf
, nchars
, p
- buf
, multibyte
);
4190 /* If we allocated BUF with malloc, free it too. */
4193 /* If the format string has text properties, or any of the string
4194 arguments has text properties, set up text properties of the
4197 if (STRING_INTERVALS (args
[0]) || arg_intervals
)
4199 Lisp_Object len
, new_len
, props
;
4200 struct gcpro gcpro1
;
4202 /* Add text properties from the format string. */
4203 len
= make_number (SCHARS (args
[0]));
4204 props
= text_property_list (args
[0], make_number (0), len
, Qnil
);
4209 ptrdiff_t bytepos
= 0, position
= 0, translated
= 0;
4213 /* Adjust the bounds of each text property
4214 to the proper start and end in the output string. */
4216 /* Put the positions in PROPS in increasing order, so that
4217 we can do (effectively) one scan through the position
4218 space of the format string. */
4219 props
= Fnreverse (props
);
4221 /* BYTEPOS is the byte position in the format string,
4222 POSITION is the untranslated char position in it,
4223 TRANSLATED is the translated char position in BUF,
4224 and ARGN is the number of the next arg we will come to. */
4225 for (list
= props
; CONSP (list
); list
= XCDR (list
))
4232 /* First adjust the property start position. */
4233 pos
= XINT (XCAR (item
));
4235 /* Advance BYTEPOS, POSITION, TRANSLATED and ARGN
4236 up to this position. */
4237 for (; position
< pos
; bytepos
++)
4239 if (! discarded
[bytepos
])
4240 position
++, translated
++;
4241 else if (discarded
[bytepos
] == 1)
4244 if (translated
== info
[argn
].start
)
4246 translated
+= info
[argn
].end
- info
[argn
].start
;
4252 XSETCAR (item
, make_number (translated
));
4254 /* Likewise adjust the property end position. */
4255 pos
= XINT (XCAR (XCDR (item
)));
4257 for (; position
< pos
; bytepos
++)
4259 if (! discarded
[bytepos
])
4260 position
++, translated
++;
4261 else if (discarded
[bytepos
] == 1)
4264 if (translated
== info
[argn
].start
)
4266 translated
+= info
[argn
].end
- info
[argn
].start
;
4272 XSETCAR (XCDR (item
), make_number (translated
));
4275 add_text_properties_from_list (val
, props
, make_number (0));
4278 /* Add text properties from arguments. */
4280 for (n
= 1; n
< nargs
; ++n
)
4281 if (info
[n
].intervals
)
4283 len
= make_number (SCHARS (args
[n
]));
4284 new_len
= make_number (info
[n
].end
- info
[n
].start
);
4285 props
= text_property_list (args
[n
], make_number (0), len
, Qnil
);
4286 props
= extend_property_ranges (props
, new_len
);
4287 /* If successive arguments have properties, be sure that
4288 the value of `composition' property be the copy. */
4289 if (n
> 1 && info
[n
- 1].end
)
4290 make_composition_value_copy (props
);
4291 add_text_properties_from_list (val
, props
,
4292 make_number (info
[n
].start
));
4302 format2 (const char *string1
, Lisp_Object arg0
, Lisp_Object arg1
)
4304 Lisp_Object args
[3];
4305 args
[0] = build_string (string1
);
4308 return Fformat (3, args
);
4311 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
4312 doc
: /* Return t if two characters match, optionally ignoring case.
4313 Both arguments must be characters (i.e. integers).
4314 Case is ignored if `case-fold-search' is non-nil in the current buffer. */)
4315 (register Lisp_Object c1
, Lisp_Object c2
)
4318 /* Check they're chars, not just integers, otherwise we could get array
4319 bounds violations in downcase. */
4320 CHECK_CHARACTER (c1
);
4321 CHECK_CHARACTER (c2
);
4323 if (XINT (c1
) == XINT (c2
))
4325 if (NILP (BVAR (current_buffer
, case_fold_search
)))
4329 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
))
4330 && ! ASCII_CHAR_P (i1
))
4332 MAKE_CHAR_MULTIBYTE (i1
);
4335 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
))
4336 && ! ASCII_CHAR_P (i2
))
4338 MAKE_CHAR_MULTIBYTE (i2
);
4340 return (downcase (i1
) == downcase (i2
) ? Qt
: Qnil
);
4343 /* Transpose the markers in two regions of the current buffer, and
4344 adjust the ones between them if necessary (i.e.: if the regions
4347 START1, END1 are the character positions of the first region.
4348 START1_BYTE, END1_BYTE are the byte positions.
4349 START2, END2 are the character positions of the second region.
4350 START2_BYTE, END2_BYTE are the byte positions.
4352 Traverses the entire marker list of the buffer to do so, adding an
4353 appropriate amount to some, subtracting from some, and leaving the
4354 rest untouched. Most of this is copied from adjust_markers in insdel.c.
4356 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
4359 transpose_markers (ptrdiff_t start1
, ptrdiff_t end1
,
4360 ptrdiff_t start2
, ptrdiff_t end2
,
4361 ptrdiff_t start1_byte
, ptrdiff_t end1_byte
,
4362 ptrdiff_t start2_byte
, ptrdiff_t end2_byte
)
4364 register ptrdiff_t amt1
, amt1_byte
, amt2
, amt2_byte
, diff
, diff_byte
, mpos
;
4365 register struct Lisp_Marker
*marker
;
4367 /* Update point as if it were a marker. */
4371 TEMP_SET_PT_BOTH (PT
+ (end2
- end1
),
4372 PT_BYTE
+ (end2_byte
- end1_byte
));
4373 else if (PT
< start2
)
4374 TEMP_SET_PT_BOTH (PT
+ (end2
- start2
) - (end1
- start1
),
4375 (PT_BYTE
+ (end2_byte
- start2_byte
)
4376 - (end1_byte
- start1_byte
)));
4378 TEMP_SET_PT_BOTH (PT
- (start2
- start1
),
4379 PT_BYTE
- (start2_byte
- start1_byte
));
4381 /* We used to adjust the endpoints here to account for the gap, but that
4382 isn't good enough. Even if we assume the caller has tried to move the
4383 gap out of our way, it might still be at start1 exactly, for example;
4384 and that places it `inside' the interval, for our purposes. The amount
4385 of adjustment is nontrivial if there's a `denormalized' marker whose
4386 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
4387 the dirty work to Fmarker_position, below. */
4389 /* The difference between the region's lengths */
4390 diff
= (end2
- start2
) - (end1
- start1
);
4391 diff_byte
= (end2_byte
- start2_byte
) - (end1_byte
- start1_byte
);
4393 /* For shifting each marker in a region by the length of the other
4394 region plus the distance between the regions. */
4395 amt1
= (end2
- start2
) + (start2
- end1
);
4396 amt2
= (end1
- start1
) + (start2
- end1
);
4397 amt1_byte
= (end2_byte
- start2_byte
) + (start2_byte
- end1_byte
);
4398 amt2_byte
= (end1_byte
- start1_byte
) + (start2_byte
- end1_byte
);
4400 for (marker
= BUF_MARKERS (current_buffer
); marker
; marker
= marker
->next
)
4402 mpos
= marker
->bytepos
;
4403 if (mpos
>= start1_byte
&& mpos
< end2_byte
)
4405 if (mpos
< end1_byte
)
4407 else if (mpos
< start2_byte
)
4411 marker
->bytepos
= mpos
;
4413 mpos
= marker
->charpos
;
4414 if (mpos
>= start1
&& mpos
< end2
)
4418 else if (mpos
< start2
)
4423 marker
->charpos
= mpos
;
4427 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
4428 doc
: /* Transpose region STARTR1 to ENDR1 with STARTR2 to ENDR2.
4429 The regions should not be overlapping, because the size of the buffer is
4430 never changed in a transposition.
4432 Optional fifth arg LEAVE-MARKERS, if non-nil, means don't update
4433 any markers that happen to be located in the regions.
4435 Transposing beyond buffer boundaries is an error. */)
4436 (Lisp_Object startr1
, Lisp_Object endr1
, Lisp_Object startr2
, Lisp_Object endr2
, Lisp_Object leave_markers
)
4438 register ptrdiff_t start1
, end1
, start2
, end2
;
4439 ptrdiff_t start1_byte
, start2_byte
, len1_byte
, len2_byte
;
4440 ptrdiff_t gap
, len1
, len_mid
, len2
;
4441 unsigned char *start1_addr
, *start2_addr
, *temp
;
4443 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
, tmp_interval3
;
4446 XSETBUFFER (buf
, current_buffer
);
4447 cur_intv
= BUF_INTERVALS (current_buffer
);
4449 validate_region (&startr1
, &endr1
);
4450 validate_region (&startr2
, &endr2
);
4452 start1
= XFASTINT (startr1
);
4453 end1
= XFASTINT (endr1
);
4454 start2
= XFASTINT (startr2
);
4455 end2
= XFASTINT (endr2
);
4458 /* Swap the regions if they're reversed. */
4461 register ptrdiff_t glumph
= start1
;
4469 len1
= end1
- start1
;
4470 len2
= end2
- start2
;
4473 error ("Transposed regions overlap");
4474 /* Nothing to change for adjacent regions with one being empty */
4475 else if ((start1
== end1
|| start2
== end2
) && end1
== start2
)
4478 /* The possibilities are:
4479 1. Adjacent (contiguous) regions, or separate but equal regions
4480 (no, really equal, in this case!), or
4481 2. Separate regions of unequal size.
4483 The worst case is usually No. 2. It means that (aside from
4484 potential need for getting the gap out of the way), there also
4485 needs to be a shifting of the text between the two regions. So
4486 if they are spread far apart, we are that much slower... sigh. */
4488 /* It must be pointed out that the really studly thing to do would
4489 be not to move the gap at all, but to leave it in place and work
4490 around it if necessary. This would be extremely efficient,
4491 especially considering that people are likely to do
4492 transpositions near where they are working interactively, which
4493 is exactly where the gap would be found. However, such code
4494 would be much harder to write and to read. So, if you are
4495 reading this comment and are feeling squirrely, by all means have
4496 a go! I just didn't feel like doing it, so I will simply move
4497 the gap the minimum distance to get it out of the way, and then
4498 deal with an unbroken array. */
4500 /* Make sure the gap won't interfere, by moving it out of the text
4501 we will operate on. */
4502 if (start1
< gap
&& gap
< end2
)
4504 if (gap
- start1
< end2
- gap
)
4510 start1_byte
= CHAR_TO_BYTE (start1
);
4511 start2_byte
= CHAR_TO_BYTE (start2
);
4512 len1_byte
= CHAR_TO_BYTE (end1
) - start1_byte
;
4513 len2_byte
= CHAR_TO_BYTE (end2
) - start2_byte
;
4515 #ifdef BYTE_COMBINING_DEBUG
4518 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4519 len2_byte
, start1
, start1_byte
)
4520 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4521 len1_byte
, end2
, start2_byte
+ len2_byte
)
4522 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4523 len1_byte
, end2
, start2_byte
+ len2_byte
))
4528 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4529 len2_byte
, start1
, start1_byte
)
4530 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4531 len1_byte
, start2
, start2_byte
)
4532 || count_combining_after (BYTE_POS_ADDR (start2_byte
),
4533 len2_byte
, end1
, start1_byte
+ len1_byte
)
4534 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4535 len1_byte
, end2
, start2_byte
+ len2_byte
))
4540 /* Hmmm... how about checking to see if the gap is large
4541 enough to use as the temporary storage? That would avoid an
4542 allocation... interesting. Later, don't fool with it now. */
4544 /* Working without memmove, for portability (sigh), so must be
4545 careful of overlapping subsections of the array... */
4547 if (end1
== start2
) /* adjacent regions */
4549 modify_region (current_buffer
, start1
, end2
, 0);
4550 record_change (start1
, len1
+ len2
);
4552 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4553 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4554 /* Don't use Fset_text_properties: that can cause GC, which can
4555 clobber objects stored in the tmp_intervals. */
4556 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4557 if (!NULL_INTERVAL_P (tmp_interval3
))
4558 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4560 /* First region smaller than second. */
4561 if (len1_byte
< len2_byte
)
4565 SAFE_ALLOCA (temp
, unsigned char *, len2_byte
);
4567 /* Don't precompute these addresses. We have to compute them
4568 at the last minute, because the relocating allocator might
4569 have moved the buffer around during the xmalloc. */
4570 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4571 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4573 memcpy (temp
, start2_addr
, len2_byte
);
4574 memcpy (start1_addr
+ len2_byte
, start1_addr
, len1_byte
);
4575 memcpy (start1_addr
, temp
, len2_byte
);
4579 /* First region not smaller than second. */
4583 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4584 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4585 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4586 memcpy (temp
, start1_addr
, len1_byte
);
4587 memcpy (start1_addr
, start2_addr
, len2_byte
);
4588 memcpy (start1_addr
+ len2_byte
, temp
, len1_byte
);
4591 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
4592 len1
, current_buffer
, 0);
4593 graft_intervals_into_buffer (tmp_interval2
, start1
,
4594 len2
, current_buffer
, 0);
4595 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4596 update_compositions (start1
+ len2
, end2
, CHECK_TAIL
);
4598 /* Non-adjacent regions, because end1 != start2, bleagh... */
4601 len_mid
= start2_byte
- (start1_byte
+ len1_byte
);
4603 if (len1_byte
== len2_byte
)
4604 /* Regions are same size, though, how nice. */
4608 modify_region (current_buffer
, start1
, end1
, 0);
4609 modify_region (current_buffer
, start2
, end2
, 0);
4610 record_change (start1
, len1
);
4611 record_change (start2
, len2
);
4612 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4613 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4615 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr1
, 0);
4616 if (!NULL_INTERVAL_P (tmp_interval3
))
4617 set_text_properties_1 (startr1
, endr1
, Qnil
, buf
, tmp_interval3
);
4619 tmp_interval3
= validate_interval_range (buf
, &startr2
, &endr2
, 0);
4620 if (!NULL_INTERVAL_P (tmp_interval3
))
4621 set_text_properties_1 (startr2
, endr2
, Qnil
, buf
, tmp_interval3
);
4623 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4624 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4625 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4626 memcpy (temp
, start1_addr
, len1_byte
);
4627 memcpy (start1_addr
, start2_addr
, len2_byte
);
4628 memcpy (start2_addr
, temp
, len1_byte
);
4631 graft_intervals_into_buffer (tmp_interval1
, start2
,
4632 len1
, current_buffer
, 0);
4633 graft_intervals_into_buffer (tmp_interval2
, start1
,
4634 len2
, current_buffer
, 0);
4637 else if (len1_byte
< len2_byte
) /* Second region larger than first */
4638 /* Non-adjacent & unequal size, area between must also be shifted. */
4642 modify_region (current_buffer
, start1
, end2
, 0);
4643 record_change (start1
, (end2
- start1
));
4644 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4645 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4646 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4648 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4649 if (!NULL_INTERVAL_P (tmp_interval3
))
4650 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4652 /* holds region 2 */
4653 SAFE_ALLOCA (temp
, unsigned char *, len2_byte
);
4654 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4655 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4656 memcpy (temp
, start2_addr
, len2_byte
);
4657 memcpy (start1_addr
+ len_mid
+ len2_byte
, start1_addr
, len1_byte
);
4658 memmove (start1_addr
+ len2_byte
, start1_addr
+ len1_byte
, len_mid
);
4659 memcpy (start1_addr
, temp
, len2_byte
);
4662 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4663 len1
, current_buffer
, 0);
4664 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4665 len_mid
, current_buffer
, 0);
4666 graft_intervals_into_buffer (tmp_interval2
, start1
,
4667 len2
, current_buffer
, 0);
4670 /* Second region smaller than first. */
4674 record_change (start1
, (end2
- start1
));
4675 modify_region (current_buffer
, start1
, end2
, 0);
4677 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4678 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4679 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4681 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4682 if (!NULL_INTERVAL_P (tmp_interval3
))
4683 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4685 /* holds region 1 */
4686 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4687 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4688 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4689 memcpy (temp
, start1_addr
, len1_byte
);
4690 memcpy (start1_addr
, start2_addr
, len2_byte
);
4691 memcpy (start1_addr
+ len2_byte
, start1_addr
+ len1_byte
, len_mid
);
4692 memcpy (start1_addr
+ len2_byte
+ len_mid
, temp
, len1_byte
);
4695 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4696 len1
, current_buffer
, 0);
4697 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4698 len_mid
, current_buffer
, 0);
4699 graft_intervals_into_buffer (tmp_interval2
, start1
,
4700 len2
, current_buffer
, 0);
4703 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4704 update_compositions (end2
- len1
, end2
, CHECK_BORDER
);
4707 /* When doing multiple transpositions, it might be nice
4708 to optimize this. Perhaps the markers in any one buffer
4709 should be organized in some sorted data tree. */
4710 if (NILP (leave_markers
))
4712 transpose_markers (start1
, end1
, start2
, end2
,
4713 start1_byte
, start1_byte
+ len1_byte
,
4714 start2_byte
, start2_byte
+ len2_byte
);
4715 fix_start_end_in_overlays (start1
, end2
);
4718 signal_after_change (start1
, end2
- start1
, end2
- start1
);
4724 syms_of_editfns (void)
4729 DEFSYM (Qbuffer_access_fontify_functions
, "buffer-access-fontify-functions");
4731 DEFVAR_LISP ("inhibit-field-text-motion", Vinhibit_field_text_motion
,
4732 doc
: /* Non-nil means text motion commands don't notice fields. */);
4733 Vinhibit_field_text_motion
= Qnil
;
4735 DEFVAR_LISP ("buffer-access-fontify-functions",
4736 Vbuffer_access_fontify_functions
,
4737 doc
: /* List of functions called by `buffer-substring' to fontify if necessary.
4738 Each function is called with two arguments which specify the range
4739 of the buffer being accessed. */);
4740 Vbuffer_access_fontify_functions
= Qnil
;
4744 obuf
= Fcurrent_buffer ();
4745 /* Do this here, because init_buffer_once is too early--it won't work. */
4746 Fset_buffer (Vprin1_to_string_buffer
);
4747 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
4748 Fset (Fmake_local_variable (intern_c_string ("buffer-access-fontify-functions")),
4753 DEFVAR_LISP ("buffer-access-fontified-property",
4754 Vbuffer_access_fontified_property
,
4755 doc
: /* Property which (if non-nil) indicates text has been fontified.
4756 `buffer-substring' need not call the `buffer-access-fontify-functions'
4757 functions if all the text being accessed has this property. */);
4758 Vbuffer_access_fontified_property
= Qnil
;
4760 DEFVAR_LISP ("system-name", Vsystem_name
,
4761 doc
: /* The host name of the machine Emacs is running on. */);
4763 DEFVAR_LISP ("user-full-name", Vuser_full_name
,
4764 doc
: /* The full name of the user logged in. */);
4766 DEFVAR_LISP ("user-login-name", Vuser_login_name
,
4767 doc
: /* The user's name, taken from environment variables if possible. */);
4769 DEFVAR_LISP ("user-real-login-name", Vuser_real_login_name
,
4770 doc
: /* The user's name, based upon the real uid only. */);
4772 DEFVAR_LISP ("operating-system-release", Voperating_system_release
,
4773 doc
: /* The release of the operating system Emacs is running on. */);
4775 defsubr (&Spropertize
);
4776 defsubr (&Schar_equal
);
4777 defsubr (&Sgoto_char
);
4778 defsubr (&Sstring_to_char
);
4779 defsubr (&Schar_to_string
);
4780 defsubr (&Sbyte_to_string
);
4781 defsubr (&Sbuffer_substring
);
4782 defsubr (&Sbuffer_substring_no_properties
);
4783 defsubr (&Sbuffer_string
);
4785 defsubr (&Spoint_marker
);
4786 defsubr (&Smark_marker
);
4788 defsubr (&Sregion_beginning
);
4789 defsubr (&Sregion_end
);
4791 DEFSYM (Qfield
, "field");
4792 DEFSYM (Qboundary
, "boundary");
4793 defsubr (&Sfield_beginning
);
4794 defsubr (&Sfield_end
);
4795 defsubr (&Sfield_string
);
4796 defsubr (&Sfield_string_no_properties
);
4797 defsubr (&Sdelete_field
);
4798 defsubr (&Sconstrain_to_field
);
4800 defsubr (&Sline_beginning_position
);
4801 defsubr (&Sline_end_position
);
4803 /* defsubr (&Smark); */
4804 /* defsubr (&Sset_mark); */
4805 defsubr (&Ssave_excursion
);
4806 defsubr (&Ssave_current_buffer
);
4808 defsubr (&Sbufsize
);
4809 defsubr (&Spoint_max
);
4810 defsubr (&Spoint_min
);
4811 defsubr (&Spoint_min_marker
);
4812 defsubr (&Spoint_max_marker
);
4813 defsubr (&Sgap_position
);
4814 defsubr (&Sgap_size
);
4815 defsubr (&Sposition_bytes
);
4816 defsubr (&Sbyte_to_position
);
4822 defsubr (&Sfollowing_char
);
4823 defsubr (&Sprevious_char
);
4824 defsubr (&Schar_after
);
4825 defsubr (&Schar_before
);
4827 defsubr (&Sinsert_before_markers
);
4828 defsubr (&Sinsert_and_inherit
);
4829 defsubr (&Sinsert_and_inherit_before_markers
);
4830 defsubr (&Sinsert_char
);
4831 defsubr (&Sinsert_byte
);
4833 defsubr (&Suser_login_name
);
4834 defsubr (&Suser_real_login_name
);
4835 defsubr (&Suser_uid
);
4836 defsubr (&Suser_real_uid
);
4837 defsubr (&Suser_full_name
);
4838 defsubr (&Semacs_pid
);
4839 defsubr (&Scurrent_time
);
4840 defsubr (&Sget_internal_run_time
);
4841 defsubr (&Sformat_time_string
);
4842 defsubr (&Sfloat_time
);
4843 defsubr (&Sdecode_time
);
4844 defsubr (&Sencode_time
);
4845 defsubr (&Scurrent_time_string
);
4846 defsubr (&Scurrent_time_zone
);
4847 defsubr (&Sset_time_zone_rule
);
4848 defsubr (&Ssystem_name
);
4849 defsubr (&Smessage
);
4850 defsubr (&Smessage_box
);
4851 defsubr (&Smessage_or_box
);
4852 defsubr (&Scurrent_message
);
4855 defsubr (&Sinsert_buffer_substring
);
4856 defsubr (&Scompare_buffer_substrings
);
4857 defsubr (&Ssubst_char_in_region
);
4858 defsubr (&Stranslate_region_internal
);
4859 defsubr (&Sdelete_region
);
4860 defsubr (&Sdelete_and_extract_region
);
4862 defsubr (&Snarrow_to_region
);
4863 defsubr (&Ssave_restriction
);
4864 defsubr (&Stranspose_regions
);