1 /* Lisp functions pertaining to editing.
3 Copyright (C) 1985-1987, 1989, 1993-2014 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>
53 #include "intervals.h"
54 #include "character.h"
59 #include "blockinput.h"
61 #define TM_YEAR_BASE 1900
64 extern Lisp_Object
w32_get_internal_run_time (void);
67 static Lisp_Object
format_time_string (char const *, ptrdiff_t, struct timespec
,
69 static int tm_diff (struct tm
*, struct tm
*);
70 static void update_buffer_properties (ptrdiff_t, ptrdiff_t);
72 static Lisp_Object Qbuffer_access_fontify_functions
;
74 /* Symbol for the text property used to mark fields. */
78 /* A special value for Qfield properties. */
80 static Lisp_Object Qboundary
;
82 /* The startup value of the TZ environment variable so it can be
83 restored if the user calls set-time-zone-rule with a nil
84 argument. If null, the TZ environment variable was unset. */
85 static char const *initial_tz
;
87 /* True if the static variable tzvalbuf (defined in
88 set_time_zone_rule) is part of 'environ'. */
89 static bool tzvalbuf_in_environ
;
95 const char *user_name
;
97 struct passwd
*pw
; /* password entry for the current user */
100 /* Set up system_name even when dumping. */
104 /* Don't bother with this on initial start when just dumping out */
107 #endif /* not CANNOT_DUMP */
109 initial_tz
= getenv ("TZ");
110 tzvalbuf_in_environ
= 0;
112 pw
= getpwuid (getuid ());
114 /* We let the real user name default to "root" because that's quite
115 accurate on MSDOG and because it lets Emacs find the init file.
116 (The DVX libraries override the Djgpp libraries here.) */
117 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "root");
119 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "unknown");
122 /* Get the effective user name, by consulting environment variables,
123 or the effective uid if those are unset. */
124 user_name
= getenv ("LOGNAME");
127 user_name
= getenv ("USERNAME"); /* it's USERNAME on NT */
128 #else /* WINDOWSNT */
129 user_name
= getenv ("USER");
130 #endif /* WINDOWSNT */
133 pw
= getpwuid (geteuid ());
134 user_name
= pw
? pw
->pw_name
: "unknown";
136 Vuser_login_name
= build_string (user_name
);
138 /* If the user name claimed in the environment vars differs from
139 the real uid, use the claimed name to find the full name. */
140 tem
= Fstring_equal (Vuser_login_name
, Vuser_real_login_name
);
142 tem
= Vuser_login_name
;
145 uid_t euid
= geteuid ();
146 tem
= make_fixnum_or_float (euid
);
148 Vuser_full_name
= Fuser_full_name (tem
);
152 Vuser_full_name
= build_string (p
);
153 else if (NILP (Vuser_full_name
))
154 Vuser_full_name
= build_string ("unknown");
156 #ifdef HAVE_SYS_UTSNAME_H
160 Voperating_system_release
= build_string (uts
.release
);
163 Voperating_system_release
= Qnil
;
167 DEFUN ("char-to-string", Fchar_to_string
, Schar_to_string
, 1, 1, 0,
168 doc
: /* Convert arg CHAR to a string containing that character.
169 usage: (char-to-string CHAR) */)
170 (Lisp_Object character
)
173 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
175 CHECK_CHARACTER (character
);
176 c
= XFASTINT (character
);
178 len
= CHAR_STRING (c
, str
);
179 return make_string_from_bytes ((char *) str
, 1, len
);
182 DEFUN ("byte-to-string", Fbyte_to_string
, Sbyte_to_string
, 1, 1, 0,
183 doc
: /* Convert arg BYTE to a unibyte string containing that byte. */)
188 if (XINT (byte
) < 0 || XINT (byte
) > 255)
189 error ("Invalid byte");
191 return make_string_from_bytes ((char *) &b
, 1, 1);
194 DEFUN ("string-to-char", Fstring_to_char
, Sstring_to_char
, 1, 1, 0,
195 doc
: /* Return the first character in STRING. */)
196 (register Lisp_Object string
)
198 register Lisp_Object val
;
199 CHECK_STRING (string
);
202 if (STRING_MULTIBYTE (string
))
203 XSETFASTINT (val
, STRING_CHAR (SDATA (string
)));
205 XSETFASTINT (val
, SREF (string
, 0));
208 XSETFASTINT (val
, 0);
212 DEFUN ("point", Fpoint
, Spoint
, 0, 0, 0,
213 doc
: /* Return value of point, as an integer.
214 Beginning of buffer is position (point-min). */)
218 XSETFASTINT (temp
, PT
);
222 DEFUN ("point-marker", Fpoint_marker
, Spoint_marker
, 0, 0, 0,
223 doc
: /* Return value of point, as a marker object. */)
226 return build_marker (current_buffer
, PT
, PT_BYTE
);
229 DEFUN ("goto-char", Fgoto_char
, Sgoto_char
, 1, 1, "NGoto char: ",
230 doc
: /* Set point to POSITION, a number or marker.
231 Beginning of buffer is position (point-min), end is (point-max).
233 The return value is POSITION. */)
234 (register Lisp_Object position
)
236 if (MARKERP (position
))
237 set_point_from_marker (position
);
238 else if (INTEGERP (position
))
239 SET_PT (clip_to_bounds (BEGV
, XINT (position
), ZV
));
241 wrong_type_argument (Qinteger_or_marker_p
, position
);
246 /* Return the start or end position of the region.
247 BEGINNINGP means return the start.
248 If there is no region active, signal an error. */
251 region_limit (bool beginningp
)
255 if (!NILP (Vtransient_mark_mode
)
256 && NILP (Vmark_even_if_inactive
)
257 && NILP (BVAR (current_buffer
, mark_active
)))
258 xsignal0 (Qmark_inactive
);
260 m
= Fmarker_position (BVAR (current_buffer
, mark
));
262 error ("The mark is not set now, so there is no region");
264 /* Clip to the current narrowing (bug#11770). */
265 return make_number ((PT
< XFASTINT (m
)) == beginningp
267 : clip_to_bounds (BEGV
, XFASTINT (m
), ZV
));
270 DEFUN ("region-beginning", Fregion_beginning
, Sregion_beginning
, 0, 0, 0,
271 doc
: /* Return the integer value of point or mark, whichever is smaller. */)
274 return region_limit (1);
277 DEFUN ("region-end", Fregion_end
, Sregion_end
, 0, 0, 0,
278 doc
: /* Return the integer value of point or mark, whichever is larger. */)
281 return region_limit (0);
284 DEFUN ("mark-marker", Fmark_marker
, Smark_marker
, 0, 0, 0,
285 doc
: /* Return this buffer's mark, as a marker object.
286 Watch out! Moving this marker changes the mark position.
287 If you set the marker not to point anywhere, the buffer will have no mark. */)
290 return BVAR (current_buffer
, mark
);
294 /* Find all the overlays in the current buffer that touch position POS.
295 Return the number found, and store them in a vector in VEC
299 overlays_around (EMACS_INT pos
, Lisp_Object
*vec
, ptrdiff_t len
)
301 Lisp_Object overlay
, start
, end
;
302 struct Lisp_Overlay
*tail
;
303 ptrdiff_t startpos
, endpos
;
306 for (tail
= current_buffer
->overlays_before
; tail
; tail
= tail
->next
)
308 XSETMISC (overlay
, tail
);
310 end
= OVERLAY_END (overlay
);
311 endpos
= OVERLAY_POSITION (end
);
314 start
= OVERLAY_START (overlay
);
315 startpos
= OVERLAY_POSITION (start
);
320 /* Keep counting overlays even if we can't return them all. */
325 for (tail
= current_buffer
->overlays_after
; tail
; tail
= tail
->next
)
327 XSETMISC (overlay
, tail
);
329 start
= OVERLAY_START (overlay
);
330 startpos
= OVERLAY_POSITION (start
);
333 end
= OVERLAY_END (overlay
);
334 endpos
= OVERLAY_POSITION (end
);
346 DEFUN ("get-pos-property", Fget_pos_property
, Sget_pos_property
, 2, 3, 0,
347 doc
: /* Return the value of POSITION's property PROP, in OBJECT.
348 Almost identical to `get-char-property' except for the following difference:
349 Whereas `get-char-property' returns the property of the char at (i.e. right
350 after) POSITION, this pays attention to properties's stickiness and overlays's
351 advancement settings, in order to find the property of POSITION itself,
352 i.e. the property that a char would inherit if it were inserted
354 (Lisp_Object position
, register Lisp_Object prop
, Lisp_Object object
)
356 CHECK_NUMBER_COERCE_MARKER (position
);
359 XSETBUFFER (object
, current_buffer
);
360 else if (WINDOWP (object
))
361 object
= XWINDOW (object
)->contents
;
363 if (!BUFFERP (object
))
364 /* pos-property only makes sense in buffers right now, since strings
365 have no overlays and no notion of insertion for which stickiness
367 return Fget_text_property (position
, prop
, object
);
370 EMACS_INT posn
= XINT (position
);
372 Lisp_Object
*overlay_vec
, tem
;
373 struct buffer
*obuf
= current_buffer
;
376 set_buffer_temp (XBUFFER (object
));
378 /* First try with room for 40 overlays. */
380 overlay_vec
= alloca (noverlays
* sizeof *overlay_vec
);
381 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
383 /* If there are more than 40,
384 make enough space for all, and try again. */
387 SAFE_ALLOCA_LISP (overlay_vec
, noverlays
);
388 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
390 noverlays
= sort_overlays (overlay_vec
, noverlays
, NULL
);
392 set_buffer_temp (obuf
);
394 /* Now check the overlays in order of decreasing priority. */
395 while (--noverlays
>= 0)
397 Lisp_Object ol
= overlay_vec
[noverlays
];
398 tem
= Foverlay_get (ol
, prop
);
401 /* Check the overlay is indeed active at point. */
402 Lisp_Object start
= OVERLAY_START (ol
), finish
= OVERLAY_END (ol
);
403 if ((OVERLAY_POSITION (start
) == posn
404 && XMARKER (start
)->insertion_type
== 1)
405 || (OVERLAY_POSITION (finish
) == posn
406 && XMARKER (finish
)->insertion_type
== 0))
407 ; /* The overlay will not cover a char inserted at point. */
417 { /* Now check the text properties. */
418 int stickiness
= text_property_stickiness (prop
, position
, object
);
420 return Fget_text_property (position
, prop
, object
);
421 else if (stickiness
< 0
422 && XINT (position
) > BUF_BEGV (XBUFFER (object
)))
423 return Fget_text_property (make_number (XINT (position
) - 1),
431 /* Find the field surrounding POS in *BEG and *END. If POS is nil,
432 the value of point is used instead. If BEG or END is null,
433 means don't store the beginning or end of the field.
435 BEG_LIMIT and END_LIMIT serve to limit the ranged of the returned
436 results; they do not effect boundary behavior.
438 If MERGE_AT_BOUNDARY is non-nil, then if POS is at the very first
439 position of a field, then the beginning of the previous field is
440 returned instead of the beginning of POS's field (since the end of a
441 field is actually also the beginning of the next input field, this
442 behavior is sometimes useful). Additionally in the MERGE_AT_BOUNDARY
443 non-nil case, if two fields are separated by a field with the special
444 value `boundary', and POS lies within it, then the two separated
445 fields are considered to be adjacent, and POS between them, when
446 finding the beginning and ending of the "merged" field.
448 Either BEG or END may be 0, in which case the corresponding value
452 find_field (Lisp_Object pos
, Lisp_Object merge_at_boundary
,
453 Lisp_Object beg_limit
,
454 ptrdiff_t *beg
, Lisp_Object end_limit
, ptrdiff_t *end
)
456 /* Fields right before and after the point. */
457 Lisp_Object before_field
, after_field
;
458 /* True if POS counts as the start of a field. */
459 bool at_field_start
= 0;
460 /* True if POS counts as the end of a field. */
461 bool at_field_end
= 0;
464 XSETFASTINT (pos
, PT
);
466 CHECK_NUMBER_COERCE_MARKER (pos
);
469 = get_char_property_and_overlay (pos
, Qfield
, Qnil
, NULL
);
471 = (XFASTINT (pos
) > BEGV
472 ? get_char_property_and_overlay (make_number (XINT (pos
) - 1),
474 /* Using nil here would be a more obvious choice, but it would
475 fail when the buffer starts with a non-sticky field. */
478 /* See if we need to handle the case where MERGE_AT_BOUNDARY is nil
479 and POS is at beginning of a field, which can also be interpreted
480 as the end of the previous field. Note that the case where if
481 MERGE_AT_BOUNDARY is non-nil (see function comment) is actually the
482 more natural one; then we avoid treating the beginning of a field
484 if (NILP (merge_at_boundary
))
486 Lisp_Object field
= Fget_pos_property (pos
, Qfield
, Qnil
);
487 if (!EQ (field
, after_field
))
489 if (!EQ (field
, before_field
))
491 if (NILP (field
) && at_field_start
&& at_field_end
)
492 /* If an inserted char would have a nil field while the surrounding
493 text is non-nil, we're probably not looking at a
494 zero-length field, but instead at a non-nil field that's
495 not intended for editing (such as comint's prompts). */
496 at_field_end
= at_field_start
= 0;
499 /* Note about special `boundary' fields:
501 Consider the case where the point (`.') is between the fields `x' and `y':
505 In this situation, if merge_at_boundary is non-nil, consider the
506 `x' and `y' fields as forming one big merged field, and so the end
507 of the field is the end of `y'.
509 However, if `x' and `y' are separated by a special `boundary' field
510 (a field with a `field' char-property of 'boundary), then ignore
511 this special field when merging adjacent fields. Here's the same
512 situation, but with a `boundary' field between the `x' and `y' fields:
516 Here, if point is at the end of `x', the beginning of `y', or
517 anywhere in-between (within the `boundary' field), merge all
518 three fields and consider the beginning as being the beginning of
519 the `x' field, and the end as being the end of the `y' field. */
524 /* POS is at the edge of a field, and we should consider it as
525 the beginning of the following field. */
526 *beg
= XFASTINT (pos
);
528 /* Find the previous field boundary. */
531 if (!NILP (merge_at_boundary
) && EQ (before_field
, Qboundary
))
532 /* Skip a `boundary' field. */
533 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
536 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
538 *beg
= NILP (p
) ? BEGV
: XFASTINT (p
);
545 /* POS is at the edge of a field, and we should consider it as
546 the end of the previous field. */
547 *end
= XFASTINT (pos
);
549 /* Find the next field boundary. */
551 if (!NILP (merge_at_boundary
) && EQ (after_field
, Qboundary
))
552 /* Skip a `boundary' field. */
553 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
556 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
558 *end
= NILP (pos
) ? ZV
: XFASTINT (pos
);
564 DEFUN ("delete-field", Fdelete_field
, Sdelete_field
, 0, 1, 0,
565 doc
: /* Delete the field surrounding POS.
566 A field is a region of text with the same `field' property.
567 If POS is nil, the value of point is used for POS. */)
571 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
573 del_range (beg
, end
);
577 DEFUN ("field-string", Ffield_string
, Sfield_string
, 0, 1, 0,
578 doc
: /* Return the contents of the field surrounding POS as a string.
579 A field is a region of text with the same `field' property.
580 If POS is nil, the value of point is used for POS. */)
584 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
585 return make_buffer_string (beg
, end
, 1);
588 DEFUN ("field-string-no-properties", Ffield_string_no_properties
, Sfield_string_no_properties
, 0, 1, 0,
589 doc
: /* Return the contents of the field around POS, without text properties.
590 A field is a region of text with the same `field' property.
591 If POS is nil, the value of point is used for POS. */)
595 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
596 return make_buffer_string (beg
, end
, 0);
599 DEFUN ("field-beginning", Ffield_beginning
, Sfield_beginning
, 0, 3, 0,
600 doc
: /* Return the beginning of the field surrounding POS.
601 A field is a region of text with the same `field' property.
602 If POS is nil, the value of point is used for POS.
603 If ESCAPE-FROM-EDGE is non-nil and POS is at the beginning of its
604 field, then the beginning of the *previous* field is returned.
605 If LIMIT is non-nil, it is a buffer position; if the beginning of the field
606 is before LIMIT, then LIMIT will be returned instead. */)
607 (Lisp_Object pos
, Lisp_Object escape_from_edge
, Lisp_Object limit
)
610 find_field (pos
, escape_from_edge
, limit
, &beg
, Qnil
, 0);
611 return make_number (beg
);
614 DEFUN ("field-end", Ffield_end
, Sfield_end
, 0, 3, 0,
615 doc
: /* Return the end of the field surrounding POS.
616 A field is a region of text with the same `field' property.
617 If POS is nil, the value of point is used for POS.
618 If ESCAPE-FROM-EDGE is non-nil and POS is at the end of its field,
619 then the end of the *following* field is returned.
620 If LIMIT is non-nil, it is a buffer position; if the end of the field
621 is after LIMIT, then LIMIT will be returned instead. */)
622 (Lisp_Object pos
, Lisp_Object escape_from_edge
, Lisp_Object limit
)
625 find_field (pos
, escape_from_edge
, Qnil
, 0, limit
, &end
);
626 return make_number (end
);
629 DEFUN ("constrain-to-field", Fconstrain_to_field
, Sconstrain_to_field
, 2, 5, 0,
630 doc
: /* Return the position closest to NEW-POS that is in the same field as OLD-POS.
631 A field is a region of text with the same `field' property.
633 If NEW-POS is nil, then use the current point instead, and move point
634 to the resulting constrained position, in addition to returning that
637 If OLD-POS is at the boundary of two fields, then the allowable
638 positions for NEW-POS depends on the value of the optional argument
639 ESCAPE-FROM-EDGE: If ESCAPE-FROM-EDGE is nil, then NEW-POS is
640 constrained to the field that has the same `field' char-property
641 as any new characters inserted at OLD-POS, whereas if ESCAPE-FROM-EDGE
642 is non-nil, NEW-POS is constrained to the union of the two adjacent
643 fields. Additionally, if two fields are separated by another field with
644 the special value `boundary', then any point within this special field is
645 also considered to be `on the boundary'.
647 If the optional argument ONLY-IN-LINE is non-nil and constraining
648 NEW-POS would move it to a different line, NEW-POS is returned
649 unconstrained. This is useful for commands that move by line, like
650 \\[next-line] or \\[beginning-of-line], which should generally respect field boundaries
651 only in the case where they can still move to the right line.
653 If the optional argument INHIBIT-CAPTURE-PROPERTY is non-nil, and OLD-POS has
654 a non-nil property of that name, then any field boundaries are ignored.
656 Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */)
657 (Lisp_Object new_pos
, Lisp_Object old_pos
, Lisp_Object escape_from_edge
,
658 Lisp_Object only_in_line
, Lisp_Object inhibit_capture_property
)
660 /* If non-zero, then the original point, before re-positioning. */
661 ptrdiff_t orig_point
= 0;
663 Lisp_Object prev_old
, prev_new
;
666 /* Use the current point, and afterwards, set it. */
669 XSETFASTINT (new_pos
, PT
);
672 CHECK_NUMBER_COERCE_MARKER (new_pos
);
673 CHECK_NUMBER_COERCE_MARKER (old_pos
);
675 fwd
= (XINT (new_pos
) > XINT (old_pos
));
677 prev_old
= make_number (XINT (old_pos
) - 1);
678 prev_new
= make_number (XINT (new_pos
) - 1);
680 if (NILP (Vinhibit_field_text_motion
)
681 && !EQ (new_pos
, old_pos
)
682 && (!NILP (Fget_char_property (new_pos
, Qfield
, Qnil
))
683 || !NILP (Fget_char_property (old_pos
, Qfield
, Qnil
))
684 /* To recognize field boundaries, we must also look at the
685 previous positions; we could use `Fget_pos_property'
686 instead, but in itself that would fail inside non-sticky
687 fields (like comint prompts). */
688 || (XFASTINT (new_pos
) > BEGV
689 && !NILP (Fget_char_property (prev_new
, Qfield
, Qnil
)))
690 || (XFASTINT (old_pos
) > BEGV
691 && !NILP (Fget_char_property (prev_old
, Qfield
, Qnil
))))
692 && (NILP (inhibit_capture_property
)
693 /* Field boundaries are again a problem; but now we must
694 decide the case exactly, so we need to call
695 `get_pos_property' as well. */
696 || (NILP (Fget_pos_property (old_pos
, inhibit_capture_property
, Qnil
))
697 && (XFASTINT (old_pos
) <= BEGV
698 || NILP (Fget_char_property
699 (old_pos
, inhibit_capture_property
, Qnil
))
700 || NILP (Fget_char_property
701 (prev_old
, inhibit_capture_property
, Qnil
))))))
702 /* It is possible that NEW_POS is not within the same field as
703 OLD_POS; try to move NEW_POS so that it is. */
706 Lisp_Object field_bound
;
709 field_bound
= Ffield_end (old_pos
, escape_from_edge
, new_pos
);
711 field_bound
= Ffield_beginning (old_pos
, escape_from_edge
, new_pos
);
713 if (/* See if ESCAPE_FROM_EDGE caused FIELD_BOUND to jump to the
714 other side of NEW_POS, which would mean that NEW_POS is
715 already acceptable, and it's not necessary to constrain it
717 ((XFASTINT (field_bound
) < XFASTINT (new_pos
)) ? fwd
: !fwd
)
718 /* NEW_POS should be constrained, but only if either
719 ONLY_IN_LINE is nil (in which case any constraint is OK),
720 or NEW_POS and FIELD_BOUND are on the same line (in which
721 case the constraint is OK even if ONLY_IN_LINE is non-nil). */
722 && (NILP (only_in_line
)
723 /* This is the ONLY_IN_LINE case, check that NEW_POS and
724 FIELD_BOUND are on the same line by seeing whether
725 there's an intervening newline or not. */
726 || (find_newline (XFASTINT (new_pos
), -1,
727 XFASTINT (field_bound
), -1,
728 fwd
? -1 : 1, &shortage
, NULL
, 1),
730 /* Constrain NEW_POS to FIELD_BOUND. */
731 new_pos
= field_bound
;
733 if (orig_point
&& XFASTINT (new_pos
) != orig_point
)
734 /* The NEW_POS argument was originally nil, so automatically set PT. */
735 SET_PT (XFASTINT (new_pos
));
742 DEFUN ("line-beginning-position",
743 Fline_beginning_position
, Sline_beginning_position
, 0, 1, 0,
744 doc
: /* Return the character position of the first character on the current line.
745 With optional argument N, scan forward N - 1 lines first.
746 If the scan reaches the end of the buffer, return that position.
748 This function ignores text display directionality; it returns the
749 position of the first character in logical order, i.e. the smallest
750 character position on the line.
752 This function constrains the returned position to the current field
753 unless that position would be on a different line than the original,
754 unconstrained result. If N is nil or 1, and a front-sticky field
755 starts at point, the scan stops as soon as it starts. To ignore field
756 boundaries, bind `inhibit-field-text-motion' to t.
758 This function does not move point. */)
761 ptrdiff_t orig
, orig_byte
, end
;
763 specbind (Qinhibit_point_motion_hooks
, Qt
);
772 Fforward_line (make_number (XINT (n
) - 1));
775 SET_PT_BOTH (orig
, orig_byte
);
779 /* Return END constrained to the current input field. */
780 return Fconstrain_to_field (make_number (end
), make_number (orig
),
781 XINT (n
) != 1 ? Qt
: Qnil
,
785 DEFUN ("line-end-position", Fline_end_position
, Sline_end_position
, 0, 1, 0,
786 doc
: /* Return the character position of the last character on the current line.
787 With argument N not nil or 1, move forward N - 1 lines first.
788 If scan reaches end of buffer, return that position.
790 This function ignores text display directionality; it returns the
791 position of the last character in logical order, i.e. the largest
792 character position on the line.
794 This function constrains the returned position to the current field
795 unless that would be on a different line than the original,
796 unconstrained result. If N is nil or 1, and a rear-sticky field ends
797 at point, the scan stops as soon as it starts. To ignore field
798 boundaries bind `inhibit-field-text-motion' to t.
800 This function does not move point. */)
812 clipped_n
= clip_to_bounds (PTRDIFF_MIN
+ 1, XINT (n
), PTRDIFF_MAX
);
813 end_pos
= find_before_next_newline (orig
, 0, clipped_n
- (clipped_n
<= 0),
816 /* Return END_POS constrained to the current input field. */
817 return Fconstrain_to_field (make_number (end_pos
), make_number (orig
),
821 /* Save current buffer state for `save-excursion' special form.
822 We (ab)use Lisp_Misc_Save_Value to allow explicit free and so
823 offload some work from GC. */
826 save_excursion_save (void)
828 return make_save_obj_obj_obj_obj
830 /* Do not copy the mark if it points to nowhere. */
831 (XMARKER (BVAR (current_buffer
, mark
))->buffer
832 ? Fcopy_marker (BVAR (current_buffer
, mark
), Qnil
)
834 /* Selected window if current buffer is shown in it, nil otherwise. */
835 (EQ (XWINDOW (selected_window
)->contents
, Fcurrent_buffer ())
836 ? selected_window
: Qnil
),
837 BVAR (current_buffer
, mark_active
));
840 /* Restore saved buffer before leaving `save-excursion' special form. */
843 save_excursion_restore (Lisp_Object info
)
845 Lisp_Object tem
, tem1
, omark
, nmark
;
846 struct gcpro gcpro1
, gcpro2
, gcpro3
;
848 tem
= Fmarker_buffer (XSAVE_OBJECT (info
, 0));
849 /* If we're unwinding to top level, saved buffer may be deleted. This
850 means that all of its markers are unchained and so tem is nil. */
854 omark
= nmark
= Qnil
;
855 GCPRO3 (info
, omark
, nmark
);
860 tem
= XSAVE_OBJECT (info
, 0);
862 unchain_marker (XMARKER (tem
));
865 tem
= XSAVE_OBJECT (info
, 1);
866 omark
= Fmarker_position (BVAR (current_buffer
, mark
));
868 unchain_marker (XMARKER (BVAR (current_buffer
, mark
)));
871 Fset_marker (BVAR (current_buffer
, mark
), tem
, Fcurrent_buffer ());
872 nmark
= Fmarker_position (tem
);
873 unchain_marker (XMARKER (tem
));
877 tem
= XSAVE_OBJECT (info
, 3);
878 tem1
= BVAR (current_buffer
, mark_active
);
879 bset_mark_active (current_buffer
, tem
);
881 /* If mark is active now, and either was not active
882 or was at a different place, run the activate hook. */
885 if (! EQ (omark
, nmark
))
887 tem
= intern ("activate-mark-hook");
888 Frun_hooks (1, &tem
);
891 /* If mark has ceased to be active, run deactivate hook. */
892 else if (! NILP (tem1
))
894 tem
= intern ("deactivate-mark-hook");
895 Frun_hooks (1, &tem
);
898 /* If buffer was visible in a window, and a different window was
899 selected, and the old selected window is still showing this
900 buffer, restore point in that window. */
901 tem
= XSAVE_OBJECT (info
, 2);
903 && !EQ (tem
, selected_window
)
904 && (tem1
= XWINDOW (tem
)->contents
,
905 (/* Window is live... */
907 /* ...and it shows the current buffer. */
908 && XBUFFER (tem1
) == current_buffer
)))
909 Fset_window_point (tem
, make_number (PT
));
918 DEFUN ("save-excursion", Fsave_excursion
, Ssave_excursion
, 0, UNEVALLED
, 0,
919 doc
: /* Save point, mark, and current buffer; execute BODY; restore those things.
920 Executes BODY just like `progn'.
921 The values of point, mark and the current buffer are restored
922 even in case of abnormal exit (throw or error).
923 The state of activation of the mark is also restored.
925 This construct does not save `deactivate-mark', and therefore
926 functions that change the buffer will still cause deactivation
927 of the mark at the end of the command. To prevent that, bind
928 `deactivate-mark' with `let'.
930 If you only want to save the current buffer but not point nor mark,
931 then just use `save-current-buffer', or even `with-current-buffer'.
933 usage: (save-excursion &rest BODY) */)
936 register Lisp_Object val
;
939 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
946 DEFUN ("save-current-buffer", Fsave_current_buffer
, Ssave_current_buffer
, 0, UNEVALLED
, 0,
947 doc
: /* Record which buffer is current; execute BODY; make that buffer current.
948 BODY is executed just like `progn'.
949 usage: (save-current-buffer &rest BODY) */)
954 record_unwind_current_buffer ();
955 Lisp_Object tem0
= Fprogn (args
);
960 DEFUN ("buffer-size", Fbuffer_size
, Sbuffer_size
, 0, 1, 0,
961 doc
: /* Return the number of characters in the current buffer.
962 If BUFFER, return the number of characters in that buffer instead. */)
966 return make_number (Z
- BEG
);
969 CHECK_BUFFER (buffer
);
970 return make_number (BUF_Z (XBUFFER (buffer
))
971 - BUF_BEG (XBUFFER (buffer
)));
975 DEFUN ("point-min", Fpoint_min
, Spoint_min
, 0, 0, 0,
976 doc
: /* Return the minimum permissible value of point in the current buffer.
977 This is 1, unless narrowing (a buffer restriction) is in effect. */)
981 XSETFASTINT (temp
, BEGV
);
985 DEFUN ("point-min-marker", Fpoint_min_marker
, Spoint_min_marker
, 0, 0, 0,
986 doc
: /* Return a marker to the minimum permissible value of point in this buffer.
987 This is the beginning, unless narrowing (a buffer restriction) is in effect. */)
990 return build_marker (current_buffer
, BEGV
, BEGV_BYTE
);
993 DEFUN ("point-max", Fpoint_max
, Spoint_max
, 0, 0, 0,
994 doc
: /* Return the maximum permissible value of point in the current buffer.
995 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
996 is in effect, in which case it is less. */)
1000 XSETFASTINT (temp
, ZV
);
1004 DEFUN ("point-max-marker", Fpoint_max_marker
, Spoint_max_marker
, 0, 0, 0,
1005 doc
: /* Return a marker to the maximum permissible value of point in this buffer.
1006 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1007 is in effect, in which case it is less. */)
1010 return build_marker (current_buffer
, ZV
, ZV_BYTE
);
1013 DEFUN ("gap-position", Fgap_position
, Sgap_position
, 0, 0, 0,
1014 doc
: /* Return the position of the gap, in the current buffer.
1015 See also `gap-size'. */)
1019 XSETFASTINT (temp
, GPT
);
1023 DEFUN ("gap-size", Fgap_size
, Sgap_size
, 0, 0, 0,
1024 doc
: /* Return the size of the current buffer's gap.
1025 See also `gap-position'. */)
1029 XSETFASTINT (temp
, GAP_SIZE
);
1033 DEFUN ("position-bytes", Fposition_bytes
, Sposition_bytes
, 1, 1, 0,
1034 doc
: /* Return the byte position for character position POSITION.
1035 If POSITION is out of range, the value is nil. */)
1036 (Lisp_Object position
)
1038 CHECK_NUMBER_COERCE_MARKER (position
);
1039 if (XINT (position
) < BEG
|| XINT (position
) > Z
)
1041 return make_number (CHAR_TO_BYTE (XINT (position
)));
1044 DEFUN ("byte-to-position", Fbyte_to_position
, Sbyte_to_position
, 1, 1, 0,
1045 doc
: /* Return the character position for byte position BYTEPOS.
1046 If BYTEPOS is out of range, the value is nil. */)
1047 (Lisp_Object bytepos
)
1049 CHECK_NUMBER (bytepos
);
1050 if (XINT (bytepos
) < BEG_BYTE
|| XINT (bytepos
) > Z_BYTE
)
1052 return make_number (BYTE_TO_CHAR (XINT (bytepos
)));
1055 DEFUN ("following-char", Ffollowing_char
, Sfollowing_char
, 0, 0, 0,
1056 doc
: /* Return the character following point, as a number.
1057 At the end of the buffer or accessible region, return 0. */)
1062 XSETFASTINT (temp
, 0);
1064 XSETFASTINT (temp
, FETCH_CHAR (PT_BYTE
));
1068 DEFUN ("preceding-char", Fprevious_char
, Sprevious_char
, 0, 0, 0,
1069 doc
: /* Return the character preceding point, as a number.
1070 At the beginning of the buffer or accessible region, return 0. */)
1075 XSETFASTINT (temp
, 0);
1076 else if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
1078 ptrdiff_t pos
= PT_BYTE
;
1080 XSETFASTINT (temp
, FETCH_CHAR (pos
));
1083 XSETFASTINT (temp
, FETCH_BYTE (PT_BYTE
- 1));
1087 DEFUN ("bobp", Fbobp
, Sbobp
, 0, 0, 0,
1088 doc
: /* Return t if point is at the beginning of the buffer.
1089 If the buffer is narrowed, this means the beginning of the narrowed part. */)
1097 DEFUN ("eobp", Feobp
, Seobp
, 0, 0, 0,
1098 doc
: /* Return t if point is at the end of the buffer.
1099 If the buffer is narrowed, this means the end of the narrowed part. */)
1107 DEFUN ("bolp", Fbolp
, Sbolp
, 0, 0, 0,
1108 doc
: /* Return t if point is at the beginning of a line. */)
1111 if (PT
== BEGV
|| FETCH_BYTE (PT_BYTE
- 1) == '\n')
1116 DEFUN ("eolp", Feolp
, Seolp
, 0, 0, 0,
1117 doc
: /* Return t if point is at the end of a line.
1118 `End of a line' includes point being at the end of the buffer. */)
1121 if (PT
== ZV
|| FETCH_BYTE (PT_BYTE
) == '\n')
1126 DEFUN ("char-after", Fchar_after
, Schar_after
, 0, 1, 0,
1127 doc
: /* Return character in current buffer at position POS.
1128 POS is an integer or a marker and defaults to point.
1129 If POS is out of range, the value is nil. */)
1132 register ptrdiff_t pos_byte
;
1137 XSETFASTINT (pos
, PT
);
1142 pos_byte
= marker_byte_position (pos
);
1143 if (pos_byte
< BEGV_BYTE
|| pos_byte
>= ZV_BYTE
)
1148 CHECK_NUMBER_COERCE_MARKER (pos
);
1149 if (XINT (pos
) < BEGV
|| XINT (pos
) >= ZV
)
1152 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1155 return make_number (FETCH_CHAR (pos_byte
));
1158 DEFUN ("char-before", Fchar_before
, Schar_before
, 0, 1, 0,
1159 doc
: /* Return character in current buffer preceding position POS.
1160 POS is an integer or a marker and defaults to point.
1161 If POS is out of range, the value is nil. */)
1164 register Lisp_Object val
;
1165 register ptrdiff_t pos_byte
;
1170 XSETFASTINT (pos
, PT
);
1175 pos_byte
= marker_byte_position (pos
);
1177 if (pos_byte
<= BEGV_BYTE
|| pos_byte
> ZV_BYTE
)
1182 CHECK_NUMBER_COERCE_MARKER (pos
);
1184 if (XINT (pos
) <= BEGV
|| XINT (pos
) > ZV
)
1187 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1190 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
1193 XSETFASTINT (val
, FETCH_CHAR (pos_byte
));
1198 XSETFASTINT (val
, FETCH_BYTE (pos_byte
));
1203 DEFUN ("user-login-name", Fuser_login_name
, Suser_login_name
, 0, 1, 0,
1204 doc
: /* Return the name under which the user logged in, as a string.
1205 This is based on the effective uid, not the real uid.
1206 Also, if the environment variables LOGNAME or USER are set,
1207 that determines the value of this function.
1209 If optional argument UID is an integer or a float, return the login name
1210 of the user with that uid, or nil if there is no such user. */)
1216 /* Set up the user name info if we didn't do it before.
1217 (That can happen if Emacs is dumpable
1218 but you decide to run `temacs -l loadup' and not dump. */
1219 if (INTEGERP (Vuser_login_name
))
1223 return Vuser_login_name
;
1225 CONS_TO_INTEGER (uid
, uid_t
, id
);
1229 return (pw
? build_string (pw
->pw_name
) : Qnil
);
1232 DEFUN ("user-real-login-name", Fuser_real_login_name
, Suser_real_login_name
,
1234 doc
: /* Return the name of the user's real uid, as a string.
1235 This ignores the environment variables LOGNAME and USER, so it differs from
1236 `user-login-name' when running under `su'. */)
1239 /* Set up the user name info if we didn't do it before.
1240 (That can happen if Emacs is dumpable
1241 but you decide to run `temacs -l loadup' and not dump. */
1242 if (INTEGERP (Vuser_login_name
))
1244 return Vuser_real_login_name
;
1247 DEFUN ("user-uid", Fuser_uid
, Suser_uid
, 0, 0, 0,
1248 doc
: /* Return the effective uid of Emacs.
1249 Value is an integer or a float, depending on the value. */)
1252 uid_t euid
= geteuid ();
1253 return make_fixnum_or_float (euid
);
1256 DEFUN ("user-real-uid", Fuser_real_uid
, Suser_real_uid
, 0, 0, 0,
1257 doc
: /* Return the real uid of Emacs.
1258 Value is an integer or a float, depending on the value. */)
1261 uid_t uid
= getuid ();
1262 return make_fixnum_or_float (uid
);
1265 DEFUN ("group-gid", Fgroup_gid
, Sgroup_gid
, 0, 0, 0,
1266 doc
: /* Return the effective gid of Emacs.
1267 Value is an integer or a float, depending on the value. */)
1270 gid_t egid
= getegid ();
1271 return make_fixnum_or_float (egid
);
1274 DEFUN ("group-real-gid", Fgroup_real_gid
, Sgroup_real_gid
, 0, 0, 0,
1275 doc
: /* Return the real gid of Emacs.
1276 Value is an integer or a float, depending on the value. */)
1279 gid_t gid
= getgid ();
1280 return make_fixnum_or_float (gid
);
1283 DEFUN ("user-full-name", Fuser_full_name
, Suser_full_name
, 0, 1, 0,
1284 doc
: /* Return the full name of the user logged in, as a string.
1285 If the full name corresponding to Emacs's userid is not known,
1288 If optional argument UID is an integer or float, return the full name
1289 of the user with that uid, or nil if there is no such user.
1290 If UID is a string, return the full name of the user with that login
1291 name, or nil if there is no such user. */)
1295 register char *p
, *q
;
1299 return Vuser_full_name
;
1300 else if (NUMBERP (uid
))
1303 CONS_TO_INTEGER (uid
, uid_t
, u
);
1308 else if (STRINGP (uid
))
1311 pw
= getpwnam (SSDATA (uid
));
1315 error ("Invalid UID specification");
1321 /* Chop off everything after the first comma. */
1322 q
= strchr (p
, ',');
1323 full
= make_string (p
, q
? q
- p
: strlen (p
));
1325 #ifdef AMPERSAND_FULL_NAME
1327 q
= strchr (p
, '&');
1328 /* Substitute the login name for the &, upcasing the first character. */
1334 login
= Fuser_login_name (make_number (pw
->pw_uid
));
1335 r
= alloca (strlen (p
) + SCHARS (login
) + 1);
1336 memcpy (r
, p
, q
- p
);
1338 strcat (r
, SSDATA (login
));
1339 r
[q
- p
] = upcase ((unsigned char) r
[q
- p
]);
1341 full
= build_string (r
);
1343 #endif /* AMPERSAND_FULL_NAME */
1348 DEFUN ("system-name", Fsystem_name
, Ssystem_name
, 0, 0, 0,
1349 doc
: /* Return the host name of the machine you are running on, as a string. */)
1352 return Vsystem_name
;
1355 DEFUN ("emacs-pid", Femacs_pid
, Semacs_pid
, 0, 0, 0,
1356 doc
: /* Return the process ID of Emacs, as a number. */)
1359 pid_t pid
= getpid ();
1360 return make_fixnum_or_float (pid
);
1366 # define TIME_T_MIN TYPE_MINIMUM (time_t)
1369 # define TIME_T_MAX TYPE_MAXIMUM (time_t)
1372 /* Report that a time value is out of range for Emacs. */
1374 time_overflow (void)
1376 error ("Specified time is not representable");
1379 /* Return the upper part of the time T (everything but the bottom 16 bits). */
1383 time_t hi
= t
>> 16;
1385 /* Check for overflow, helping the compiler for common cases where
1386 no runtime check is needed, and taking care not to convert
1387 negative numbers to unsigned before comparing them. */
1388 if (! ((! TYPE_SIGNED (time_t)
1389 || MOST_NEGATIVE_FIXNUM
<= TIME_T_MIN
>> 16
1390 || MOST_NEGATIVE_FIXNUM
<= hi
)
1391 && (TIME_T_MAX
>> 16 <= MOST_POSITIVE_FIXNUM
1392 || hi
<= MOST_POSITIVE_FIXNUM
)))
1398 /* Return the bottom 16 bits of the time T. */
1402 return t
& ((1 << 16) - 1);
1405 DEFUN ("current-time", Fcurrent_time
, Scurrent_time
, 0, 0, 0,
1406 doc
: /* Return the current time, as the number of seconds since 1970-01-01 00:00:00.
1407 The time is returned as a list of integers (HIGH LOW USEC PSEC).
1408 HIGH has the most significant bits of the seconds, while LOW has the
1409 least significant 16 bits. USEC and PSEC are the microsecond and
1410 picosecond counts. */)
1413 return make_lisp_time (current_timespec ());
1416 DEFUN ("get-internal-run-time", Fget_internal_run_time
, Sget_internal_run_time
,
1418 doc
: /* Return the current run time used by Emacs.
1419 The time is returned as a list (HIGH LOW USEC PSEC), using the same
1420 style as (current-time).
1422 On systems that can't determine the run time, `get-internal-run-time'
1423 does the same thing as `current-time'. */)
1426 #ifdef HAVE_GETRUSAGE
1427 struct rusage usage
;
1431 if (getrusage (RUSAGE_SELF
, &usage
) < 0)
1432 /* This shouldn't happen. What action is appropriate? */
1435 /* Sum up user time and system time. */
1436 secs
= usage
.ru_utime
.tv_sec
+ usage
.ru_stime
.tv_sec
;
1437 usecs
= usage
.ru_utime
.tv_usec
+ usage
.ru_stime
.tv_usec
;
1438 if (usecs
>= 1000000)
1443 return make_lisp_time (make_timespec (secs
, usecs
* 1000));
1444 #else /* ! HAVE_GETRUSAGE */
1446 return w32_get_internal_run_time ();
1447 #else /* ! WINDOWSNT */
1448 return Fcurrent_time ();
1449 #endif /* WINDOWSNT */
1450 #endif /* HAVE_GETRUSAGE */
1454 /* Make a Lisp list that represents the time T with fraction TAIL. */
1456 make_time_tail (time_t t
, Lisp_Object tail
)
1458 return Fcons (make_number (hi_time (t
)),
1459 Fcons (make_number (lo_time (t
)), tail
));
1462 /* Make a Lisp list that represents the system time T. */
1464 make_time (time_t t
)
1466 return make_time_tail (t
, Qnil
);
1469 /* Make a Lisp list that represents the Emacs time T. T may be an
1470 invalid time, with a slightly negative tv_nsec value such as
1471 UNKNOWN_MODTIME_NSECS; in that case, the Lisp list contains a
1472 correspondingly negative picosecond count. */
1474 make_lisp_time (struct timespec t
)
1477 return make_time_tail (t
.tv_sec
, list2i (ns
/ 1000, ns
% 1000 * 1000));
1480 /* Decode a Lisp list SPECIFIED_TIME that represents a time.
1481 Set *PHIGH, *PLOW, *PUSEC, *PPSEC to its parts; do not check their values.
1482 Return true if successful. */
1484 disassemble_lisp_time (Lisp_Object specified_time
, Lisp_Object
*phigh
,
1485 Lisp_Object
*plow
, Lisp_Object
*pusec
,
1488 if (CONSP (specified_time
))
1490 Lisp_Object low
= XCDR (specified_time
);
1491 Lisp_Object usec
= make_number (0);
1492 Lisp_Object psec
= make_number (0);
1495 Lisp_Object low_tail
= XCDR (low
);
1497 if (CONSP (low_tail
))
1499 usec
= XCAR (low_tail
);
1500 low_tail
= XCDR (low_tail
);
1501 if (CONSP (low_tail
))
1502 psec
= XCAR (low_tail
);
1504 else if (!NILP (low_tail
))
1508 *phigh
= XCAR (specified_time
);
1518 /* From the time components HIGH, LOW, USEC and PSEC taken from a Lisp
1519 list, generate the corresponding time value.
1521 If RESULT is not null, store into *RESULT the converted time;
1522 this can fail if the converted time does not fit into struct timespec.
1523 If *DRESULT is not null, store into *DRESULT the number of
1524 seconds since the start of the POSIX Epoch.
1526 Return true if successful. */
1528 decode_time_components (Lisp_Object high
, Lisp_Object low
, Lisp_Object usec
,
1530 struct timespec
*result
, double *dresult
)
1532 EMACS_INT hi
, lo
, us
, ps
;
1533 if (! (INTEGERP (high
) && INTEGERP (low
)
1534 && INTEGERP (usec
) && INTEGERP (psec
)))
1541 /* Normalize out-of-range lower-order components by carrying
1542 each overflow into the next higher-order component. */
1543 us
+= ps
/ 1000000 - (ps
% 1000000 < 0);
1544 lo
+= us
/ 1000000 - (us
% 1000000 < 0);
1546 ps
= ps
% 1000000 + 1000000 * (ps
% 1000000 < 0);
1547 us
= us
% 1000000 + 1000000 * (us
% 1000000 < 0);
1548 lo
&= (1 << 16) - 1;
1552 if ((TYPE_SIGNED (time_t) ? TIME_T_MIN
>> 16 <= hi
: 0 <= hi
)
1553 && hi
<= TIME_T_MAX
>> 16)
1555 /* Return the greatest representable time that is not greater
1556 than the requested time. */
1558 *result
= make_timespec ((sec
<< 16) + lo
, us
* 1000 + ps
/ 1000);
1562 /* Overflow in the highest-order component. */
1568 *dresult
= (us
* 1e6
+ ps
) / 1e12
+ lo
+ hi
* 65536.0;
1573 /* Decode a Lisp list SPECIFIED_TIME that represents a time.
1574 If SPECIFIED_TIME is nil, use the current time.
1576 Round the time down to the nearest struct timespec value.
1577 Return seconds since the Epoch.
1578 Signal an error if unsuccessful. */
1580 lisp_time_argument (Lisp_Object specified_time
)
1583 if (NILP (specified_time
))
1584 t
= current_timespec ();
1587 Lisp_Object high
, low
, usec
, psec
;
1588 if (! (disassemble_lisp_time (specified_time
, &high
, &low
, &usec
, &psec
)
1589 && decode_time_components (high
, low
, usec
, psec
, &t
, 0)))
1590 error ("Invalid time specification");
1595 /* Like lisp_time_argument, except decode only the seconds part,
1596 do not allow out-of-range time stamps, do not check the subseconds part,
1597 and always round down. */
1599 lisp_seconds_argument (Lisp_Object specified_time
)
1601 if (NILP (specified_time
))
1605 Lisp_Object high
, low
, usec
, psec
;
1607 if (! (disassemble_lisp_time (specified_time
, &high
, &low
, &usec
, &psec
)
1608 && decode_time_components (high
, low
, make_number (0),
1609 make_number (0), &t
, 0)))
1610 error ("Invalid time specification");
1615 DEFUN ("float-time", Ffloat_time
, Sfloat_time
, 0, 1, 0,
1616 doc
: /* Return the current time, as a float number of seconds since the epoch.
1617 If SPECIFIED-TIME is given, it is the time to convert to float
1618 instead of the current time. The argument should have the form
1619 (HIGH LOW) or (HIGH LOW USEC) or (HIGH LOW USEC PSEC). Thus,
1620 you can use times from `current-time' and from `file-attributes'.
1621 SPECIFIED-TIME can also have the form (HIGH . LOW), but this is
1622 considered obsolete.
1624 WARNING: Since the result is floating point, it may not be exact.
1625 If precise time stamps are required, use either `current-time',
1626 or (if you need time as a string) `format-time-string'. */)
1627 (Lisp_Object specified_time
)
1630 if (NILP (specified_time
))
1632 struct timespec now
= current_timespec ();
1633 t
= now
.tv_sec
+ now
.tv_nsec
/ 1e9
;
1637 Lisp_Object high
, low
, usec
, psec
;
1638 if (! (disassemble_lisp_time (specified_time
, &high
, &low
, &usec
, &psec
)
1639 && decode_time_components (high
, low
, usec
, psec
, 0, &t
)))
1640 error ("Invalid time specification");
1642 return make_float (t
);
1645 /* Write information into buffer S of size MAXSIZE, according to the
1646 FORMAT of length FORMAT_LEN, using time information taken from *TP.
1647 Default to Universal Time if UT, local time otherwise.
1648 Use NS as the number of nanoseconds in the %N directive.
1649 Return the number of bytes written, not including the terminating
1650 '\0'. If S is NULL, nothing will be written anywhere; so to
1651 determine how many bytes would be written, use NULL for S and
1652 ((size_t) -1) for MAXSIZE.
1654 This function behaves like nstrftime, except it allows null
1655 bytes in FORMAT and it does not support nanoseconds. */
1657 emacs_nmemftime (char *s
, size_t maxsize
, const char *format
,
1658 size_t format_len
, const struct tm
*tp
, bool ut
, int ns
)
1662 /* Loop through all the null-terminated strings in the format
1663 argument. Normally there's just one null-terminated string, but
1664 there can be arbitrarily many, concatenated together, if the
1665 format contains '\0' bytes. nstrftime stops at the first
1666 '\0' byte so we must invoke it separately for each such string. */
1675 result
= nstrftime (s
, maxsize
, format
, tp
, ut
, ns
);
1679 if (result
== 0 && s
[0] != '\0')
1684 maxsize
-= result
+ 1;
1686 len
= strlen (format
);
1687 if (len
== format_len
)
1691 format_len
-= len
+ 1;
1695 DEFUN ("format-time-string", Fformat_time_string
, Sformat_time_string
, 1, 3, 0,
1696 doc
: /* Use FORMAT-STRING to format the time TIME, or now if omitted.
1697 TIME is specified as (HIGH LOW USEC PSEC), as returned by
1698 `current-time' or `file-attributes'. The obsolete form (HIGH . LOW)
1699 is also still accepted.
1700 The third, optional, argument UNIVERSAL, if non-nil, means describe TIME
1701 as Universal Time; nil means describe TIME in the local time zone.
1702 The value is a copy of FORMAT-STRING, but with certain constructs replaced
1703 by text that describes the specified date and time in TIME:
1705 %Y is the year, %y within the century, %C the century.
1706 %G is the year corresponding to the ISO week, %g within the century.
1707 %m is the numeric month.
1708 %b and %h are the locale's abbreviated month name, %B the full name.
1709 (%h is not supported on MS-Windows.)
1710 %d is the day of the month, zero-padded, %e is blank-padded.
1711 %u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.
1712 %a is the locale's abbreviated name of the day of week, %A the full name.
1713 %U is the week number starting on Sunday, %W starting on Monday,
1714 %V according to ISO 8601.
1715 %j is the day of the year.
1717 %H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H
1718 only blank-padded, %l is like %I blank-padded.
1719 %p is the locale's equivalent of either AM or PM.
1722 %N is the nanosecond, %6N the microsecond, %3N the millisecond, etc.
1723 %Z is the time zone name, %z is the numeric form.
1724 %s is the number of seconds since 1970-01-01 00:00:00 +0000.
1726 %c is the locale's date and time format.
1727 %x is the locale's "preferred" date format.
1728 %D is like "%m/%d/%y".
1729 %F is the ISO 8601 date format (like "%Y-%m-%d").
1731 %R is like "%H:%M", %T is like "%H:%M:%S", %r is like "%I:%M:%S %p".
1732 %X is the locale's "preferred" time format.
1734 Finally, %n is a newline, %t is a tab, %% is a literal %.
1736 Certain flags and modifiers are available with some format controls.
1737 The flags are `_', `-', `^' and `#'. For certain characters X,
1738 %_X is like %X, but padded with blanks; %-X is like %X,
1739 but without padding. %^X is like %X, but with all textual
1740 characters up-cased; %#X is like %X, but with letter-case of
1741 all textual characters reversed.
1742 %NX (where N stands for an integer) is like %X,
1743 but takes up at least N (a number) positions.
1744 The modifiers are `E' and `O'. For certain characters X,
1745 %EX is a locale's alternative version of %X;
1746 %OX is like %X, but uses the locale's number symbols.
1748 For example, to produce full ISO 8601 format, use "%FT%T%z".
1750 usage: (format-time-string FORMAT-STRING &optional TIME UNIVERSAL) */)
1751 (Lisp_Object format_string
, Lisp_Object timeval
, Lisp_Object universal
)
1753 struct timespec t
= lisp_time_argument (timeval
);
1756 CHECK_STRING (format_string
);
1757 format_string
= code_convert_string_norecord (format_string
,
1758 Vlocale_coding_system
, 1);
1759 return format_time_string (SSDATA (format_string
), SBYTES (format_string
),
1760 t
, ! NILP (universal
), &tm
);
1764 format_time_string (char const *format
, ptrdiff_t formatlen
,
1765 struct timespec t
, bool ut
, struct tm
*tmp
)
1769 ptrdiff_t size
= sizeof buffer
;
1771 Lisp_Object bufstring
;
1778 time_t *taddr
= &t
.tv_sec
;
1781 synchronize_system_time_locale ();
1783 tm
= ut
? gmtime (taddr
) : localtime (taddr
);
1792 len
= emacs_nmemftime (buf
, size
, format
, formatlen
, tm
, ut
, ns
);
1793 if ((0 < len
&& len
< size
) || (len
== 0 && buf
[0] == '\0'))
1796 /* Buffer was too small, so make it bigger and try again. */
1797 len
= emacs_nmemftime (NULL
, SIZE_MAX
, format
, formatlen
, tm
, ut
, ns
);
1799 if (STRING_BYTES_BOUND
<= len
)
1802 buf
= SAFE_ALLOCA (size
);
1806 bufstring
= make_unibyte_string (buf
, len
);
1808 return code_convert_string_norecord (bufstring
, Vlocale_coding_system
, 0);
1811 DEFUN ("decode-time", Fdecode_time
, Sdecode_time
, 0, 1, 0,
1812 doc
: /* Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST ZONE).
1813 The optional SPECIFIED-TIME should be a list of (HIGH LOW . IGNORED),
1814 as from `current-time' and `file-attributes', or nil to use the
1815 current time. The obsolete form (HIGH . LOW) is also still accepted.
1816 The list has the following nine members: SEC is an integer between 0
1817 and 60; SEC is 60 for a leap second, which only some operating systems
1818 support. MINUTE is an integer between 0 and 59. HOUR is an integer
1819 between 0 and 23. DAY is an integer between 1 and 31. MONTH is an
1820 integer between 1 and 12. YEAR is an integer indicating the
1821 four-digit year. DOW is the day of week, an integer between 0 and 6,
1822 where 0 is Sunday. DST is t if daylight saving time is in effect,
1823 otherwise nil. ZONE is an integer indicating the number of seconds
1824 east of Greenwich. (Note that Common Lisp has different meanings for
1826 (Lisp_Object specified_time
)
1828 time_t time_spec
= lisp_seconds_argument (specified_time
);
1830 struct tm
*decoded_time
;
1831 Lisp_Object list_args
[9];
1834 decoded_time
= localtime (&time_spec
);
1836 save_tm
= *decoded_time
;
1839 && MOST_NEGATIVE_FIXNUM
- TM_YEAR_BASE
<= save_tm
.tm_year
1840 && save_tm
.tm_year
<= MOST_POSITIVE_FIXNUM
- TM_YEAR_BASE
))
1842 XSETFASTINT (list_args
[0], save_tm
.tm_sec
);
1843 XSETFASTINT (list_args
[1], save_tm
.tm_min
);
1844 XSETFASTINT (list_args
[2], save_tm
.tm_hour
);
1845 XSETFASTINT (list_args
[3], save_tm
.tm_mday
);
1846 XSETFASTINT (list_args
[4], save_tm
.tm_mon
+ 1);
1847 /* On 64-bit machines an int is narrower than EMACS_INT, thus the
1848 cast below avoids overflow in int arithmetics. */
1849 XSETINT (list_args
[5], TM_YEAR_BASE
+ (EMACS_INT
) save_tm
.tm_year
);
1850 XSETFASTINT (list_args
[6], save_tm
.tm_wday
);
1851 list_args
[7] = save_tm
.tm_isdst
? Qt
: Qnil
;
1854 decoded_time
= gmtime (&time_spec
);
1855 if (decoded_time
== 0)
1856 list_args
[8] = Qnil
;
1858 XSETINT (list_args
[8], tm_diff (&save_tm
, decoded_time
));
1860 return Flist (9, list_args
);
1863 /* Return OBJ - OFFSET, checking that OBJ is a valid fixnum and that
1864 the result is representable as an int. Assume OFFSET is small and
1867 check_tm_member (Lisp_Object obj
, int offset
)
1872 if (! (INT_MIN
+ offset
<= n
&& n
- offset
<= INT_MAX
))
1877 DEFUN ("encode-time", Fencode_time
, Sencode_time
, 6, MANY
, 0,
1878 doc
: /* Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.
1879 This is the reverse operation of `decode-time', which see.
1880 ZONE defaults to the current time zone rule. This can
1881 be a string or t (as from `set-time-zone-rule'), or it can be a list
1882 \(as from `current-time-zone') or an integer (as from `decode-time')
1883 applied without consideration for daylight saving time.
1885 You can pass more than 7 arguments; then the first six arguments
1886 are used as SECOND through YEAR, and the *last* argument is used as ZONE.
1887 The intervening arguments are ignored.
1888 This feature lets (apply 'encode-time (decode-time ...)) work.
1890 Out-of-range values for SECOND, MINUTE, HOUR, DAY, or MONTH are allowed;
1891 for example, a DAY of 0 means the day preceding the given month.
1892 Year numbers less than 100 are treated just like other year numbers.
1893 If you want them to stand for years in this century, you must do that yourself.
1895 Years before 1970 are not guaranteed to work. On some systems,
1896 year values as low as 1901 do work.
1898 usage: (encode-time SECOND MINUTE HOUR DAY MONTH YEAR &optional ZONE) */)
1899 (ptrdiff_t nargs
, Lisp_Object
*args
)
1903 Lisp_Object zone
= (nargs
> 6 ? args
[nargs
- 1] : Qnil
);
1905 tm
.tm_sec
= check_tm_member (args
[0], 0);
1906 tm
.tm_min
= check_tm_member (args
[1], 0);
1907 tm
.tm_hour
= check_tm_member (args
[2], 0);
1908 tm
.tm_mday
= check_tm_member (args
[3], 0);
1909 tm
.tm_mon
= check_tm_member (args
[4], 1);
1910 tm
.tm_year
= check_tm_member (args
[5], TM_YEAR_BASE
);
1918 value
= mktime (&tm
);
1923 static char const tzbuf_format
[] = "XXX%s%"pI
"d:%02d:%02d";
1924 char tzbuf
[sizeof tzbuf_format
+ INT_STRLEN_BOUND (EMACS_INT
)];
1926 const char *tzstring
;
1931 else if (STRINGP (zone
))
1932 tzstring
= SSDATA (zone
);
1933 else if (INTEGERP (zone
))
1935 EMACS_INT abszone
= eabs (XINT (zone
));
1936 EMACS_INT zone_hr
= abszone
/ (60*60);
1937 int zone_min
= (abszone
/60) % 60;
1938 int zone_sec
= abszone
% 60;
1939 sprintf (tzbuf
, tzbuf_format
, &"-"[XINT (zone
) < 0],
1940 zone_hr
, zone_min
, zone_sec
);
1944 error ("Invalid time zone specification");
1946 old_tzstring
= getenv ("TZ");
1949 char *buf
= SAFE_ALLOCA (strlen (old_tzstring
) + 1);
1950 old_tzstring
= strcpy (buf
, old_tzstring
);
1955 /* Set TZ before calling mktime; merely adjusting mktime's returned
1956 value doesn't suffice, since that would mishandle leap seconds. */
1957 set_time_zone_rule (tzstring
);
1959 value
= mktime (&tm
);
1961 set_time_zone_rule (old_tzstring
);
1962 #ifdef LOCALTIME_CACHE
1969 if (value
== (time_t) -1)
1972 return make_time (value
);
1975 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
, 0, 1, 0,
1976 doc
: /* Return the current local time, as a human-readable string.
1977 Programs can use this function to decode a time,
1978 since the number of columns in each field is fixed
1979 if the year is in the range 1000-9999.
1980 The format is `Sun Sep 16 01:03:52 1973'.
1981 However, see also the functions `decode-time' and `format-time-string'
1982 which provide a much more powerful and general facility.
1984 If SPECIFIED-TIME is given, it is a time to format instead of the
1985 current time. The argument should have the form (HIGH LOW . IGNORED).
1986 Thus, you can use times obtained from `current-time' and from
1987 `file-attributes'. SPECIFIED-TIME can also have the form (HIGH . LOW),
1988 but this is considered obsolete. */)
1989 (Lisp_Object specified_time
)
1991 time_t value
= lisp_seconds_argument (specified_time
);
1993 char buf
[sizeof "Mon Apr 30 12:49:17 " + INT_STRLEN_BOUND (int) + 1];
1994 int len
IF_LINT (= 0);
1996 /* Convert to a string in ctime format, except without the trailing
1997 newline, and without the 4-digit year limit. Don't use asctime
1998 or ctime, as they might dump core if the year is outside the
1999 range -999 .. 9999. */
2001 tm
= localtime (&value
);
2004 static char const wday_name
[][4] =
2005 { "Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat" };
2006 static char const mon_name
[][4] =
2007 { "Jan", "Feb", "Mar", "Apr", "May", "Jun",
2008 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" };
2009 printmax_t year_base
= TM_YEAR_BASE
;
2011 len
= sprintf (buf
, "%s %s%3d %02d:%02d:%02d %"pMd
,
2012 wday_name
[tm
->tm_wday
], mon_name
[tm
->tm_mon
], tm
->tm_mday
,
2013 tm
->tm_hour
, tm
->tm_min
, tm
->tm_sec
,
2014 tm
->tm_year
+ year_base
);
2020 return make_unibyte_string (buf
, len
);
2023 /* Yield A - B, measured in seconds.
2024 This function is copied from the GNU C Library. */
2026 tm_diff (struct tm
*a
, struct tm
*b
)
2028 /* Compute intervening leap days correctly even if year is negative.
2029 Take care to avoid int overflow in leap day calculations,
2030 but it's OK to assume that A and B are close to each other. */
2031 int a4
= (a
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (a
->tm_year
& 3);
2032 int b4
= (b
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (b
->tm_year
& 3);
2033 int a100
= a4
/ 25 - (a4
% 25 < 0);
2034 int b100
= b4
/ 25 - (b4
% 25 < 0);
2035 int a400
= a100
>> 2;
2036 int b400
= b100
>> 2;
2037 int intervening_leap_days
= (a4
- b4
) - (a100
- b100
) + (a400
- b400
);
2038 int years
= a
->tm_year
- b
->tm_year
;
2039 int days
= (365 * years
+ intervening_leap_days
2040 + (a
->tm_yday
- b
->tm_yday
));
2041 return (60 * (60 * (24 * days
+ (a
->tm_hour
- b
->tm_hour
))
2042 + (a
->tm_min
- b
->tm_min
))
2043 + (a
->tm_sec
- b
->tm_sec
));
2046 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 1, 0,
2047 doc
: /* Return the offset and name for the local time zone.
2048 This returns a list of the form (OFFSET NAME).
2049 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).
2050 A negative value means west of Greenwich.
2051 NAME is a string giving the name of the time zone.
2052 If SPECIFIED-TIME is given, the time zone offset is determined from it
2053 instead of using the current time. The argument should have the form
2054 (HIGH LOW . IGNORED). Thus, you can use times obtained from
2055 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
2056 have the form (HIGH . LOW), but this is considered obsolete.
2058 Some operating systems cannot provide all this information to Emacs;
2059 in this case, `current-time-zone' returns a list containing nil for
2060 the data it can't find. */)
2061 (Lisp_Object specified_time
)
2063 struct timespec value
;
2067 Lisp_Object zone_offset
, zone_name
;
2070 value
= make_timespec (lisp_seconds_argument (specified_time
), 0);
2071 zone_name
= format_time_string ("%Z", sizeof "%Z" - 1, value
, 0, &localtm
);
2073 t
= gmtime (&value
.tv_sec
);
2075 offset
= tm_diff (&localtm
, t
);
2080 zone_offset
= make_number (offset
);
2081 if (SCHARS (zone_name
) == 0)
2083 /* No local time zone name is available; use "+-NNNN" instead. */
2084 int m
= offset
/ 60;
2085 int am
= offset
< 0 ? - m
: m
;
2086 char buf
[sizeof "+00" + INT_STRLEN_BOUND (int)];
2087 zone_name
= make_formatted_string (buf
, "%c%02d%02d",
2088 (offset
< 0 ? '-' : '+'),
2093 return list2 (zone_offset
, zone_name
);
2096 DEFUN ("set-time-zone-rule", Fset_time_zone_rule
, Sset_time_zone_rule
, 1, 1, 0,
2097 doc
: /* Set the local time zone using TZ, a string specifying a time zone rule.
2098 If TZ is nil, use implementation-defined default time zone information.
2099 If TZ is t, use Universal Time.
2101 Instead of calling this function, you typically want (setenv "TZ" TZ).
2102 That changes both the environment of the Emacs process and the
2103 variable `process-environment', whereas `set-time-zone-rule' affects
2104 only the former. */)
2107 const char *tzstring
;
2109 if (! (NILP (tz
) || EQ (tz
, Qt
)))
2113 tzstring
= initial_tz
;
2114 else if (EQ (tz
, Qt
))
2117 tzstring
= SSDATA (tz
);
2120 set_time_zone_rule (tzstring
);
2126 /* Set the local time zone rule to TZSTRING.
2128 This function is not thread-safe, partly because putenv, unsetenv
2129 and tzset are not, and partly because of the static storage it
2130 updates. Other threads that invoke localtime etc. may be adversely
2131 affected while this function is executing. */
2134 set_time_zone_rule (const char *tzstring
)
2136 /* A buffer holding a string of the form "TZ=value", intended
2137 to be part of the environment. */
2138 static char *tzvalbuf
;
2139 static ptrdiff_t tzvalbufsize
;
2141 int tzeqlen
= sizeof "TZ=" - 1;
2143 #ifdef LOCALTIME_CACHE
2144 /* These two values are known to load tz files in buggy implementations,
2145 i.e., Solaris 1 executables running under either Solaris 1 or Solaris 2.
2146 Their values shouldn't matter in non-buggy implementations.
2147 We don't use string literals for these strings,
2148 since if a string in the environment is in readonly
2149 storage, it runs afoul of bugs in SVR4 and Solaris 2.3.
2150 See Sun bugs 1113095 and 1114114, ``Timezone routines
2151 improperly modify environment''. */
2153 static char set_time_zone_rule_tz
[][sizeof "TZ=GMT+0"]
2154 = { "TZ=GMT+0", "TZ=GMT+1" };
2156 /* In SunOS 4.1.3_U1 and 4.1.4, if TZ has a value like
2157 "US/Pacific" that loads a tz file, then changes to a value like
2158 "XXX0" that does not load a tz file, and then changes back to
2159 its original value, the last change is (incorrectly) ignored.
2160 Also, if TZ changes twice in succession to values that do
2161 not load a tz file, tzset can dump core (see Sun bug#1225179).
2162 The following code works around these bugs. */
2166 /* Temporarily set TZ to a value that loads a tz file
2167 and that differs from tzstring. */
2168 bool eq0
= strcmp (tzstring
, set_time_zone_rule_tz
[0] + tzeqlen
) == 0;
2169 xputenv (set_time_zone_rule_tz
[eq0
]);
2173 /* The implied tzstring is unknown, so temporarily set TZ to
2174 two different values that each load a tz file. */
2175 xputenv (set_time_zone_rule_tz
[0]);
2177 xputenv (set_time_zone_rule_tz
[1]);
2180 tzvalbuf_in_environ
= 0;
2186 tzvalbuf_in_environ
= 0;
2190 ptrdiff_t tzstringlen
= strlen (tzstring
);
2192 if (tzvalbufsize
<= tzeqlen
+ tzstringlen
)
2195 tzvalbuf_in_environ
= 0;
2196 tzvalbuf
= xpalloc (tzvalbuf
, &tzvalbufsize
,
2197 tzeqlen
+ tzstringlen
- tzvalbufsize
+ 1, -1, 1);
2198 memcpy (tzvalbuf
, "TZ=", tzeqlen
);
2201 strcpy (tzvalbuf
+ tzeqlen
, tzstring
);
2203 if (!tzvalbuf_in_environ
)
2206 tzvalbuf_in_environ
= 1;
2210 #ifdef LOCALTIME_CACHE
2215 /* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC
2216 (if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a
2217 type of object is Lisp_String). INHERIT is passed to
2218 INSERT_FROM_STRING_FUNC as the last argument. */
2221 general_insert_function (void (*insert_func
)
2222 (const char *, ptrdiff_t),
2223 void (*insert_from_string_func
)
2224 (Lisp_Object
, ptrdiff_t, ptrdiff_t,
2225 ptrdiff_t, ptrdiff_t, bool),
2226 bool inherit
, ptrdiff_t nargs
, Lisp_Object
*args
)
2231 for (argnum
= 0; argnum
< nargs
; argnum
++)
2234 if (CHARACTERP (val
))
2236 int c
= XFASTINT (val
);
2237 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2240 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2241 len
= CHAR_STRING (c
, str
);
2244 str
[0] = CHAR_TO_BYTE8 (c
);
2247 (*insert_func
) ((char *) str
, len
);
2249 else if (STRINGP (val
))
2251 (*insert_from_string_func
) (val
, 0, 0,
2257 wrong_type_argument (Qchar_or_string_p
, val
);
2262 insert1 (Lisp_Object arg
)
2268 /* Callers passing one argument to Finsert need not gcpro the
2269 argument "array", since the only element of the array will
2270 not be used after calling insert or insert_from_string, so
2271 we don't care if it gets trashed. */
2273 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
2274 doc
: /* Insert the arguments, either strings or characters, at point.
2275 Point and before-insertion markers move forward to end up
2276 after the inserted text.
2277 Any other markers at the point of insertion remain before the text.
2279 If the current buffer is multibyte, unibyte strings are converted
2280 to multibyte for insertion (see `string-make-multibyte').
2281 If the current buffer is unibyte, multibyte strings are converted
2282 to unibyte for insertion (see `string-make-unibyte').
2284 When operating on binary data, it may be necessary to preserve the
2285 original bytes of a unibyte string when inserting it into a multibyte
2286 buffer; to accomplish this, apply `string-as-multibyte' to the string
2287 and insert the result.
2289 usage: (insert &rest ARGS) */)
2290 (ptrdiff_t nargs
, Lisp_Object
*args
)
2292 general_insert_function (insert
, insert_from_string
, 0, nargs
, args
);
2296 DEFUN ("insert-and-inherit", Finsert_and_inherit
, Sinsert_and_inherit
,
2298 doc
: /* Insert the arguments at point, inheriting properties from adjoining text.
2299 Point and before-insertion markers move forward to end up
2300 after the inserted text.
2301 Any other markers at the point of insertion remain before the text.
2303 If the current buffer is multibyte, unibyte strings are converted
2304 to multibyte for insertion (see `unibyte-char-to-multibyte').
2305 If the current buffer is unibyte, multibyte strings are converted
2306 to unibyte for insertion.
2308 usage: (insert-and-inherit &rest ARGS) */)
2309 (ptrdiff_t nargs
, Lisp_Object
*args
)
2311 general_insert_function (insert_and_inherit
, insert_from_string
, 1,
2316 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
2317 doc
: /* Insert strings or characters at point, relocating markers after the text.
2318 Point and markers move forward to end up after the inserted text.
2320 If the current buffer is multibyte, unibyte strings are converted
2321 to multibyte for insertion (see `unibyte-char-to-multibyte').
2322 If the current buffer is unibyte, multibyte strings are converted
2323 to unibyte for insertion.
2325 If an overlay begins at the insertion point, the inserted text falls
2326 outside the overlay; if a nonempty overlay ends at the insertion
2327 point, the inserted text falls inside that overlay.
2329 usage: (insert-before-markers &rest ARGS) */)
2330 (ptrdiff_t nargs
, Lisp_Object
*args
)
2332 general_insert_function (insert_before_markers
,
2333 insert_from_string_before_markers
, 0,
2338 DEFUN ("insert-before-markers-and-inherit", Finsert_and_inherit_before_markers
,
2339 Sinsert_and_inherit_before_markers
, 0, MANY
, 0,
2340 doc
: /* Insert text at point, relocating markers and inheriting properties.
2341 Point and markers move forward to end up after the inserted text.
2343 If the current buffer is multibyte, unibyte strings are converted
2344 to multibyte for insertion (see `unibyte-char-to-multibyte').
2345 If the current buffer is unibyte, multibyte strings are converted
2346 to unibyte for insertion.
2348 usage: (insert-before-markers-and-inherit &rest ARGS) */)
2349 (ptrdiff_t nargs
, Lisp_Object
*args
)
2351 general_insert_function (insert_before_markers_and_inherit
,
2352 insert_from_string_before_markers
, 1,
2357 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 1, 3,
2358 "(list (read-char-by-name \"Insert character (Unicode name or hex): \")\
2359 (prefix-numeric-value current-prefix-arg)\
2361 doc
: /* Insert COUNT copies of CHARACTER.
2362 Interactively, prompt for CHARACTER. You can specify CHARACTER in one
2365 - As its Unicode character name, e.g. \"LATIN SMALL LETTER A\".
2366 Completion is available; if you type a substring of the name
2367 preceded by an asterisk `*', Emacs shows all names which include
2368 that substring, not necessarily at the beginning of the name.
2370 - As a hexadecimal code point, e.g. 263A. Note that code points in
2371 Emacs are equivalent to Unicode up to 10FFFF (which is the limit of
2372 the Unicode code space).
2374 - As a code point with a radix specified with #, e.g. #o21430
2375 (octal), #x2318 (hex), or #10r8984 (decimal).
2377 If called interactively, COUNT is given by the prefix argument. If
2378 omitted or nil, it defaults to 1.
2380 Inserting the character(s) relocates point and before-insertion
2381 markers in the same ways as the function `insert'.
2383 The optional third argument INHERIT, if non-nil, says to inherit text
2384 properties from adjoining text, if those properties are sticky. If
2385 called interactively, INHERIT is t. */)
2386 (Lisp_Object character
, Lisp_Object count
, Lisp_Object inherit
)
2389 register ptrdiff_t n
;
2391 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2394 CHECK_CHARACTER (character
);
2396 XSETFASTINT (count
, 1);
2397 CHECK_NUMBER (count
);
2398 c
= XFASTINT (character
);
2400 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2401 len
= CHAR_STRING (c
, str
);
2403 str
[0] = c
, len
= 1;
2404 if (XINT (count
) <= 0)
2406 if (BUF_BYTES_MAX
/ len
< XINT (count
))
2408 n
= XINT (count
) * len
;
2409 stringlen
= min (n
, sizeof string
- sizeof string
% len
);
2410 for (i
= 0; i
< stringlen
; i
++)
2411 string
[i
] = str
[i
% len
];
2412 while (n
> stringlen
)
2415 if (!NILP (inherit
))
2416 insert_and_inherit (string
, stringlen
);
2418 insert (string
, stringlen
);
2421 if (!NILP (inherit
))
2422 insert_and_inherit (string
, n
);
2428 DEFUN ("insert-byte", Finsert_byte
, Sinsert_byte
, 2, 3, 0,
2429 doc
: /* Insert COUNT (second arg) copies of BYTE (first arg).
2430 Both arguments are required.
2431 BYTE is a number of the range 0..255.
2433 If BYTE is 128..255 and the current buffer is multibyte, the
2434 corresponding eight-bit character is inserted.
2436 Point, and before-insertion markers, are relocated as in the function `insert'.
2437 The optional third arg INHERIT, if non-nil, says to inherit text properties
2438 from adjoining text, if those properties are sticky. */)
2439 (Lisp_Object byte
, Lisp_Object count
, Lisp_Object inherit
)
2441 CHECK_NUMBER (byte
);
2442 if (XINT (byte
) < 0 || XINT (byte
) > 255)
2443 args_out_of_range_3 (byte
, make_number (0), make_number (255));
2444 if (XINT (byte
) >= 128
2445 && ! NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2446 XSETFASTINT (byte
, BYTE8_TO_CHAR (XINT (byte
)));
2447 return Finsert_char (byte
, count
, inherit
);
2451 /* Making strings from buffer contents. */
2453 /* Return a Lisp_String containing the text of the current buffer from
2454 START to END. If text properties are in use and the current buffer
2455 has properties in the range specified, the resulting string will also
2456 have them, if PROPS is true.
2458 We don't want to use plain old make_string here, because it calls
2459 make_uninit_string, which can cause the buffer arena to be
2460 compacted. make_string has no way of knowing that the data has
2461 been moved, and thus copies the wrong data into the string. This
2462 doesn't effect most of the other users of make_string, so it should
2463 be left as is. But we should use this function when conjuring
2464 buffer substrings. */
2467 make_buffer_string (ptrdiff_t start
, ptrdiff_t end
, bool props
)
2469 ptrdiff_t start_byte
= CHAR_TO_BYTE (start
);
2470 ptrdiff_t end_byte
= CHAR_TO_BYTE (end
);
2472 return make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
);
2475 /* Return a Lisp_String containing the text of the current buffer from
2476 START / START_BYTE to END / END_BYTE.
2478 If text properties are in use and the current buffer
2479 has properties in the range specified, the resulting string will also
2480 have them, if PROPS is true.
2482 We don't want to use plain old make_string here, because it calls
2483 make_uninit_string, which can cause the buffer arena to be
2484 compacted. make_string has no way of knowing that the data has
2485 been moved, and thus copies the wrong data into the string. This
2486 doesn't effect most of the other users of make_string, so it should
2487 be left as is. But we should use this function when conjuring
2488 buffer substrings. */
2491 make_buffer_string_both (ptrdiff_t start
, ptrdiff_t start_byte
,
2492 ptrdiff_t end
, ptrdiff_t end_byte
, bool props
)
2494 Lisp_Object result
, tem
, tem1
;
2496 if (start
< GPT
&& GPT
< end
)
2497 move_gap_both (start
, start_byte
);
2499 if (! NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2500 result
= make_uninit_multibyte_string (end
- start
, end_byte
- start_byte
);
2502 result
= make_uninit_string (end
- start
);
2503 memcpy (SDATA (result
), BYTE_POS_ADDR (start_byte
), end_byte
- start_byte
);
2505 /* If desired, update and copy the text properties. */
2508 update_buffer_properties (start
, end
);
2510 tem
= Fnext_property_change (make_number (start
), Qnil
, make_number (end
));
2511 tem1
= Ftext_properties_at (make_number (start
), Qnil
);
2513 if (XINT (tem
) != end
|| !NILP (tem1
))
2514 copy_intervals_to_string (result
, current_buffer
, start
,
2521 /* Call Vbuffer_access_fontify_functions for the range START ... END
2522 in the current buffer, if necessary. */
2525 update_buffer_properties (ptrdiff_t start
, ptrdiff_t end
)
2527 /* If this buffer has some access functions,
2528 call them, specifying the range of the buffer being accessed. */
2529 if (!NILP (Vbuffer_access_fontify_functions
))
2531 Lisp_Object args
[3];
2534 args
[0] = Qbuffer_access_fontify_functions
;
2535 XSETINT (args
[1], start
);
2536 XSETINT (args
[2], end
);
2538 /* But don't call them if we can tell that the work
2539 has already been done. */
2540 if (!NILP (Vbuffer_access_fontified_property
))
2542 tem
= Ftext_property_any (args
[1], args
[2],
2543 Vbuffer_access_fontified_property
,
2546 Frun_hook_with_args (3, args
);
2549 Frun_hook_with_args (3, args
);
2553 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
2554 doc
: /* Return the contents of part of the current buffer as a string.
2555 The two arguments START and END are character positions;
2556 they can be in either order.
2557 The string returned is multibyte if the buffer is multibyte.
2559 This function copies the text properties of that part of the buffer
2560 into the result string; if you don't want the text properties,
2561 use `buffer-substring-no-properties' instead. */)
2562 (Lisp_Object start
, Lisp_Object end
)
2564 register ptrdiff_t b
, e
;
2566 validate_region (&start
, &end
);
2570 return make_buffer_string (b
, e
, 1);
2573 DEFUN ("buffer-substring-no-properties", Fbuffer_substring_no_properties
,
2574 Sbuffer_substring_no_properties
, 2, 2, 0,
2575 doc
: /* Return the characters of part of the buffer, without the text properties.
2576 The two arguments START and END are character positions;
2577 they can be in either order. */)
2578 (Lisp_Object start
, Lisp_Object end
)
2580 register ptrdiff_t b
, e
;
2582 validate_region (&start
, &end
);
2586 return make_buffer_string (b
, e
, 0);
2589 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
2590 doc
: /* Return the contents of the current buffer as a string.
2591 If narrowing is in effect, this function returns only the visible part
2595 return make_buffer_string_both (BEGV
, BEGV_BYTE
, ZV
, ZV_BYTE
, 1);
2598 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
2600 doc
: /* Insert before point a substring of the contents of BUFFER.
2601 BUFFER may be a buffer or a buffer name.
2602 Arguments START and END are character positions specifying the substring.
2603 They default to the values of (point-min) and (point-max) in BUFFER. */)
2604 (Lisp_Object buffer
, Lisp_Object start
, Lisp_Object end
)
2606 register EMACS_INT b
, e
, temp
;
2607 register struct buffer
*bp
, *obuf
;
2610 buf
= Fget_buffer (buffer
);
2614 if (!BUFFER_LIVE_P (bp
))
2615 error ("Selecting deleted buffer");
2621 CHECK_NUMBER_COERCE_MARKER (start
);
2628 CHECK_NUMBER_COERCE_MARKER (end
);
2633 temp
= b
, b
= e
, e
= temp
;
2635 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
2636 args_out_of_range (start
, end
);
2638 obuf
= current_buffer
;
2639 set_buffer_internal_1 (bp
);
2640 update_buffer_properties (b
, e
);
2641 set_buffer_internal_1 (obuf
);
2643 insert_from_buffer (bp
, b
, e
- b
, 0);
2647 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
2649 doc
: /* Compare two substrings of two buffers; return result as number.
2650 Return -N if first string is less after N-1 chars, +N if first string is
2651 greater after N-1 chars, or 0 if strings match. Each substring is
2652 represented as three arguments: BUFFER, START and END. That makes six
2653 args in all, three for each substring.
2655 The value of `case-fold-search' in the current buffer
2656 determines whether case is significant or ignored. */)
2657 (Lisp_Object buffer1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object buffer2
, Lisp_Object start2
, Lisp_Object end2
)
2659 register EMACS_INT begp1
, endp1
, begp2
, endp2
, temp
;
2660 register struct buffer
*bp1
, *bp2
;
2661 register Lisp_Object trt
2662 = (!NILP (BVAR (current_buffer
, case_fold_search
))
2663 ? BVAR (current_buffer
, case_canon_table
) : Qnil
);
2664 ptrdiff_t chars
= 0;
2665 ptrdiff_t i1
, i2
, i1_byte
, i2_byte
;
2667 /* Find the first buffer and its substring. */
2670 bp1
= current_buffer
;
2674 buf1
= Fget_buffer (buffer1
);
2677 bp1
= XBUFFER (buf1
);
2678 if (!BUFFER_LIVE_P (bp1
))
2679 error ("Selecting deleted buffer");
2683 begp1
= BUF_BEGV (bp1
);
2686 CHECK_NUMBER_COERCE_MARKER (start1
);
2687 begp1
= XINT (start1
);
2690 endp1
= BUF_ZV (bp1
);
2693 CHECK_NUMBER_COERCE_MARKER (end1
);
2694 endp1
= XINT (end1
);
2698 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
2700 if (!(BUF_BEGV (bp1
) <= begp1
2702 && endp1
<= BUF_ZV (bp1
)))
2703 args_out_of_range (start1
, end1
);
2705 /* Likewise for second substring. */
2708 bp2
= current_buffer
;
2712 buf2
= Fget_buffer (buffer2
);
2715 bp2
= XBUFFER (buf2
);
2716 if (!BUFFER_LIVE_P (bp2
))
2717 error ("Selecting deleted buffer");
2721 begp2
= BUF_BEGV (bp2
);
2724 CHECK_NUMBER_COERCE_MARKER (start2
);
2725 begp2
= XINT (start2
);
2728 endp2
= BUF_ZV (bp2
);
2731 CHECK_NUMBER_COERCE_MARKER (end2
);
2732 endp2
= XINT (end2
);
2736 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
2738 if (!(BUF_BEGV (bp2
) <= begp2
2740 && endp2
<= BUF_ZV (bp2
)))
2741 args_out_of_range (start2
, end2
);
2745 i1_byte
= buf_charpos_to_bytepos (bp1
, i1
);
2746 i2_byte
= buf_charpos_to_bytepos (bp2
, i2
);
2748 while (i1
< endp1
&& i2
< endp2
)
2750 /* When we find a mismatch, we must compare the
2751 characters, not just the bytes. */
2756 if (! NILP (BVAR (bp1
, enable_multibyte_characters
)))
2758 c1
= BUF_FETCH_MULTIBYTE_CHAR (bp1
, i1_byte
);
2759 BUF_INC_POS (bp1
, i1_byte
);
2764 c1
= BUF_FETCH_BYTE (bp1
, i1
);
2765 MAKE_CHAR_MULTIBYTE (c1
);
2769 if (! NILP (BVAR (bp2
, enable_multibyte_characters
)))
2771 c2
= BUF_FETCH_MULTIBYTE_CHAR (bp2
, i2_byte
);
2772 BUF_INC_POS (bp2
, i2_byte
);
2777 c2
= BUF_FETCH_BYTE (bp2
, i2
);
2778 MAKE_CHAR_MULTIBYTE (c2
);
2784 c1
= char_table_translate (trt
, c1
);
2785 c2
= char_table_translate (trt
, c2
);
2788 return make_number (- 1 - chars
);
2790 return make_number (chars
+ 1);
2795 /* The strings match as far as they go.
2796 If one is shorter, that one is less. */
2797 if (chars
< endp1
- begp1
)
2798 return make_number (chars
+ 1);
2799 else if (chars
< endp2
- begp2
)
2800 return make_number (- chars
- 1);
2802 /* Same length too => they are equal. */
2803 return make_number (0);
2807 subst_char_in_region_unwind (Lisp_Object arg
)
2809 bset_undo_list (current_buffer
, arg
);
2813 subst_char_in_region_unwind_1 (Lisp_Object arg
)
2815 bset_filename (current_buffer
, arg
);
2818 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
2819 Ssubst_char_in_region
, 4, 5, 0,
2820 doc
: /* From START to END, replace FROMCHAR with TOCHAR each time it occurs.
2821 If optional arg NOUNDO is non-nil, don't record this change for undo
2822 and don't mark the buffer as really changed.
2823 Both characters must have the same length of multi-byte form. */)
2824 (Lisp_Object start
, Lisp_Object end
, Lisp_Object fromchar
, Lisp_Object tochar
, Lisp_Object noundo
)
2826 register ptrdiff_t pos
, pos_byte
, stop
, i
, len
, end_byte
;
2827 /* Keep track of the first change in the buffer:
2828 if 0 we haven't found it yet.
2829 if < 0 we've found it and we've run the before-change-function.
2830 if > 0 we've actually performed it and the value is its position. */
2831 ptrdiff_t changed
= 0;
2832 unsigned char fromstr
[MAX_MULTIBYTE_LENGTH
], tostr
[MAX_MULTIBYTE_LENGTH
];
2835 #define COMBINING_NO 0
2836 #define COMBINING_BEFORE 1
2837 #define COMBINING_AFTER 2
2838 #define COMBINING_BOTH (COMBINING_BEFORE | COMBINING_AFTER)
2839 int maybe_byte_combining
= COMBINING_NO
;
2840 ptrdiff_t last_changed
= 0;
2842 = !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
2847 validate_region (&start
, &end
);
2848 CHECK_CHARACTER (fromchar
);
2849 CHECK_CHARACTER (tochar
);
2850 fromc
= XFASTINT (fromchar
);
2851 toc
= XFASTINT (tochar
);
2855 len
= CHAR_STRING (fromc
, fromstr
);
2856 if (CHAR_STRING (toc
, tostr
) != len
)
2857 error ("Characters in `subst-char-in-region' have different byte-lengths");
2858 if (!ASCII_CHAR_P (*tostr
))
2860 /* If *TOSTR is in the range 0x80..0x9F and TOCHAR is not a
2861 complete multibyte character, it may be combined with the
2862 after bytes. If it is in the range 0xA0..0xFF, it may be
2863 combined with the before and after bytes. */
2864 if (!CHAR_HEAD_P (*tostr
))
2865 maybe_byte_combining
= COMBINING_BOTH
;
2866 else if (BYTES_BY_CHAR_HEAD (*tostr
) > len
)
2867 maybe_byte_combining
= COMBINING_AFTER
;
2878 pos_byte
= CHAR_TO_BYTE (pos
);
2879 stop
= CHAR_TO_BYTE (XINT (end
));
2882 /* If we don't want undo, turn off putting stuff on the list.
2883 That's faster than getting rid of things,
2884 and it prevents even the entry for a first change.
2885 Also inhibit locking the file. */
2886 if (!changed
&& !NILP (noundo
))
2888 record_unwind_protect (subst_char_in_region_unwind
,
2889 BVAR (current_buffer
, undo_list
));
2890 bset_undo_list (current_buffer
, Qt
);
2891 /* Don't do file-locking. */
2892 record_unwind_protect (subst_char_in_region_unwind_1
,
2893 BVAR (current_buffer
, filename
));
2894 bset_filename (current_buffer
, Qnil
);
2897 if (pos_byte
< GPT_BYTE
)
2898 stop
= min (stop
, GPT_BYTE
);
2901 ptrdiff_t pos_byte_next
= pos_byte
;
2903 if (pos_byte
>= stop
)
2905 if (pos_byte
>= end_byte
) break;
2908 p
= BYTE_POS_ADDR (pos_byte
);
2910 INC_POS (pos_byte_next
);
2913 if (pos_byte_next
- pos_byte
== len
2914 && p
[0] == fromstr
[0]
2916 || (p
[1] == fromstr
[1]
2917 && (len
== 2 || (p
[2] == fromstr
[2]
2918 && (len
== 3 || p
[3] == fromstr
[3]))))))
2921 /* We've already seen this and run the before-change-function;
2922 this time we only need to record the actual position. */
2927 modify_text (pos
, XINT (end
));
2929 if (! NILP (noundo
))
2931 if (MODIFF
- 1 == SAVE_MODIFF
)
2933 if (MODIFF
- 1 == BUF_AUTOSAVE_MODIFF (current_buffer
))
2934 BUF_AUTOSAVE_MODIFF (current_buffer
)++;
2937 /* The before-change-function may have moved the gap
2938 or even modified the buffer so we should start over. */
2942 /* Take care of the case where the new character
2943 combines with neighboring bytes. */
2944 if (maybe_byte_combining
2945 && (maybe_byte_combining
== COMBINING_AFTER
2946 ? (pos_byte_next
< Z_BYTE
2947 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2948 : ((pos_byte_next
< Z_BYTE
2949 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2950 || (pos_byte
> BEG_BYTE
2951 && ! ASCII_CHAR_P (FETCH_BYTE (pos_byte
- 1))))))
2953 Lisp_Object tem
, string
;
2955 struct gcpro gcpro1
;
2957 tem
= BVAR (current_buffer
, undo_list
);
2960 /* Make a multibyte string containing this single character. */
2961 string
= make_multibyte_string ((char *) tostr
, 1, len
);
2962 /* replace_range is less efficient, because it moves the gap,
2963 but it handles combining correctly. */
2964 replace_range (pos
, pos
+ 1, string
,
2966 pos_byte_next
= CHAR_TO_BYTE (pos
);
2967 if (pos_byte_next
> pos_byte
)
2968 /* Before combining happened. We should not increment
2969 POS. So, to cancel the later increment of POS,
2973 INC_POS (pos_byte_next
);
2975 if (! NILP (noundo
))
2976 bset_undo_list (current_buffer
, tem
);
2983 record_change (pos
, 1);
2984 for (i
= 0; i
< len
; i
++) *p
++ = tostr
[i
];
2986 last_changed
= pos
+ 1;
2988 pos_byte
= pos_byte_next
;
2994 signal_after_change (changed
,
2995 last_changed
- changed
, last_changed
- changed
);
2996 update_compositions (changed
, last_changed
, CHECK_ALL
);
3004 static Lisp_Object
check_translation (ptrdiff_t, ptrdiff_t, ptrdiff_t,
3007 /* Helper function for Ftranslate_region_internal.
3009 Check if a character sequence at POS (POS_BYTE) matches an element
3010 of VAL. VAL is a list (([FROM-CHAR ...] . TO) ...). If a matching
3011 element is found, return it. Otherwise return Qnil. */
3014 check_translation (ptrdiff_t pos
, ptrdiff_t pos_byte
, ptrdiff_t end
,
3017 int buf_size
= 16, buf_used
= 0;
3018 int *buf
= alloca (sizeof (int) * buf_size
);
3020 for (; CONSP (val
); val
= XCDR (val
))
3029 if (! VECTORP (elt
))
3032 if (len
<= end
- pos
)
3034 for (i
= 0; i
< len
; i
++)
3038 unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
3041 if (buf_used
== buf_size
)
3046 newbuf
= alloca (sizeof (int) * buf_size
);
3047 memcpy (newbuf
, buf
, sizeof (int) * buf_used
);
3050 buf
[buf_used
++] = STRING_CHAR_AND_LENGTH (p
, len1
);
3053 if (XINT (AREF (elt
, i
)) != buf
[i
])
3064 DEFUN ("translate-region-internal", Ftranslate_region_internal
,
3065 Stranslate_region_internal
, 3, 3, 0,
3066 doc
: /* Internal use only.
3067 From START to END, translate characters according to TABLE.
3068 TABLE is a string or a char-table; the Nth character in it is the
3069 mapping for the character with code N.
3070 It returns the number of characters changed. */)
3071 (Lisp_Object start
, Lisp_Object end
, register Lisp_Object table
)
3073 register unsigned char *tt
; /* Trans table. */
3074 register int nc
; /* New character. */
3075 int cnt
; /* Number of changes made. */
3076 ptrdiff_t size
; /* Size of translate table. */
3077 ptrdiff_t pos
, pos_byte
, end_pos
;
3078 bool multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3079 bool string_multibyte
IF_LINT (= 0);
3081 validate_region (&start
, &end
);
3082 if (CHAR_TABLE_P (table
))
3084 if (! EQ (XCHAR_TABLE (table
)->purpose
, Qtranslation_table
))
3085 error ("Not a translation table");
3091 CHECK_STRING (table
);
3093 if (! multibyte
&& (SCHARS (table
) < SBYTES (table
)))
3094 table
= string_make_unibyte (table
);
3095 string_multibyte
= SCHARS (table
) < SBYTES (table
);
3096 size
= SBYTES (table
);
3101 pos_byte
= CHAR_TO_BYTE (pos
);
3102 end_pos
= XINT (end
);
3103 modify_text (pos
, end_pos
);
3106 for (; pos
< end_pos
; )
3108 register unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
3109 unsigned char *str
, buf
[MAX_MULTIBYTE_LENGTH
];
3115 oc
= STRING_CHAR_AND_LENGTH (p
, len
);
3122 /* Reload as signal_after_change in last iteration may GC. */
3124 if (string_multibyte
)
3126 str
= tt
+ string_char_to_byte (table
, oc
);
3127 nc
= STRING_CHAR_AND_LENGTH (str
, str_len
);
3132 if (! ASCII_CHAR_P (nc
) && multibyte
)
3134 str_len
= BYTE8_STRING (nc
, buf
);
3147 val
= CHAR_TABLE_REF (table
, oc
);
3148 if (CHARACTERP (val
))
3150 nc
= XFASTINT (val
);
3151 str_len
= CHAR_STRING (nc
, buf
);
3154 else if (VECTORP (val
) || (CONSP (val
)))
3156 /* VAL is [TO_CHAR ...] or (([FROM-CHAR ...] . TO) ...)
3157 where TO is TO-CHAR or [TO-CHAR ...]. */
3162 if (nc
!= oc
&& nc
>= 0)
3164 /* Simple one char to one char translation. */
3169 /* This is less efficient, because it moves the gap,
3170 but it should handle multibyte characters correctly. */
3171 string
= make_multibyte_string ((char *) str
, 1, str_len
);
3172 replace_range (pos
, pos
+ 1, string
, 1, 0, 1);
3177 record_change (pos
, 1);
3178 while (str_len
-- > 0)
3180 signal_after_change (pos
, 1, 1);
3181 update_compositions (pos
, pos
+ 1, CHECK_BORDER
);
3191 val
= check_translation (pos
, pos_byte
, end_pos
, val
);
3198 /* VAL is ([FROM-CHAR ...] . TO). */
3199 len
= ASIZE (XCAR (val
));
3207 string
= Fconcat (1, &val
);
3211 string
= Fmake_string (make_number (1), val
);
3213 replace_range (pos
, pos
+ len
, string
, 1, 0, 1);
3214 pos_byte
+= SBYTES (string
);
3215 pos
+= SCHARS (string
);
3216 cnt
+= SCHARS (string
);
3217 end_pos
+= SCHARS (string
) - len
;
3225 return make_number (cnt
);
3228 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
3229 doc
: /* Delete the text between START and END.
3230 If called interactively, delete the region between point and mark.
3231 This command deletes buffer text without modifying the kill ring. */)
3232 (Lisp_Object start
, Lisp_Object end
)
3234 validate_region (&start
, &end
);
3235 del_range (XINT (start
), XINT (end
));
3239 DEFUN ("delete-and-extract-region", Fdelete_and_extract_region
,
3240 Sdelete_and_extract_region
, 2, 2, 0,
3241 doc
: /* Delete the text between START and END and return it. */)
3242 (Lisp_Object start
, Lisp_Object end
)
3244 validate_region (&start
, &end
);
3245 if (XINT (start
) == XINT (end
))
3246 return empty_unibyte_string
;
3247 return del_range_1 (XINT (start
), XINT (end
), 1, 1);
3250 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
3251 doc
: /* Remove restrictions (narrowing) from current buffer.
3252 This allows the buffer's full text to be seen and edited. */)
3255 if (BEG
!= BEGV
|| Z
!= ZV
)
3256 current_buffer
->clip_changed
= 1;
3258 BEGV_BYTE
= BEG_BYTE
;
3259 SET_BUF_ZV_BOTH (current_buffer
, Z
, Z_BYTE
);
3260 /* Changing the buffer bounds invalidates any recorded current column. */
3261 invalidate_current_column ();
3265 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
3266 doc
: /* Restrict editing in this buffer to the current region.
3267 The rest of the text becomes temporarily invisible and untouchable
3268 but is not deleted; if you save the buffer in a file, the invisible
3269 text is included in the file. \\[widen] makes all visible again.
3270 See also `save-restriction'.
3272 When calling from a program, pass two arguments; positions (integers
3273 or markers) bounding the text that should remain visible. */)
3274 (register Lisp_Object start
, Lisp_Object end
)
3276 CHECK_NUMBER_COERCE_MARKER (start
);
3277 CHECK_NUMBER_COERCE_MARKER (end
);
3279 if (XINT (start
) > XINT (end
))
3282 tem
= start
; start
= end
; end
= tem
;
3285 if (!(BEG
<= XINT (start
) && XINT (start
) <= XINT (end
) && XINT (end
) <= Z
))
3286 args_out_of_range (start
, end
);
3288 if (BEGV
!= XFASTINT (start
) || ZV
!= XFASTINT (end
))
3289 current_buffer
->clip_changed
= 1;
3291 SET_BUF_BEGV (current_buffer
, XFASTINT (start
));
3292 SET_BUF_ZV (current_buffer
, XFASTINT (end
));
3293 if (PT
< XFASTINT (start
))
3294 SET_PT (XFASTINT (start
));
3295 if (PT
> XFASTINT (end
))
3296 SET_PT (XFASTINT (end
));
3297 /* Changing the buffer bounds invalidates any recorded current column. */
3298 invalidate_current_column ();
3303 save_restriction_save (void)
3305 if (BEGV
== BEG
&& ZV
== Z
)
3306 /* The common case that the buffer isn't narrowed.
3307 We return just the buffer object, which save_restriction_restore
3308 recognizes as meaning `no restriction'. */
3309 return Fcurrent_buffer ();
3311 /* We have to save a restriction, so return a pair of markers, one
3312 for the beginning and one for the end. */
3314 Lisp_Object beg
, end
;
3316 beg
= build_marker (current_buffer
, BEGV
, BEGV_BYTE
);
3317 end
= build_marker (current_buffer
, ZV
, ZV_BYTE
);
3319 /* END must move forward if text is inserted at its exact location. */
3320 XMARKER (end
)->insertion_type
= 1;
3322 return Fcons (beg
, end
);
3327 save_restriction_restore (Lisp_Object data
)
3329 struct buffer
*cur
= NULL
;
3330 struct buffer
*buf
= (CONSP (data
)
3331 ? XMARKER (XCAR (data
))->buffer
3334 if (buf
&& buf
!= current_buffer
&& !NILP (BVAR (buf
, pt_marker
)))
3335 { /* If `buf' uses markers to keep track of PT, BEGV, and ZV (as
3336 is the case if it is or has an indirect buffer), then make
3337 sure it is current before we update BEGV, so
3338 set_buffer_internal takes care of managing those markers. */
3339 cur
= current_buffer
;
3340 set_buffer_internal (buf
);
3344 /* A pair of marks bounding a saved restriction. */
3346 struct Lisp_Marker
*beg
= XMARKER (XCAR (data
));
3347 struct Lisp_Marker
*end
= XMARKER (XCDR (data
));
3348 eassert (buf
== end
->buffer
);
3350 if (buf
/* Verify marker still points to a buffer. */
3351 && (beg
->charpos
!= BUF_BEGV (buf
) || end
->charpos
!= BUF_ZV (buf
)))
3352 /* The restriction has changed from the saved one, so restore
3353 the saved restriction. */
3355 ptrdiff_t pt
= BUF_PT (buf
);
3357 SET_BUF_BEGV_BOTH (buf
, beg
->charpos
, beg
->bytepos
);
3358 SET_BUF_ZV_BOTH (buf
, end
->charpos
, end
->bytepos
);
3360 if (pt
< beg
->charpos
|| pt
> end
->charpos
)
3361 /* The point is outside the new visible range, move it inside. */
3362 SET_BUF_PT_BOTH (buf
,
3363 clip_to_bounds (beg
->charpos
, pt
, end
->charpos
),
3364 clip_to_bounds (beg
->bytepos
, BUF_PT_BYTE (buf
),
3367 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3371 /* A buffer, which means that there was no old restriction. */
3373 if (buf
/* Verify marker still points to a buffer. */
3374 && (BUF_BEGV (buf
) != BUF_BEG (buf
) || BUF_ZV (buf
) != BUF_Z (buf
)))
3375 /* The buffer has been narrowed, get rid of the narrowing. */
3377 SET_BUF_BEGV_BOTH (buf
, BUF_BEG (buf
), BUF_BEG_BYTE (buf
));
3378 SET_BUF_ZV_BOTH (buf
, BUF_Z (buf
), BUF_Z_BYTE (buf
));
3380 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3384 /* Changing the buffer bounds invalidates any recorded current column. */
3385 invalidate_current_column ();
3388 set_buffer_internal (cur
);
3391 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
3392 doc
: /* Execute BODY, saving and restoring current buffer's restrictions.
3393 The buffer's restrictions make parts of the beginning and end invisible.
3394 \(They are set up with `narrow-to-region' and eliminated with `widen'.)
3395 This special form, `save-restriction', saves the current buffer's restrictions
3396 when it is entered, and restores them when it is exited.
3397 So any `narrow-to-region' within BODY lasts only until the end of the form.
3398 The old restrictions settings are restored
3399 even in case of abnormal exit (throw or error).
3401 The value returned is the value of the last form in BODY.
3403 Note: if you are using both `save-excursion' and `save-restriction',
3404 use `save-excursion' outermost:
3405 (save-excursion (save-restriction ...))
3407 usage: (save-restriction &rest BODY) */)
3410 register Lisp_Object val
;
3413 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
3414 val
= Fprogn (body
);
3419 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
3420 doc
: /* Display a message at the bottom of the screen.
3421 The message also goes into the `*Messages*' buffer, if `message-log-max'
3422 is non-nil. (In keyboard macros, that's all it does.)
3425 In batch mode, the message is printed to the standard error stream,
3426 followed by a newline.
3428 The first argument is a format control string, and the rest are data
3429 to be formatted under control of the string. See `format' for details.
3431 Note: Use (message "%s" VALUE) to print the value of expressions and
3432 variables to avoid accidentally interpreting `%' as format specifiers.
3434 If the first argument is nil or the empty string, the function clears
3435 any existing message; this lets the minibuffer contents show. See
3436 also `current-message'.
3438 usage: (message FORMAT-STRING &rest ARGS) */)
3439 (ptrdiff_t nargs
, Lisp_Object
*args
)
3442 || (STRINGP (args
[0])
3443 && SBYTES (args
[0]) == 0))
3450 register Lisp_Object val
;
3451 val
= Fformat (nargs
, args
);
3457 DEFUN ("message-box", Fmessage_box
, Smessage_box
, 1, MANY
, 0,
3458 doc
: /* Display a message, in a dialog box if possible.
3459 If a dialog box is not available, use the echo area.
3460 The first argument is a format control string, and the rest are data
3461 to be formatted under control of the string. See `format' for details.
3463 If the first argument is nil or the empty string, clear any existing
3464 message; let the minibuffer contents show.
3466 usage: (message-box FORMAT-STRING &rest ARGS) */)
3467 (ptrdiff_t nargs
, Lisp_Object
*args
)
3476 Lisp_Object val
= Fformat (nargs
, args
);
3477 Lisp_Object pane
, menu
;
3478 struct gcpro gcpro1
;
3480 pane
= list1 (Fcons (build_string ("OK"), Qt
));
3482 menu
= Fcons (val
, pane
);
3483 Fx_popup_dialog (Qt
, menu
, Qt
);
3489 DEFUN ("message-or-box", Fmessage_or_box
, Smessage_or_box
, 1, MANY
, 0,
3490 doc
: /* Display a message in a dialog box or in the echo area.
3491 If this command was invoked with the mouse, use a dialog box if
3492 `use-dialog-box' is non-nil.
3493 Otherwise, use the echo area.
3494 The first argument is a format control string, and the rest are data
3495 to be formatted under control of the string. See `format' for details.
3497 If the first argument is nil or the empty string, clear any existing
3498 message; let the minibuffer contents show.
3500 usage: (message-or-box FORMAT-STRING &rest ARGS) */)
3501 (ptrdiff_t nargs
, Lisp_Object
*args
)
3503 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3505 return Fmessage_box (nargs
, args
);
3506 return Fmessage (nargs
, args
);
3509 DEFUN ("current-message", Fcurrent_message
, Scurrent_message
, 0, 0, 0,
3510 doc
: /* Return the string currently displayed in the echo area, or nil if none. */)
3513 return current_message ();
3517 DEFUN ("propertize", Fpropertize
, Spropertize
, 1, MANY
, 0,
3518 doc
: /* Return a copy of STRING with text properties added.
3519 First argument is the string to copy.
3520 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
3521 properties to add to the result.
3522 usage: (propertize STRING &rest PROPERTIES) */)
3523 (ptrdiff_t nargs
, Lisp_Object
*args
)
3525 Lisp_Object properties
, string
;
3526 struct gcpro gcpro1
, gcpro2
;
3529 /* Number of args must be odd. */
3530 if ((nargs
& 1) == 0)
3531 error ("Wrong number of arguments");
3533 properties
= string
= Qnil
;
3534 GCPRO2 (properties
, string
);
3536 /* First argument must be a string. */
3537 CHECK_STRING (args
[0]);
3538 string
= Fcopy_sequence (args
[0]);
3540 for (i
= 1; i
< nargs
; i
+= 2)
3541 properties
= Fcons (args
[i
], Fcons (args
[i
+ 1], properties
));
3543 Fadd_text_properties (make_number (0),
3544 make_number (SCHARS (string
)),
3545 properties
, string
);
3549 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
3550 doc
: /* Format a string out of a format-string and arguments.
3551 The first argument is a format control string.
3552 The other arguments are substituted into it to make the result, a string.
3554 The format control string may contain %-sequences meaning to substitute
3555 the next available argument:
3557 %s means print a string argument. Actually, prints any object, with `princ'.
3558 %d means print as number in decimal (%o octal, %x hex).
3559 %X is like %x, but uses upper case.
3560 %e means print a number in exponential notation.
3561 %f means print a number in decimal-point notation.
3562 %g means print a number in exponential notation
3563 or decimal-point notation, whichever uses fewer characters.
3564 %c means print a number as a single character.
3565 %S means print any object as an s-expression (using `prin1').
3567 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.
3568 Use %% to put a single % into the output.
3570 A %-sequence may contain optional flag, width, and precision
3571 specifiers, as follows:
3573 %<flags><width><precision>character
3575 where flags is [+ #-0]+, width is [0-9]+, and precision is .[0-9]+
3577 The + flag character inserts a + before any positive number, while a
3578 space inserts a space before any positive number; these flags only
3579 affect %d, %e, %f, and %g sequences, and the + flag takes precedence.
3580 The - and 0 flags affect the width specifier, as described below.
3582 The # flag means to use an alternate display form for %o, %x, %X, %e,
3583 %f, and %g sequences: for %o, it ensures that the result begins with
3584 \"0\"; for %x and %X, it prefixes the result with \"0x\" or \"0X\";
3585 for %e, %f, and %g, it causes a decimal point to be included even if
3586 the precision is zero.
3588 The width specifier supplies a lower limit for the length of the
3589 printed representation. The padding, if any, normally goes on the
3590 left, but it goes on the right if the - flag is present. The padding
3591 character is normally a space, but it is 0 if the 0 flag is present.
3592 The 0 flag is ignored if the - flag is present, or the format sequence
3593 is something other than %d, %e, %f, and %g.
3595 For %e, %f, and %g sequences, the number after the "." in the
3596 precision specifier says how many decimal places to show; if zero, the
3597 decimal point itself is omitted. For %s and %S, the precision
3598 specifier truncates the string to the given width.
3600 usage: (format STRING &rest OBJECTS) */)
3601 (ptrdiff_t nargs
, Lisp_Object
*args
)
3603 ptrdiff_t n
; /* The number of the next arg to substitute. */
3604 char initial_buffer
[4000];
3605 char *buf
= initial_buffer
;
3606 ptrdiff_t bufsize
= sizeof initial_buffer
;
3607 ptrdiff_t max_bufsize
= STRING_BYTES_BOUND
+ 1;
3609 char *format
, *end
, *format_start
;
3610 ptrdiff_t formatlen
, nchars
;
3611 /* True if the format is multibyte. */
3612 bool multibyte_format
= 0;
3613 /* True if the output should be a multibyte string,
3614 which is true if any of the inputs is one. */
3616 /* When we make a multibyte string, we must pay attention to the
3617 byte combining problem, i.e., a byte may be combined with a
3618 multibyte character of the previous string. This flag tells if we
3619 must consider such a situation or not. */
3620 bool maybe_combine_byte
;
3622 bool arg_intervals
= 0;
3625 /* discarded[I] is 1 if byte I of the format
3626 string was not copied into the output.
3627 It is 2 if byte I was not the first byte of its character. */
3630 /* Each element records, for one argument,
3631 the start and end bytepos in the output string,
3632 whether the argument has been converted to string (e.g., due to "%S"),
3633 and whether the argument is a string with intervals.
3634 info[0] is unused. Unused elements have -1 for start. */
3637 ptrdiff_t start
, end
;
3638 bool_bf converted_to_string
: 1;
3639 bool_bf intervals
: 1;
3642 /* It should not be necessary to GCPRO ARGS, because
3643 the caller in the interpreter should take care of that. */
3645 CHECK_STRING (args
[0]);
3646 format_start
= SSDATA (args
[0]);
3647 formatlen
= SBYTES (args
[0]);
3649 /* Allocate the info and discarded tables. */
3652 if ((SIZE_MAX
- formatlen
) / sizeof (struct info
) <= nargs
)
3653 memory_full (SIZE_MAX
);
3654 info
= SAFE_ALLOCA ((nargs
+ 1) * sizeof *info
+ formatlen
);
3655 discarded
= (char *) &info
[nargs
+ 1];
3656 for (i
= 0; i
< nargs
+ 1; i
++)
3659 info
[i
].intervals
= info
[i
].converted_to_string
= 0;
3661 memset (discarded
, 0, formatlen
);
3664 /* Try to determine whether the result should be multibyte.
3665 This is not always right; sometimes the result needs to be multibyte
3666 because of an object that we will pass through prin1,
3667 and in that case, we won't know it here. */
3668 multibyte_format
= STRING_MULTIBYTE (args
[0]);
3669 multibyte
= multibyte_format
;
3670 for (n
= 1; !multibyte
&& n
< nargs
; n
++)
3671 if (STRINGP (args
[n
]) && STRING_MULTIBYTE (args
[n
]))
3674 /* If we start out planning a unibyte result,
3675 then discover it has to be multibyte, we jump back to retry. */
3682 /* Scan the format and store result in BUF. */
3683 format
= format_start
;
3684 end
= format
+ formatlen
;
3685 maybe_combine_byte
= 0;
3687 while (format
!= end
)
3689 /* The values of N and FORMAT when the loop body is entered. */
3691 char *format0
= format
;
3693 /* Bytes needed to represent the output of this conversion. */
3694 ptrdiff_t convbytes
;
3698 /* General format specifications look like
3700 '%' [flags] [field-width] [precision] format
3705 field-width ::= [0-9]+
3706 precision ::= '.' [0-9]*
3708 If a field-width is specified, it specifies to which width
3709 the output should be padded with blanks, if the output
3710 string is shorter than field-width.
3712 If precision is specified, it specifies the number of
3713 digits to print after the '.' for floats, or the max.
3714 number of chars to print from a string. */
3716 bool minus_flag
= 0;
3718 bool space_flag
= 0;
3719 bool sharp_flag
= 0;
3721 ptrdiff_t field_width
;
3722 bool precision_given
;
3723 uintmax_t precision
= UINTMAX_MAX
;
3731 case '-': minus_flag
= 1; continue;
3732 case '+': plus_flag
= 1; continue;
3733 case ' ': space_flag
= 1; continue;
3734 case '#': sharp_flag
= 1; continue;
3735 case '0': zero_flag
= 1; continue;
3740 /* Ignore flags when sprintf ignores them. */
3741 space_flag
&= ~ plus_flag
;
3742 zero_flag
&= ~ minus_flag
;
3745 uintmax_t w
= strtoumax (format
, &num_end
, 10);
3746 if (max_bufsize
<= w
)
3750 precision_given
= *num_end
== '.';
3751 if (precision_given
)
3752 precision
= strtoumax (num_end
+ 1, &num_end
, 10);
3756 error ("Format string ends in middle of format specifier");
3758 memset (&discarded
[format0
- format_start
], 1, format
- format0
);
3759 conversion
= *format
;
3760 if (conversion
== '%')
3762 discarded
[format
- format_start
] = 1;
3767 error ("Not enough arguments for format string");
3769 /* For 'S', prin1 the argument, and then treat like 's'.
3770 For 's', princ any argument that is not a string or
3771 symbol. But don't do this conversion twice, which might
3772 happen after retrying. */
3773 if ((conversion
== 'S'
3774 || (conversion
== 's'
3775 && ! STRINGP (args
[n
]) && ! SYMBOLP (args
[n
]))))
3777 if (! info
[n
].converted_to_string
)
3779 Lisp_Object noescape
= conversion
== 'S' ? Qnil
: Qt
;
3780 args
[n
] = Fprin1_to_string (args
[n
], noescape
);
3781 info
[n
].converted_to_string
= 1;
3782 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
3790 else if (conversion
== 'c')
3792 if (FLOATP (args
[n
]))
3794 double d
= XFLOAT_DATA (args
[n
]);
3795 args
[n
] = make_number (FIXNUM_OVERFLOW_P (d
) ? -1 : d
);
3798 if (INTEGERP (args
[n
]) && ! ASCII_CHAR_P (XINT (args
[n
])))
3805 args
[n
] = Fchar_to_string (args
[n
]);
3806 info
[n
].converted_to_string
= 1;
3809 if (info
[n
].converted_to_string
)
3814 if (SYMBOLP (args
[n
]))
3816 args
[n
] = SYMBOL_NAME (args
[n
]);
3817 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
3824 if (conversion
== 's')
3826 /* handle case (precision[n] >= 0) */
3828 ptrdiff_t width
, padding
, nbytes
;
3829 ptrdiff_t nchars_string
;
3831 ptrdiff_t prec
= -1;
3832 if (precision_given
&& precision
<= TYPE_MAXIMUM (ptrdiff_t))
3835 /* lisp_string_width ignores a precision of 0, but GNU
3836 libc functions print 0 characters when the precision
3837 is 0. Imitate libc behavior here. Changing
3838 lisp_string_width is the right thing, and will be
3839 done, but meanwhile we work with it. */
3842 width
= nchars_string
= nbytes
= 0;
3846 width
= lisp_string_width (args
[n
], prec
, &nch
, &nby
);
3849 nchars_string
= SCHARS (args
[n
]);
3850 nbytes
= SBYTES (args
[n
]);
3854 nchars_string
= nch
;
3860 if (convbytes
&& multibyte
&& ! STRING_MULTIBYTE (args
[n
]))
3861 convbytes
= count_size_as_multibyte (SDATA (args
[n
]), nbytes
);
3863 padding
= width
< field_width
? field_width
- width
: 0;
3865 if (max_bufsize
- padding
<= convbytes
)
3867 convbytes
+= padding
;
3868 if (convbytes
<= buf
+ bufsize
- p
)
3872 memset (p
, ' ', padding
);
3879 && !ASCII_CHAR_P (*((unsigned char *) p
- 1))
3880 && STRING_MULTIBYTE (args
[n
])
3881 && !CHAR_HEAD_P (SREF (args
[n
], 0)))
3882 maybe_combine_byte
= 1;
3884 p
+= copy_text (SDATA (args
[n
]), (unsigned char *) p
,
3886 STRING_MULTIBYTE (args
[n
]), multibyte
);
3888 info
[n
].start
= nchars
;
3889 nchars
+= nchars_string
;
3890 info
[n
].end
= nchars
;
3894 memset (p
, ' ', padding
);
3899 /* If this argument has text properties, record where
3900 in the result string it appears. */
3901 if (string_intervals (args
[n
]))
3902 info
[n
].intervals
= arg_intervals
= 1;
3907 else if (! (conversion
== 'c' || conversion
== 'd'
3908 || conversion
== 'e' || conversion
== 'f'
3909 || conversion
== 'g' || conversion
== 'i'
3910 || conversion
== 'o' || conversion
== 'x'
3911 || conversion
== 'X'))
3912 error ("Invalid format operation %%%c",
3913 STRING_CHAR ((unsigned char *) format
- 1));
3914 else if (! (INTEGERP (args
[n
]) || FLOATP (args
[n
])))
3915 error ("Format specifier doesn't match argument type");
3920 /* Maximum precision for a %f conversion such that the
3921 trailing output digit might be nonzero. Any precision
3922 larger than this will not yield useful information. */
3923 USEFUL_PRECISION_MAX
=
3925 * (FLT_RADIX
== 2 || FLT_RADIX
== 10 ? 1
3926 : FLT_RADIX
== 16 ? 4
3929 /* Maximum number of bytes generated by any format, if
3930 precision is no more than USEFUL_PRECISION_MAX.
3931 On all practical hosts, %f is the worst case. */
3933 sizeof "-." + (DBL_MAX_10_EXP
+ 1) + USEFUL_PRECISION_MAX
,
3935 /* Length of pM (that is, of pMd without the
3937 pMlen
= sizeof pMd
- 2
3939 verify (USEFUL_PRECISION_MAX
> 0);
3942 ptrdiff_t padding
, sprintf_bytes
;
3943 uintmax_t excess_precision
, numwidth
;
3944 uintmax_t leading_zeros
= 0, trailing_zeros
= 0;
3946 char sprintf_buf
[SPRINTF_BUFSIZE
];
3948 /* Copy of conversion specification, modified somewhat.
3949 At most three flags F can be specified at once. */
3950 char convspec
[sizeof "%FFF.*d" + pMlen
];
3952 /* Avoid undefined behavior in underlying sprintf. */
3953 if (conversion
== 'd' || conversion
== 'i')
3956 /* Create the copy of the conversion specification, with
3957 any width and precision removed, with ".*" inserted,
3958 and with pM inserted for integer formats. */
3962 *f
= '-'; f
+= minus_flag
;
3963 *f
= '+'; f
+= plus_flag
;
3964 *f
= ' '; f
+= space_flag
;
3965 *f
= '#'; f
+= sharp_flag
;
3966 *f
= '0'; f
+= zero_flag
;
3969 if (conversion
== 'd' || conversion
== 'i'
3970 || conversion
== 'o' || conversion
== 'x'
3971 || conversion
== 'X')
3973 memcpy (f
, pMd
, pMlen
);
3975 zero_flag
&= ~ precision_given
;
3982 if (precision_given
)
3983 prec
= min (precision
, USEFUL_PRECISION_MAX
);
3985 /* Use sprintf to format this number into sprintf_buf. Omit
3986 padding and excess precision, though, because sprintf limits
3987 output length to INT_MAX.
3989 There are four types of conversion: double, unsigned
3990 char (passed as int), wide signed int, and wide
3991 unsigned int. Treat them separately because the
3992 sprintf ABI is sensitive to which type is passed. Be
3993 careful about integer overflow, NaNs, infinities, and
3994 conversions; for example, the min and max macros are
3995 not suitable here. */
3996 if (conversion
== 'e' || conversion
== 'f' || conversion
== 'g')
3998 double x
= (INTEGERP (args
[n
])
4000 : XFLOAT_DATA (args
[n
]));
4001 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4003 else if (conversion
== 'c')
4005 /* Don't use sprintf here, as it might mishandle prec. */
4006 sprintf_buf
[0] = XINT (args
[n
]);
4007 sprintf_bytes
= prec
!= 0;
4009 else if (conversion
== 'd')
4011 /* For float, maybe we should use "%1.0f"
4012 instead so it also works for values outside
4013 the integer range. */
4015 if (INTEGERP (args
[n
]))
4019 double d
= XFLOAT_DATA (args
[n
]);
4022 x
= TYPE_MINIMUM (printmax_t
);
4028 x
= TYPE_MAXIMUM (printmax_t
);
4033 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4037 /* Don't sign-extend for octal or hex printing. */
4039 if (INTEGERP (args
[n
]))
4040 x
= XUINT (args
[n
]);
4043 double d
= XFLOAT_DATA (args
[n
]);
4048 x
= TYPE_MAXIMUM (uprintmax_t
);
4053 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4056 /* Now the length of the formatted item is known, except it omits
4057 padding and excess precision. Deal with excess precision
4058 first. This happens only when the format specifies
4059 ridiculously large precision. */
4060 excess_precision
= precision
- prec
;
4061 if (excess_precision
)
4063 if (conversion
== 'e' || conversion
== 'f'
4064 || conversion
== 'g')
4066 if ((conversion
== 'g' && ! sharp_flag
)
4067 || ! ('0' <= sprintf_buf
[sprintf_bytes
- 1]
4068 && sprintf_buf
[sprintf_bytes
- 1] <= '9'))
4069 excess_precision
= 0;
4072 if (conversion
== 'g')
4074 char *dot
= strchr (sprintf_buf
, '.');
4076 excess_precision
= 0;
4079 trailing_zeros
= excess_precision
;
4082 leading_zeros
= excess_precision
;
4085 /* Compute the total bytes needed for this item, including
4086 excess precision and padding. */
4087 numwidth
= sprintf_bytes
+ excess_precision
;
4088 padding
= numwidth
< field_width
? field_width
- numwidth
: 0;
4089 if (max_bufsize
- sprintf_bytes
<= excess_precision
4090 || max_bufsize
- padding
<= numwidth
)
4092 convbytes
= numwidth
+ padding
;
4094 if (convbytes
<= buf
+ bufsize
- p
)
4096 /* Copy the formatted item from sprintf_buf into buf,
4097 inserting padding and excess-precision zeros. */
4099 char *src
= sprintf_buf
;
4101 int exponent_bytes
= 0;
4102 bool signedp
= src0
== '-' || src0
== '+' || src0
== ' ';
4103 int significand_bytes
;
4105 && ((src
[signedp
] >= '0' && src
[signedp
] <= '9')
4106 || (src
[signedp
] >= 'a' && src
[signedp
] <= 'f')
4107 || (src
[signedp
] >= 'A' && src
[signedp
] <= 'F')))
4109 leading_zeros
+= padding
;
4113 if (excess_precision
4114 && (conversion
== 'e' || conversion
== 'g'))
4116 char *e
= strchr (src
, 'e');
4118 exponent_bytes
= src
+ sprintf_bytes
- e
;
4123 memset (p
, ' ', padding
);
4131 memset (p
, '0', leading_zeros
);
4133 significand_bytes
= sprintf_bytes
- signedp
- exponent_bytes
;
4134 memcpy (p
, src
, significand_bytes
);
4135 p
+= significand_bytes
;
4136 src
+= significand_bytes
;
4137 memset (p
, '0', trailing_zeros
);
4138 p
+= trailing_zeros
;
4139 memcpy (p
, src
, exponent_bytes
);
4140 p
+= exponent_bytes
;
4142 info
[n
].start
= nchars
;
4143 nchars
+= leading_zeros
+ sprintf_bytes
+ trailing_zeros
;
4144 info
[n
].end
= nchars
;
4148 memset (p
, ' ', padding
);
4160 /* Copy a single character from format to buf. */
4163 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
4165 if (multibyte_format
)
4167 /* Copy a whole multibyte character. */
4169 && !ASCII_CHAR_P (*((unsigned char *) p
- 1))
4170 && !CHAR_HEAD_P (*format
))
4171 maybe_combine_byte
= 1;
4175 while (! CHAR_HEAD_P (*format
));
4177 convbytes
= format
- src
;
4178 memset (&discarded
[src
+ 1 - format_start
], 2, convbytes
- 1);
4182 unsigned char uc
= *format
++;
4183 if (! multibyte
|| ASCII_CHAR_P (uc
))
4187 int c
= BYTE8_TO_CHAR (uc
);
4188 convbytes
= CHAR_STRING (c
, str
);
4193 if (convbytes
<= buf
+ bufsize
- p
)
4195 memcpy (p
, src
, convbytes
);
4202 /* There wasn't enough room to store this conversion or single
4203 character. CONVBYTES says how much room is needed. Allocate
4204 enough room (and then some) and do it again. */
4206 ptrdiff_t used
= p
- buf
;
4208 if (max_bufsize
- used
< convbytes
)
4210 bufsize
= used
+ convbytes
;
4211 bufsize
= bufsize
< max_bufsize
/ 2 ? bufsize
* 2 : max_bufsize
;
4213 if (buf
== initial_buffer
)
4215 buf
= xmalloc_atomic (bufsize
);
4216 memcpy (buf
, initial_buffer
, used
);
4220 buf
= xrealloc (buf
, bufsize
);
4230 if (bufsize
< p
- buf
)
4233 if (maybe_combine_byte
)
4234 nchars
= multibyte_chars_in_text ((unsigned char *) buf
, p
- buf
);
4235 val
= make_specified_string (buf
, nchars
, p
- buf
, multibyte
);
4237 /* If we allocated BUF with malloc, free it too. */
4240 /* If the format string has text properties, or any of the string
4241 arguments has text properties, set up text properties of the
4244 if (string_intervals (args
[0]) || arg_intervals
)
4246 Lisp_Object len
, new_len
, props
;
4247 struct gcpro gcpro1
;
4249 /* Add text properties from the format string. */
4250 len
= make_number (SCHARS (args
[0]));
4251 props
= text_property_list (args
[0], make_number (0), len
, Qnil
);
4256 ptrdiff_t bytepos
= 0, position
= 0, translated
= 0;
4260 /* Adjust the bounds of each text property
4261 to the proper start and end in the output string. */
4263 /* Put the positions in PROPS in increasing order, so that
4264 we can do (effectively) one scan through the position
4265 space of the format string. */
4266 props
= Fnreverse (props
);
4268 /* BYTEPOS is the byte position in the format string,
4269 POSITION is the untranslated char position in it,
4270 TRANSLATED is the translated char position in BUF,
4271 and ARGN is the number of the next arg we will come to. */
4272 for (list
= props
; CONSP (list
); list
= XCDR (list
))
4279 /* First adjust the property start position. */
4280 pos
= XINT (XCAR (item
));
4282 /* Advance BYTEPOS, POSITION, TRANSLATED and ARGN
4283 up to this position. */
4284 for (; position
< pos
; bytepos
++)
4286 if (! discarded
[bytepos
])
4287 position
++, translated
++;
4288 else if (discarded
[bytepos
] == 1)
4291 if (translated
== info
[argn
].start
)
4293 translated
+= info
[argn
].end
- info
[argn
].start
;
4299 XSETCAR (item
, make_number (translated
));
4301 /* Likewise adjust the property end position. */
4302 pos
= XINT (XCAR (XCDR (item
)));
4304 for (; position
< pos
; bytepos
++)
4306 if (! discarded
[bytepos
])
4307 position
++, translated
++;
4308 else if (discarded
[bytepos
] == 1)
4311 if (translated
== info
[argn
].start
)
4313 translated
+= info
[argn
].end
- info
[argn
].start
;
4319 XSETCAR (XCDR (item
), make_number (translated
));
4322 add_text_properties_from_list (val
, props
, make_number (0));
4325 /* Add text properties from arguments. */
4327 for (n
= 1; n
< nargs
; ++n
)
4328 if (info
[n
].intervals
)
4330 len
= make_number (SCHARS (args
[n
]));
4331 new_len
= make_number (info
[n
].end
- info
[n
].start
);
4332 props
= text_property_list (args
[n
], make_number (0), len
, Qnil
);
4333 props
= extend_property_ranges (props
, new_len
);
4334 /* If successive arguments have properties, be sure that
4335 the value of `composition' property be the copy. */
4336 if (n
> 1 && info
[n
- 1].end
)
4337 make_composition_value_copy (props
);
4338 add_text_properties_from_list (val
, props
,
4339 make_number (info
[n
].start
));
4349 format2 (const char *string1
, Lisp_Object arg0
, Lisp_Object arg1
)
4351 Lisp_Object args
[3];
4352 args
[0] = build_string (string1
);
4355 return Fformat (3, args
);
4358 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
4359 doc
: /* Return t if two characters match, optionally ignoring case.
4360 Both arguments must be characters (i.e. integers).
4361 Case is ignored if `case-fold-search' is non-nil in the current buffer. */)
4362 (register Lisp_Object c1
, Lisp_Object c2
)
4365 /* Check they're chars, not just integers, otherwise we could get array
4366 bounds violations in downcase. */
4367 CHECK_CHARACTER (c1
);
4368 CHECK_CHARACTER (c2
);
4370 if (XINT (c1
) == XINT (c2
))
4372 if (NILP (BVAR (current_buffer
, case_fold_search
)))
4378 /* FIXME: It is possible to compare multibyte characters even when
4379 the current buffer is unibyte. Unfortunately this is ambiguous
4380 for characters between 128 and 255, as they could be either
4381 eight-bit raw bytes or Latin-1 characters. Assume the former for
4382 now. See Bug#17011, and also see casefiddle.c's casify_object,
4383 which has a similar problem. */
4384 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
4386 if (SINGLE_BYTE_CHAR_P (i1
))
4387 i1
= UNIBYTE_TO_CHAR (i1
);
4388 if (SINGLE_BYTE_CHAR_P (i2
))
4389 i2
= UNIBYTE_TO_CHAR (i2
);
4392 return (downcase (i1
) == downcase (i2
) ? Qt
: Qnil
);
4395 /* Transpose the markers in two regions of the current buffer, and
4396 adjust the ones between them if necessary (i.e.: if the regions
4399 START1, END1 are the character positions of the first region.
4400 START1_BYTE, END1_BYTE are the byte positions.
4401 START2, END2 are the character positions of the second region.
4402 START2_BYTE, END2_BYTE are the byte positions.
4404 Traverses the entire marker list of the buffer to do so, adding an
4405 appropriate amount to some, subtracting from some, and leaving the
4406 rest untouched. Most of this is copied from adjust_markers in insdel.c.
4408 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
4411 transpose_markers (ptrdiff_t start1
, ptrdiff_t end1
,
4412 ptrdiff_t start2
, ptrdiff_t end2
,
4413 ptrdiff_t start1_byte
, ptrdiff_t end1_byte
,
4414 ptrdiff_t start2_byte
, ptrdiff_t end2_byte
)
4416 register ptrdiff_t amt1
, amt1_byte
, amt2
, amt2_byte
, diff
, diff_byte
, mpos
;
4417 register struct Lisp_Marker
*marker
;
4419 /* Update point as if it were a marker. */
4423 TEMP_SET_PT_BOTH (PT
+ (end2
- end1
),
4424 PT_BYTE
+ (end2_byte
- end1_byte
));
4425 else if (PT
< start2
)
4426 TEMP_SET_PT_BOTH (PT
+ (end2
- start2
) - (end1
- start1
),
4427 (PT_BYTE
+ (end2_byte
- start2_byte
)
4428 - (end1_byte
- start1_byte
)));
4430 TEMP_SET_PT_BOTH (PT
- (start2
- start1
),
4431 PT_BYTE
- (start2_byte
- start1_byte
));
4433 /* We used to adjust the endpoints here to account for the gap, but that
4434 isn't good enough. Even if we assume the caller has tried to move the
4435 gap out of our way, it might still be at start1 exactly, for example;
4436 and that places it `inside' the interval, for our purposes. The amount
4437 of adjustment is nontrivial if there's a `denormalized' marker whose
4438 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
4439 the dirty work to Fmarker_position, below. */
4441 /* The difference between the region's lengths */
4442 diff
= (end2
- start2
) - (end1
- start1
);
4443 diff_byte
= (end2_byte
- start2_byte
) - (end1_byte
- start1_byte
);
4445 /* For shifting each marker in a region by the length of the other
4446 region plus the distance between the regions. */
4447 amt1
= (end2
- start2
) + (start2
- end1
);
4448 amt2
= (end1
- start1
) + (start2
- end1
);
4449 amt1_byte
= (end2_byte
- start2_byte
) + (start2_byte
- end1_byte
);
4450 amt2_byte
= (end1_byte
- start1_byte
) + (start2_byte
- end1_byte
);
4452 for (marker
= BUF_MARKERS (current_buffer
); marker
; marker
= marker
->next
)
4454 mpos
= marker
->bytepos
;
4455 if (mpos
>= start1_byte
&& mpos
< end2_byte
)
4457 if (mpos
< end1_byte
)
4459 else if (mpos
< start2_byte
)
4463 marker
->bytepos
= mpos
;
4465 mpos
= marker
->charpos
;
4466 if (mpos
>= start1
&& mpos
< end2
)
4470 else if (mpos
< start2
)
4475 marker
->charpos
= mpos
;
4479 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
4480 doc
: /* Transpose region STARTR1 to ENDR1 with STARTR2 to ENDR2.
4481 The regions should not be overlapping, because the size of the buffer is
4482 never changed in a transposition.
4484 Optional fifth arg LEAVE-MARKERS, if non-nil, means don't update
4485 any markers that happen to be located in the regions.
4487 Transposing beyond buffer boundaries is an error. */)
4488 (Lisp_Object startr1
, Lisp_Object endr1
, Lisp_Object startr2
, Lisp_Object endr2
, Lisp_Object leave_markers
)
4490 register ptrdiff_t start1
, end1
, start2
, end2
;
4491 ptrdiff_t start1_byte
, start2_byte
, len1_byte
, len2_byte
, end2_byte
;
4492 ptrdiff_t gap
, len1
, len_mid
, len2
;
4493 unsigned char *start1_addr
, *start2_addr
, *temp
;
4495 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
, tmp_interval3
;
4498 XSETBUFFER (buf
, current_buffer
);
4499 cur_intv
= buffer_intervals (current_buffer
);
4501 validate_region (&startr1
, &endr1
);
4502 validate_region (&startr2
, &endr2
);
4504 start1
= XFASTINT (startr1
);
4505 end1
= XFASTINT (endr1
);
4506 start2
= XFASTINT (startr2
);
4507 end2
= XFASTINT (endr2
);
4510 /* Swap the regions if they're reversed. */
4513 register ptrdiff_t glumph
= start1
;
4521 len1
= end1
- start1
;
4522 len2
= end2
- start2
;
4525 error ("Transposed regions overlap");
4526 /* Nothing to change for adjacent regions with one being empty */
4527 else if ((start1
== end1
|| start2
== end2
) && end1
== start2
)
4530 /* The possibilities are:
4531 1. Adjacent (contiguous) regions, or separate but equal regions
4532 (no, really equal, in this case!), or
4533 2. Separate regions of unequal size.
4535 The worst case is usually No. 2. It means that (aside from
4536 potential need for getting the gap out of the way), there also
4537 needs to be a shifting of the text between the two regions. So
4538 if they are spread far apart, we are that much slower... sigh. */
4540 /* It must be pointed out that the really studly thing to do would
4541 be not to move the gap at all, but to leave it in place and work
4542 around it if necessary. This would be extremely efficient,
4543 especially considering that people are likely to do
4544 transpositions near where they are working interactively, which
4545 is exactly where the gap would be found. However, such code
4546 would be much harder to write and to read. So, if you are
4547 reading this comment and are feeling squirrely, by all means have
4548 a go! I just didn't feel like doing it, so I will simply move
4549 the gap the minimum distance to get it out of the way, and then
4550 deal with an unbroken array. */
4552 start1_byte
= CHAR_TO_BYTE (start1
);
4553 end2_byte
= CHAR_TO_BYTE (end2
);
4555 /* Make sure the gap won't interfere, by moving it out of the text
4556 we will operate on. */
4557 if (start1
< gap
&& gap
< end2
)
4559 if (gap
- start1
< end2
- gap
)
4560 move_gap_both (start1
, start1_byte
);
4562 move_gap_both (end2
, end2_byte
);
4565 start2_byte
= CHAR_TO_BYTE (start2
);
4566 len1_byte
= CHAR_TO_BYTE (end1
) - start1_byte
;
4567 len2_byte
= end2_byte
- start2_byte
;
4569 #ifdef BYTE_COMBINING_DEBUG
4572 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4573 len2_byte
, start1
, start1_byte
)
4574 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4575 len1_byte
, end2
, start2_byte
+ len2_byte
)
4576 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4577 len1_byte
, end2
, start2_byte
+ len2_byte
))
4582 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4583 len2_byte
, start1
, start1_byte
)
4584 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4585 len1_byte
, start2
, start2_byte
)
4586 || count_combining_after (BYTE_POS_ADDR (start2_byte
),
4587 len2_byte
, end1
, start1_byte
+ len1_byte
)
4588 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4589 len1_byte
, end2
, start2_byte
+ len2_byte
))
4594 /* Hmmm... how about checking to see if the gap is large
4595 enough to use as the temporary storage? That would avoid an
4596 allocation... interesting. Later, don't fool with it now. */
4598 /* Working without memmove, for portability (sigh), so must be
4599 careful of overlapping subsections of the array... */
4601 if (end1
== start2
) /* adjacent regions */
4603 modify_text (start1
, end2
);
4604 record_change (start1
, len1
+ len2
);
4606 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4607 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4608 /* Don't use Fset_text_properties: that can cause GC, which can
4609 clobber objects stored in the tmp_intervals. */
4610 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4612 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4614 /* First region smaller than second. */
4615 if (len1_byte
< len2_byte
)
4619 temp
= SAFE_ALLOCA (len2_byte
);
4621 /* Don't precompute these addresses. We have to compute them
4622 at the last minute, because the relocating allocator might
4623 have moved the buffer around during the xmalloc. */
4624 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4625 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4627 memcpy (temp
, start2_addr
, len2_byte
);
4628 memcpy (start1_addr
+ len2_byte
, start1_addr
, len1_byte
);
4629 memcpy (start1_addr
, temp
, len2_byte
);
4633 /* First region not smaller than second. */
4637 temp
= SAFE_ALLOCA (len1_byte
);
4638 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4639 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4640 memcpy (temp
, start1_addr
, len1_byte
);
4641 memcpy (start1_addr
, start2_addr
, len2_byte
);
4642 memcpy (start1_addr
+ len2_byte
, temp
, len1_byte
);
4645 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
4646 len1
, current_buffer
, 0);
4647 graft_intervals_into_buffer (tmp_interval2
, start1
,
4648 len2
, current_buffer
, 0);
4649 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4650 update_compositions (start1
+ len2
, end2
, CHECK_TAIL
);
4652 /* Non-adjacent regions, because end1 != start2, bleagh... */
4655 len_mid
= start2_byte
- (start1_byte
+ len1_byte
);
4657 if (len1_byte
== len2_byte
)
4658 /* Regions are same size, though, how nice. */
4662 modify_text (start1
, end1
);
4663 modify_text (start2
, end2
);
4664 record_change (start1
, len1
);
4665 record_change (start2
, len2
);
4666 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4667 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4669 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr1
, 0);
4671 set_text_properties_1 (startr1
, endr1
, Qnil
, buf
, tmp_interval3
);
4673 tmp_interval3
= validate_interval_range (buf
, &startr2
, &endr2
, 0);
4675 set_text_properties_1 (startr2
, endr2
, Qnil
, buf
, tmp_interval3
);
4677 temp
= SAFE_ALLOCA (len1_byte
);
4678 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4679 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4680 memcpy (temp
, start1_addr
, len1_byte
);
4681 memcpy (start1_addr
, start2_addr
, len2_byte
);
4682 memcpy (start2_addr
, temp
, len1_byte
);
4685 graft_intervals_into_buffer (tmp_interval1
, start2
,
4686 len1
, current_buffer
, 0);
4687 graft_intervals_into_buffer (tmp_interval2
, start1
,
4688 len2
, current_buffer
, 0);
4691 else if (len1_byte
< len2_byte
) /* Second region larger than first */
4692 /* Non-adjacent & unequal size, area between must also be shifted. */
4696 modify_text (start1
, end2
);
4697 record_change (start1
, (end2
- start1
));
4698 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4699 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4700 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4702 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4704 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4706 /* holds region 2 */
4707 temp
= SAFE_ALLOCA (len2_byte
);
4708 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4709 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4710 memcpy (temp
, start2_addr
, len2_byte
);
4711 memcpy (start1_addr
+ len_mid
+ len2_byte
, start1_addr
, len1_byte
);
4712 memmove (start1_addr
+ len2_byte
, start1_addr
+ len1_byte
, len_mid
);
4713 memcpy (start1_addr
, temp
, len2_byte
);
4716 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4717 len1
, current_buffer
, 0);
4718 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4719 len_mid
, current_buffer
, 0);
4720 graft_intervals_into_buffer (tmp_interval2
, start1
,
4721 len2
, current_buffer
, 0);
4724 /* Second region smaller than first. */
4728 record_change (start1
, (end2
- start1
));
4729 modify_text (start1
, end2
);
4731 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4732 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4733 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4735 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4737 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4739 /* holds region 1 */
4740 temp
= SAFE_ALLOCA (len1_byte
);
4741 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4742 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4743 memcpy (temp
, start1_addr
, len1_byte
);
4744 memcpy (start1_addr
, start2_addr
, len2_byte
);
4745 memcpy (start1_addr
+ len2_byte
, start1_addr
+ len1_byte
, len_mid
);
4746 memcpy (start1_addr
+ len2_byte
+ len_mid
, temp
, len1_byte
);
4749 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4750 len1
, current_buffer
, 0);
4751 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4752 len_mid
, current_buffer
, 0);
4753 graft_intervals_into_buffer (tmp_interval2
, start1
,
4754 len2
, current_buffer
, 0);
4757 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4758 update_compositions (end2
- len1
, end2
, CHECK_BORDER
);
4761 /* When doing multiple transpositions, it might be nice
4762 to optimize this. Perhaps the markers in any one buffer
4763 should be organized in some sorted data tree. */
4764 if (NILP (leave_markers
))
4766 transpose_markers (start1
, end1
, start2
, end2
,
4767 start1_byte
, start1_byte
+ len1_byte
,
4768 start2_byte
, start2_byte
+ len2_byte
);
4769 fix_start_end_in_overlays (start1
, end2
);
4772 signal_after_change (start1
, end2
- start1
, end2
- start1
);
4778 syms_of_editfns (void)
4780 #include "editfns.x"
4782 DEFSYM (Qbuffer_access_fontify_functions
, "buffer-access-fontify-functions");
4784 DEFVAR_LISP ("inhibit-field-text-motion", Vinhibit_field_text_motion
,
4785 doc
: /* Non-nil means text motion commands don't notice fields. */);
4786 Vinhibit_field_text_motion
= Qnil
;
4788 DEFVAR_LISP ("buffer-access-fontify-functions",
4789 Vbuffer_access_fontify_functions
,
4790 doc
: /* List of functions called by `buffer-substring' to fontify if necessary.
4791 Each function is called with two arguments which specify the range
4792 of the buffer being accessed. */);
4793 Vbuffer_access_fontify_functions
= Qnil
;
4797 obuf
= Fcurrent_buffer ();
4798 /* Do this here, because init_buffer_once is too early--it won't work. */
4799 Fset_buffer (Vprin1_to_string_buffer
);
4800 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
4801 Fset (Fmake_local_variable (intern_c_string ("buffer-access-fontify-functions")),
4806 DEFVAR_LISP ("buffer-access-fontified-property",
4807 Vbuffer_access_fontified_property
,
4808 doc
: /* Property which (if non-nil) indicates text has been fontified.
4809 `buffer-substring' need not call the `buffer-access-fontify-functions'
4810 functions if all the text being accessed has this property. */);
4811 Vbuffer_access_fontified_property
= Qnil
;
4813 DEFVAR_LISP ("system-name", Vsystem_name
,
4814 doc
: /* The host name of the machine Emacs is running on. */);
4816 DEFVAR_LISP ("user-full-name", Vuser_full_name
,
4817 doc
: /* The full name of the user logged in. */);
4819 DEFVAR_LISP ("user-login-name", Vuser_login_name
,
4820 doc
: /* The user's name, taken from environment variables if possible. */);
4822 DEFVAR_LISP ("user-real-login-name", Vuser_real_login_name
,
4823 doc
: /* The user's name, based upon the real uid only. */);
4825 DEFVAR_LISP ("operating-system-release", Voperating_system_release
,
4826 doc
: /* The release of the operating system Emacs is running on. */);
4828 DEFSYM (Qfield
, "field");
4829 DEFSYM (Qboundary
, "boundary");