1 /* Lisp functions pertaining to editing.
3 Copyright (C) 1985-1987, 1989, 1993-2013 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 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
;
762 ptrdiff_t count
= SPECPDL_INDEX ();
763 specbind (Qinhibit_point_motion_hooks
, Qt
);
772 Fforward_line (make_number (XINT (n
) - 1));
775 SET_PT_BOTH (orig
, orig_byte
);
777 unbind_to (count
, Qnil
);
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
;
937 ptrdiff_t count
= SPECPDL_INDEX ();
939 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
942 return unbind_to (count
, val
);
945 DEFUN ("save-current-buffer", Fsave_current_buffer
, Ssave_current_buffer
, 0, UNEVALLED
, 0,
946 doc
: /* Record which buffer is current; execute BODY; make that buffer current.
947 BODY is executed just like `progn'.
948 usage: (save-current-buffer &rest BODY) */)
951 ptrdiff_t count
= SPECPDL_INDEX ();
953 record_unwind_current_buffer ();
954 return unbind_to (count
, Fprogn (args
));
957 DEFUN ("buffer-size", Fbuffer_size
, Sbuffer_size
, 0, 1, 0,
958 doc
: /* Return the number of characters in the current buffer.
959 If BUFFER, return the number of characters in that buffer instead. */)
963 return make_number (Z
- BEG
);
966 CHECK_BUFFER (buffer
);
967 return make_number (BUF_Z (XBUFFER (buffer
))
968 - BUF_BEG (XBUFFER (buffer
)));
972 DEFUN ("point-min", Fpoint_min
, Spoint_min
, 0, 0, 0,
973 doc
: /* Return the minimum permissible value of point in the current buffer.
974 This is 1, unless narrowing (a buffer restriction) is in effect. */)
978 XSETFASTINT (temp
, BEGV
);
982 DEFUN ("point-min-marker", Fpoint_min_marker
, Spoint_min_marker
, 0, 0, 0,
983 doc
: /* Return a marker to the minimum permissible value of point in this buffer.
984 This is the beginning, unless narrowing (a buffer restriction) is in effect. */)
987 return build_marker (current_buffer
, BEGV
, BEGV_BYTE
);
990 DEFUN ("point-max", Fpoint_max
, Spoint_max
, 0, 0, 0,
991 doc
: /* Return the maximum permissible value of point in the current buffer.
992 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
993 is in effect, in which case it is less. */)
997 XSETFASTINT (temp
, ZV
);
1001 DEFUN ("point-max-marker", Fpoint_max_marker
, Spoint_max_marker
, 0, 0, 0,
1002 doc
: /* Return a marker to the maximum permissible value of point in this buffer.
1003 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1004 is in effect, in which case it is less. */)
1007 return build_marker (current_buffer
, ZV
, ZV_BYTE
);
1010 DEFUN ("gap-position", Fgap_position
, Sgap_position
, 0, 0, 0,
1011 doc
: /* Return the position of the gap, in the current buffer.
1012 See also `gap-size'. */)
1016 XSETFASTINT (temp
, GPT
);
1020 DEFUN ("gap-size", Fgap_size
, Sgap_size
, 0, 0, 0,
1021 doc
: /* Return the size of the current buffer's gap.
1022 See also `gap-position'. */)
1026 XSETFASTINT (temp
, GAP_SIZE
);
1030 DEFUN ("position-bytes", Fposition_bytes
, Sposition_bytes
, 1, 1, 0,
1031 doc
: /* Return the byte position for character position POSITION.
1032 If POSITION is out of range, the value is nil. */)
1033 (Lisp_Object position
)
1035 CHECK_NUMBER_COERCE_MARKER (position
);
1036 if (XINT (position
) < BEG
|| XINT (position
) > Z
)
1038 return make_number (CHAR_TO_BYTE (XINT (position
)));
1041 DEFUN ("byte-to-position", Fbyte_to_position
, Sbyte_to_position
, 1, 1, 0,
1042 doc
: /* Return the character position for byte position BYTEPOS.
1043 If BYTEPOS is out of range, the value is nil. */)
1044 (Lisp_Object bytepos
)
1046 CHECK_NUMBER (bytepos
);
1047 if (XINT (bytepos
) < BEG_BYTE
|| XINT (bytepos
) > Z_BYTE
)
1049 return make_number (BYTE_TO_CHAR (XINT (bytepos
)));
1052 DEFUN ("following-char", Ffollowing_char
, Sfollowing_char
, 0, 0, 0,
1053 doc
: /* Return the character following point, as a number.
1054 At the end of the buffer or accessible region, return 0. */)
1059 XSETFASTINT (temp
, 0);
1061 XSETFASTINT (temp
, FETCH_CHAR (PT_BYTE
));
1065 DEFUN ("preceding-char", Fprevious_char
, Sprevious_char
, 0, 0, 0,
1066 doc
: /* Return the character preceding point, as a number.
1067 At the beginning of the buffer or accessible region, return 0. */)
1072 XSETFASTINT (temp
, 0);
1073 else if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
1075 ptrdiff_t pos
= PT_BYTE
;
1077 XSETFASTINT (temp
, FETCH_CHAR (pos
));
1080 XSETFASTINT (temp
, FETCH_BYTE (PT_BYTE
- 1));
1084 DEFUN ("bobp", Fbobp
, Sbobp
, 0, 0, 0,
1085 doc
: /* Return t if point is at the beginning of the buffer.
1086 If the buffer is narrowed, this means the beginning of the narrowed part. */)
1094 DEFUN ("eobp", Feobp
, Seobp
, 0, 0, 0,
1095 doc
: /* Return t if point is at the end of the buffer.
1096 If the buffer is narrowed, this means the end of the narrowed part. */)
1104 DEFUN ("bolp", Fbolp
, Sbolp
, 0, 0, 0,
1105 doc
: /* Return t if point is at the beginning of a line. */)
1108 if (PT
== BEGV
|| FETCH_BYTE (PT_BYTE
- 1) == '\n')
1113 DEFUN ("eolp", Feolp
, Seolp
, 0, 0, 0,
1114 doc
: /* Return t if point is at the end of a line.
1115 `End of a line' includes point being at the end of the buffer. */)
1118 if (PT
== ZV
|| FETCH_BYTE (PT_BYTE
) == '\n')
1123 DEFUN ("char-after", Fchar_after
, Schar_after
, 0, 1, 0,
1124 doc
: /* Return character in current buffer at position POS.
1125 POS is an integer or a marker and defaults to point.
1126 If POS is out of range, the value is nil. */)
1129 register ptrdiff_t pos_byte
;
1134 XSETFASTINT (pos
, PT
);
1139 pos_byte
= marker_byte_position (pos
);
1140 if (pos_byte
< BEGV_BYTE
|| pos_byte
>= ZV_BYTE
)
1145 CHECK_NUMBER_COERCE_MARKER (pos
);
1146 if (XINT (pos
) < BEGV
|| XINT (pos
) >= ZV
)
1149 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1152 return make_number (FETCH_CHAR (pos_byte
));
1155 DEFUN ("char-before", Fchar_before
, Schar_before
, 0, 1, 0,
1156 doc
: /* Return character in current buffer preceding position POS.
1157 POS is an integer or a marker and defaults to point.
1158 If POS is out of range, the value is nil. */)
1161 register Lisp_Object val
;
1162 register ptrdiff_t pos_byte
;
1167 XSETFASTINT (pos
, PT
);
1172 pos_byte
= marker_byte_position (pos
);
1174 if (pos_byte
<= BEGV_BYTE
|| pos_byte
> ZV_BYTE
)
1179 CHECK_NUMBER_COERCE_MARKER (pos
);
1181 if (XINT (pos
) <= BEGV
|| XINT (pos
) > ZV
)
1184 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1187 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
1190 XSETFASTINT (val
, FETCH_CHAR (pos_byte
));
1195 XSETFASTINT (val
, FETCH_BYTE (pos_byte
));
1200 DEFUN ("user-login-name", Fuser_login_name
, Suser_login_name
, 0, 1, 0,
1201 doc
: /* Return the name under which the user logged in, as a string.
1202 This is based on the effective uid, not the real uid.
1203 Also, if the environment variables LOGNAME or USER are set,
1204 that determines the value of this function.
1206 If optional argument UID is an integer or a float, return the login name
1207 of the user with that uid, or nil if there is no such user. */)
1213 /* Set up the user name info if we didn't do it before.
1214 (That can happen if Emacs is dumpable
1215 but you decide to run `temacs -l loadup' and not dump. */
1216 if (INTEGERP (Vuser_login_name
))
1220 return Vuser_login_name
;
1222 CONS_TO_INTEGER (uid
, uid_t
, id
);
1226 return (pw
? build_string (pw
->pw_name
) : Qnil
);
1229 DEFUN ("user-real-login-name", Fuser_real_login_name
, Suser_real_login_name
,
1231 doc
: /* Return the name of the user's real uid, as a string.
1232 This ignores the environment variables LOGNAME and USER, so it differs from
1233 `user-login-name' when running under `su'. */)
1236 /* Set up the user name info if we didn't do it before.
1237 (That can happen if Emacs is dumpable
1238 but you decide to run `temacs -l loadup' and not dump. */
1239 if (INTEGERP (Vuser_login_name
))
1241 return Vuser_real_login_name
;
1244 DEFUN ("user-uid", Fuser_uid
, Suser_uid
, 0, 0, 0,
1245 doc
: /* Return the effective uid of Emacs.
1246 Value is an integer or a float, depending on the value. */)
1249 uid_t euid
= geteuid ();
1250 return make_fixnum_or_float (euid
);
1253 DEFUN ("user-real-uid", Fuser_real_uid
, Suser_real_uid
, 0, 0, 0,
1254 doc
: /* Return the real uid of Emacs.
1255 Value is an integer or a float, depending on the value. */)
1258 uid_t uid
= getuid ();
1259 return make_fixnum_or_float (uid
);
1262 DEFUN ("group-gid", Fgroup_gid
, Sgroup_gid
, 0, 0, 0,
1263 doc
: /* Return the effective gid of Emacs.
1264 Value is an integer or a float, depending on the value. */)
1267 gid_t egid
= getegid ();
1268 return make_fixnum_or_float (egid
);
1271 DEFUN ("group-real-gid", Fgroup_real_gid
, Sgroup_real_gid
, 0, 0, 0,
1272 doc
: /* Return the real gid of Emacs.
1273 Value is an integer or a float, depending on the value. */)
1276 gid_t gid
= getgid ();
1277 return make_fixnum_or_float (gid
);
1280 DEFUN ("user-full-name", Fuser_full_name
, Suser_full_name
, 0, 1, 0,
1281 doc
: /* Return the full name of the user logged in, as a string.
1282 If the full name corresponding to Emacs's userid is not known,
1285 If optional argument UID is an integer or float, return the full name
1286 of the user with that uid, or nil if there is no such user.
1287 If UID is a string, return the full name of the user with that login
1288 name, or nil if there is no such user. */)
1292 register char *p
, *q
;
1296 return Vuser_full_name
;
1297 else if (NUMBERP (uid
))
1300 CONS_TO_INTEGER (uid
, uid_t
, u
);
1305 else if (STRINGP (uid
))
1308 pw
= getpwnam (SSDATA (uid
));
1312 error ("Invalid UID specification");
1318 /* Chop off everything after the first comma. */
1319 q
= strchr (p
, ',');
1320 full
= make_string (p
, q
? q
- p
: strlen (p
));
1322 #ifdef AMPERSAND_FULL_NAME
1324 q
= strchr (p
, '&');
1325 /* Substitute the login name for the &, upcasing the first character. */
1331 login
= Fuser_login_name (make_number (pw
->pw_uid
));
1332 r
= alloca (strlen (p
) + SCHARS (login
) + 1);
1333 memcpy (r
, p
, q
- p
);
1335 strcat (r
, SSDATA (login
));
1336 r
[q
- p
] = upcase ((unsigned char) r
[q
- p
]);
1338 full
= build_string (r
);
1340 #endif /* AMPERSAND_FULL_NAME */
1345 DEFUN ("system-name", Fsystem_name
, Ssystem_name
, 0, 0, 0,
1346 doc
: /* Return the host name of the machine you are running on, as a string. */)
1349 return Vsystem_name
;
1352 DEFUN ("emacs-pid", Femacs_pid
, Semacs_pid
, 0, 0, 0,
1353 doc
: /* Return the process ID of Emacs, as a number. */)
1356 pid_t pid
= getpid ();
1357 return make_fixnum_or_float (pid
);
1363 # define TIME_T_MIN TYPE_MINIMUM (time_t)
1366 # define TIME_T_MAX TYPE_MAXIMUM (time_t)
1369 /* Report that a time value is out of range for Emacs. */
1371 time_overflow (void)
1373 error ("Specified time is not representable");
1376 /* Return the upper part of the time T (everything but the bottom 16 bits). */
1380 time_t hi
= t
>> 16;
1382 /* Check for overflow, helping the compiler for common cases where
1383 no runtime check is needed, and taking care not to convert
1384 negative numbers to unsigned before comparing them. */
1385 if (! ((! TYPE_SIGNED (time_t)
1386 || MOST_NEGATIVE_FIXNUM
<= TIME_T_MIN
>> 16
1387 || MOST_NEGATIVE_FIXNUM
<= hi
)
1388 && (TIME_T_MAX
>> 16 <= MOST_POSITIVE_FIXNUM
1389 || hi
<= MOST_POSITIVE_FIXNUM
)))
1395 /* Return the bottom 16 bits of the time T. */
1399 return t
& ((1 << 16) - 1);
1402 DEFUN ("current-time", Fcurrent_time
, Scurrent_time
, 0, 0, 0,
1403 doc
: /* Return the current time, as the number of seconds since 1970-01-01 00:00:00.
1404 The time is returned as a list of integers (HIGH LOW USEC PSEC).
1405 HIGH has the most significant bits of the seconds, while LOW has the
1406 least significant 16 bits. USEC and PSEC are the microsecond and
1407 picosecond counts. */)
1410 return make_lisp_time (current_timespec ());
1413 DEFUN ("get-internal-run-time", Fget_internal_run_time
, Sget_internal_run_time
,
1415 doc
: /* Return the current run time used by Emacs.
1416 The time is returned as a list (HIGH LOW USEC PSEC), using the same
1417 style as (current-time).
1419 On systems that can't determine the run time, `get-internal-run-time'
1420 does the same thing as `current-time'. */)
1423 #ifdef HAVE_GETRUSAGE
1424 struct rusage usage
;
1428 if (getrusage (RUSAGE_SELF
, &usage
) < 0)
1429 /* This shouldn't happen. What action is appropriate? */
1432 /* Sum up user time and system time. */
1433 secs
= usage
.ru_utime
.tv_sec
+ usage
.ru_stime
.tv_sec
;
1434 usecs
= usage
.ru_utime
.tv_usec
+ usage
.ru_stime
.tv_usec
;
1435 if (usecs
>= 1000000)
1440 return make_lisp_time (make_timespec (secs
, usecs
* 1000));
1441 #else /* ! HAVE_GETRUSAGE */
1443 return w32_get_internal_run_time ();
1444 #else /* ! WINDOWSNT */
1445 return Fcurrent_time ();
1446 #endif /* WINDOWSNT */
1447 #endif /* HAVE_GETRUSAGE */
1451 /* Make a Lisp list that represents the time T with fraction TAIL. */
1453 make_time_tail (time_t t
, Lisp_Object tail
)
1455 return Fcons (make_number (hi_time (t
)),
1456 Fcons (make_number (lo_time (t
)), tail
));
1459 /* Make a Lisp list that represents the system time T. */
1461 make_time (time_t t
)
1463 return make_time_tail (t
, Qnil
);
1466 /* Make a Lisp list that represents the Emacs time T. T may be an
1467 invalid time, with a slightly negative tv_nsec value such as
1468 UNKNOWN_MODTIME_NSECS; in that case, the Lisp list contains a
1469 correspondingly negative picosecond count. */
1471 make_lisp_time (struct timespec t
)
1474 return make_time_tail (t
.tv_sec
, list2i (ns
/ 1000, ns
% 1000 * 1000));
1477 /* Decode a Lisp list SPECIFIED_TIME that represents a time.
1478 Set *PHIGH, *PLOW, *PUSEC, *PPSEC to its parts; do not check their values.
1479 Return true if successful. */
1481 disassemble_lisp_time (Lisp_Object specified_time
, Lisp_Object
*phigh
,
1482 Lisp_Object
*plow
, Lisp_Object
*pusec
,
1485 if (CONSP (specified_time
))
1487 Lisp_Object low
= XCDR (specified_time
);
1488 Lisp_Object usec
= make_number (0);
1489 Lisp_Object psec
= make_number (0);
1492 Lisp_Object low_tail
= XCDR (low
);
1494 if (CONSP (low_tail
))
1496 usec
= XCAR (low_tail
);
1497 low_tail
= XCDR (low_tail
);
1498 if (CONSP (low_tail
))
1499 psec
= XCAR (low_tail
);
1501 else if (!NILP (low_tail
))
1505 *phigh
= XCAR (specified_time
);
1515 /* From the time components HIGH, LOW, USEC and PSEC taken from a Lisp
1516 list, generate the corresponding time value.
1518 If RESULT is not null, store into *RESULT the converted time;
1519 this can fail if the converted time does not fit into struct timespec.
1520 If *DRESULT is not null, store into *DRESULT the number of
1521 seconds since the start of the POSIX Epoch.
1523 Return true if successful. */
1525 decode_time_components (Lisp_Object high
, Lisp_Object low
, Lisp_Object usec
,
1527 struct timespec
*result
, double *dresult
)
1529 EMACS_INT hi
, lo
, us
, ps
;
1530 if (! (INTEGERP (high
) && INTEGERP (low
)
1531 && INTEGERP (usec
) && INTEGERP (psec
)))
1538 /* Normalize out-of-range lower-order components by carrying
1539 each overflow into the next higher-order component. */
1540 us
+= ps
/ 1000000 - (ps
% 1000000 < 0);
1541 lo
+= us
/ 1000000 - (us
% 1000000 < 0);
1543 ps
= ps
% 1000000 + 1000000 * (ps
% 1000000 < 0);
1544 us
= us
% 1000000 + 1000000 * (us
% 1000000 < 0);
1545 lo
&= (1 << 16) - 1;
1549 if ((TYPE_SIGNED (time_t) ? TIME_T_MIN
>> 16 <= hi
: 0 <= hi
)
1550 && hi
<= TIME_T_MAX
>> 16)
1552 /* Return the greatest representable time that is not greater
1553 than the requested time. */
1555 *result
= make_timespec ((sec
<< 16) + lo
, us
* 1000 + ps
/ 1000);
1559 /* Overflow in the highest-order component. */
1565 *dresult
= (us
* 1e6
+ ps
) / 1e12
+ lo
+ hi
* 65536.0;
1570 /* Decode a Lisp list SPECIFIED_TIME that represents a time.
1571 If SPECIFIED_TIME is nil, use the current time.
1573 Round the time down to the nearest struct timespec value.
1574 Return seconds since the Epoch.
1575 Signal an error if unsuccessful. */
1577 lisp_time_argument (Lisp_Object specified_time
)
1580 if (NILP (specified_time
))
1581 t
= current_timespec ();
1584 Lisp_Object high
, low
, usec
, psec
;
1585 if (! (disassemble_lisp_time (specified_time
, &high
, &low
, &usec
, &psec
)
1586 && decode_time_components (high
, low
, usec
, psec
, &t
, 0)))
1587 error ("Invalid time specification");
1592 /* Like lisp_time_argument, except decode only the seconds part,
1593 do not allow out-of-range time stamps, do not check the subseconds part,
1594 and always round down. */
1596 lisp_seconds_argument (Lisp_Object specified_time
)
1598 if (NILP (specified_time
))
1602 Lisp_Object high
, low
, usec
, psec
;
1604 if (! (disassemble_lisp_time (specified_time
, &high
, &low
, &usec
, &psec
)
1605 && decode_time_components (high
, low
, make_number (0),
1606 make_number (0), &t
, 0)))
1607 error ("Invalid time specification");
1612 DEFUN ("float-time", Ffloat_time
, Sfloat_time
, 0, 1, 0,
1613 doc
: /* Return the current time, as a float number of seconds since the epoch.
1614 If SPECIFIED-TIME is given, it is the time to convert to float
1615 instead of the current time. The argument should have the form
1616 (HIGH LOW) or (HIGH LOW USEC) or (HIGH LOW USEC PSEC). Thus,
1617 you can use times from `current-time' and from `file-attributes'.
1618 SPECIFIED-TIME can also have the form (HIGH . LOW), but this is
1619 considered obsolete.
1621 WARNING: Since the result is floating point, it may not be exact.
1622 If precise time stamps are required, use either `current-time',
1623 or (if you need time as a string) `format-time-string'. */)
1624 (Lisp_Object specified_time
)
1627 if (NILP (specified_time
))
1629 struct timespec now
= current_timespec ();
1630 t
= now
.tv_sec
+ now
.tv_nsec
/ 1e9
;
1634 Lisp_Object high
, low
, usec
, psec
;
1635 if (! (disassemble_lisp_time (specified_time
, &high
, &low
, &usec
, &psec
)
1636 && decode_time_components (high
, low
, usec
, psec
, 0, &t
)))
1637 error ("Invalid time specification");
1639 return make_float (t
);
1642 /* Write information into buffer S of size MAXSIZE, according to the
1643 FORMAT of length FORMAT_LEN, using time information taken from *TP.
1644 Default to Universal Time if UT, local time otherwise.
1645 Use NS as the number of nanoseconds in the %N directive.
1646 Return the number of bytes written, not including the terminating
1647 '\0'. If S is NULL, nothing will be written anywhere; so to
1648 determine how many bytes would be written, use NULL for S and
1649 ((size_t) -1) for MAXSIZE.
1651 This function behaves like nstrftime, except it allows null
1652 bytes in FORMAT and it does not support nanoseconds. */
1654 emacs_nmemftime (char *s
, size_t maxsize
, const char *format
,
1655 size_t format_len
, const struct tm
*tp
, bool ut
, int ns
)
1659 /* Loop through all the null-terminated strings in the format
1660 argument. Normally there's just one null-terminated string, but
1661 there can be arbitrarily many, concatenated together, if the
1662 format contains '\0' bytes. nstrftime stops at the first
1663 '\0' byte so we must invoke it separately for each such string. */
1672 result
= nstrftime (s
, maxsize
, format
, tp
, ut
, ns
);
1676 if (result
== 0 && s
[0] != '\0')
1681 maxsize
-= result
+ 1;
1683 len
= strlen (format
);
1684 if (len
== format_len
)
1688 format_len
-= len
+ 1;
1692 DEFUN ("format-time-string", Fformat_time_string
, Sformat_time_string
, 1, 3, 0,
1693 doc
: /* Use FORMAT-STRING to format the time TIME, or now if omitted.
1694 TIME is specified as (HIGH LOW USEC PSEC), as returned by
1695 `current-time' or `file-attributes'. The obsolete form (HIGH . LOW)
1696 is also still accepted.
1697 The third, optional, argument UNIVERSAL, if non-nil, means describe TIME
1698 as Universal Time; nil means describe TIME in the local time zone.
1699 The value is a copy of FORMAT-STRING, but with certain constructs replaced
1700 by text that describes the specified date and time in TIME:
1702 %Y is the year, %y within the century, %C the century.
1703 %G is the year corresponding to the ISO week, %g within the century.
1704 %m is the numeric month.
1705 %b and %h are the locale's abbreviated month name, %B the full name.
1706 (%h is not supported on MS-Windows.)
1707 %d is the day of the month, zero-padded, %e is blank-padded.
1708 %u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.
1709 %a is the locale's abbreviated name of the day of week, %A the full name.
1710 %U is the week number starting on Sunday, %W starting on Monday,
1711 %V according to ISO 8601.
1712 %j is the day of the year.
1714 %H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H
1715 only blank-padded, %l is like %I blank-padded.
1716 %p is the locale's equivalent of either AM or PM.
1719 %N is the nanosecond, %6N the microsecond, %3N the millisecond, etc.
1720 %Z is the time zone name, %z is the numeric form.
1721 %s is the number of seconds since 1970-01-01 00:00:00 +0000.
1723 %c is the locale's date and time format.
1724 %x is the locale's "preferred" date format.
1725 %D is like "%m/%d/%y".
1727 %R is like "%H:%M", %T is like "%H:%M:%S", %r is like "%I:%M:%S %p".
1728 %X is the locale's "preferred" time format.
1730 Finally, %n is a newline, %t is a tab, %% is a literal %.
1732 Certain flags and modifiers are available with some format controls.
1733 The flags are `_', `-', `^' and `#'. For certain characters X,
1734 %_X is like %X, but padded with blanks; %-X is like %X,
1735 but without padding. %^X is like %X, but with all textual
1736 characters up-cased; %#X is like %X, but with letter-case of
1737 all textual characters reversed.
1738 %NX (where N stands for an integer) is like %X,
1739 but takes up at least N (a number) positions.
1740 The modifiers are `E' and `O'. For certain characters X,
1741 %EX is a locale's alternative version of %X;
1742 %OX is like %X, but uses the locale's number symbols.
1744 For example, to produce full ISO 8601 format, use "%Y-%m-%dT%T%z".
1746 usage: (format-time-string FORMAT-STRING &optional TIME UNIVERSAL) */)
1747 (Lisp_Object format_string
, Lisp_Object timeval
, Lisp_Object universal
)
1749 struct timespec t
= lisp_time_argument (timeval
);
1752 CHECK_STRING (format_string
);
1753 format_string
= code_convert_string_norecord (format_string
,
1754 Vlocale_coding_system
, 1);
1755 return format_time_string (SSDATA (format_string
), SBYTES (format_string
),
1756 t
, ! NILP (universal
), &tm
);
1760 format_time_string (char const *format
, ptrdiff_t formatlen
,
1761 struct timespec t
, bool ut
, struct tm
*tmp
)
1765 ptrdiff_t size
= sizeof buffer
;
1767 Lisp_Object bufstring
;
1774 time_t *taddr
= &t
.tv_sec
;
1777 synchronize_system_time_locale ();
1779 tm
= ut
? gmtime (taddr
) : localtime (taddr
);
1788 len
= emacs_nmemftime (buf
, size
, format
, formatlen
, tm
, ut
, ns
);
1789 if ((0 < len
&& len
< size
) || (len
== 0 && buf
[0] == '\0'))
1792 /* Buffer was too small, so make it bigger and try again. */
1793 len
= emacs_nmemftime (NULL
, SIZE_MAX
, format
, formatlen
, tm
, ut
, ns
);
1795 if (STRING_BYTES_BOUND
<= len
)
1798 buf
= SAFE_ALLOCA (size
);
1802 bufstring
= make_unibyte_string (buf
, len
);
1804 return code_convert_string_norecord (bufstring
, Vlocale_coding_system
, 0);
1807 DEFUN ("decode-time", Fdecode_time
, Sdecode_time
, 0, 1, 0,
1808 doc
: /* Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST ZONE).
1809 The optional SPECIFIED-TIME should be a list of (HIGH LOW . IGNORED),
1810 as from `current-time' and `file-attributes', or nil to use the
1811 current time. The obsolete form (HIGH . LOW) is also still accepted.
1812 The list has the following nine members: SEC is an integer between 0
1813 and 60; SEC is 60 for a leap second, which only some operating systems
1814 support. MINUTE is an integer between 0 and 59. HOUR is an integer
1815 between 0 and 23. DAY is an integer between 1 and 31. MONTH is an
1816 integer between 1 and 12. YEAR is an integer indicating the
1817 four-digit year. DOW is the day of week, an integer between 0 and 6,
1818 where 0 is Sunday. DST is t if daylight saving time is in effect,
1819 otherwise nil. ZONE is an integer indicating the number of seconds
1820 east of Greenwich. (Note that Common Lisp has different meanings for
1822 (Lisp_Object specified_time
)
1824 time_t time_spec
= lisp_seconds_argument (specified_time
);
1826 struct tm
*decoded_time
;
1827 Lisp_Object list_args
[9];
1830 decoded_time
= localtime (&time_spec
);
1832 save_tm
= *decoded_time
;
1835 && MOST_NEGATIVE_FIXNUM
- TM_YEAR_BASE
<= save_tm
.tm_year
1836 && save_tm
.tm_year
<= MOST_POSITIVE_FIXNUM
- TM_YEAR_BASE
))
1838 XSETFASTINT (list_args
[0], save_tm
.tm_sec
);
1839 XSETFASTINT (list_args
[1], save_tm
.tm_min
);
1840 XSETFASTINT (list_args
[2], save_tm
.tm_hour
);
1841 XSETFASTINT (list_args
[3], save_tm
.tm_mday
);
1842 XSETFASTINT (list_args
[4], save_tm
.tm_mon
+ 1);
1843 /* On 64-bit machines an int is narrower than EMACS_INT, thus the
1844 cast below avoids overflow in int arithmetics. */
1845 XSETINT (list_args
[5], TM_YEAR_BASE
+ (EMACS_INT
) save_tm
.tm_year
);
1846 XSETFASTINT (list_args
[6], save_tm
.tm_wday
);
1847 list_args
[7] = save_tm
.tm_isdst
? Qt
: Qnil
;
1850 decoded_time
= gmtime (&time_spec
);
1851 if (decoded_time
== 0)
1852 list_args
[8] = Qnil
;
1854 XSETINT (list_args
[8], tm_diff (&save_tm
, decoded_time
));
1856 return Flist (9, list_args
);
1859 /* Return OBJ - OFFSET, checking that OBJ is a valid fixnum and that
1860 the result is representable as an int. Assume OFFSET is small and
1863 check_tm_member (Lisp_Object obj
, int offset
)
1868 if (! (INT_MIN
+ offset
<= n
&& n
- offset
<= INT_MAX
))
1873 DEFUN ("encode-time", Fencode_time
, Sencode_time
, 6, MANY
, 0,
1874 doc
: /* Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.
1875 This is the reverse operation of `decode-time', which see.
1876 ZONE defaults to the current time zone rule. This can
1877 be a string or t (as from `set-time-zone-rule'), or it can be a list
1878 \(as from `current-time-zone') or an integer (as from `decode-time')
1879 applied without consideration for daylight saving time.
1881 You can pass more than 7 arguments; then the first six arguments
1882 are used as SECOND through YEAR, and the *last* argument is used as ZONE.
1883 The intervening arguments are ignored.
1884 This feature lets (apply 'encode-time (decode-time ...)) work.
1886 Out-of-range values for SECOND, MINUTE, HOUR, DAY, or MONTH are allowed;
1887 for example, a DAY of 0 means the day preceding the given month.
1888 Year numbers less than 100 are treated just like other year numbers.
1889 If you want them to stand for years in this century, you must do that yourself.
1891 Years before 1970 are not guaranteed to work. On some systems,
1892 year values as low as 1901 do work.
1894 usage: (encode-time SECOND MINUTE HOUR DAY MONTH YEAR &optional ZONE) */)
1895 (ptrdiff_t nargs
, Lisp_Object
*args
)
1899 Lisp_Object zone
= (nargs
> 6 ? args
[nargs
- 1] : Qnil
);
1901 tm
.tm_sec
= check_tm_member (args
[0], 0);
1902 tm
.tm_min
= check_tm_member (args
[1], 0);
1903 tm
.tm_hour
= check_tm_member (args
[2], 0);
1904 tm
.tm_mday
= check_tm_member (args
[3], 0);
1905 tm
.tm_mon
= check_tm_member (args
[4], 1);
1906 tm
.tm_year
= check_tm_member (args
[5], TM_YEAR_BASE
);
1914 value
= mktime (&tm
);
1919 static char const tzbuf_format
[] = "XXX%s%"pI
"d:%02d:%02d";
1920 char tzbuf
[sizeof tzbuf_format
+ INT_STRLEN_BOUND (EMACS_INT
)];
1922 const char *tzstring
;
1927 else if (STRINGP (zone
))
1928 tzstring
= SSDATA (zone
);
1929 else if (INTEGERP (zone
))
1931 EMACS_INT abszone
= eabs (XINT (zone
));
1932 EMACS_INT zone_hr
= abszone
/ (60*60);
1933 int zone_min
= (abszone
/60) % 60;
1934 int zone_sec
= abszone
% 60;
1935 sprintf (tzbuf
, tzbuf_format
, &"-"[XINT (zone
) < 0],
1936 zone_hr
, zone_min
, zone_sec
);
1940 error ("Invalid time zone specification");
1942 old_tzstring
= getenv ("TZ");
1945 char *buf
= SAFE_ALLOCA (strlen (old_tzstring
) + 1);
1946 old_tzstring
= strcpy (buf
, old_tzstring
);
1951 /* Set TZ before calling mktime; merely adjusting mktime's returned
1952 value doesn't suffice, since that would mishandle leap seconds. */
1953 set_time_zone_rule (tzstring
);
1955 value
= mktime (&tm
);
1957 set_time_zone_rule (old_tzstring
);
1958 #ifdef LOCALTIME_CACHE
1965 if (value
== (time_t) -1)
1968 return make_time (value
);
1971 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
, 0, 1, 0,
1972 doc
: /* Return the current local time, as a human-readable string.
1973 Programs can use this function to decode a time,
1974 since the number of columns in each field is fixed
1975 if the year is in the range 1000-9999.
1976 The format is `Sun Sep 16 01:03:52 1973'.
1977 However, see also the functions `decode-time' and `format-time-string'
1978 which provide a much more powerful and general facility.
1980 If SPECIFIED-TIME is given, it is a time to format instead of the
1981 current time. The argument should have the form (HIGH LOW . IGNORED).
1982 Thus, you can use times obtained from `current-time' and from
1983 `file-attributes'. SPECIFIED-TIME can also have the form (HIGH . LOW),
1984 but this is considered obsolete. */)
1985 (Lisp_Object specified_time
)
1987 time_t value
= lisp_seconds_argument (specified_time
);
1989 char buf
[sizeof "Mon Apr 30 12:49:17 " + INT_STRLEN_BOUND (int) + 1];
1990 int len
IF_LINT (= 0);
1992 /* Convert to a string in ctime format, except without the trailing
1993 newline, and without the 4-digit year limit. Don't use asctime
1994 or ctime, as they might dump core if the year is outside the
1995 range -999 .. 9999. */
1997 tm
= localtime (&value
);
2000 static char const wday_name
[][4] =
2001 { "Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat" };
2002 static char const mon_name
[][4] =
2003 { "Jan", "Feb", "Mar", "Apr", "May", "Jun",
2004 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" };
2005 printmax_t year_base
= TM_YEAR_BASE
;
2007 len
= sprintf (buf
, "%s %s%3d %02d:%02d:%02d %"pMd
,
2008 wday_name
[tm
->tm_wday
], mon_name
[tm
->tm_mon
], tm
->tm_mday
,
2009 tm
->tm_hour
, tm
->tm_min
, tm
->tm_sec
,
2010 tm
->tm_year
+ year_base
);
2016 return make_unibyte_string (buf
, len
);
2019 /* Yield A - B, measured in seconds.
2020 This function is copied from the GNU C Library. */
2022 tm_diff (struct tm
*a
, struct tm
*b
)
2024 /* Compute intervening leap days correctly even if year is negative.
2025 Take care to avoid int overflow in leap day calculations,
2026 but it's OK to assume that A and B are close to each other. */
2027 int a4
= (a
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (a
->tm_year
& 3);
2028 int b4
= (b
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (b
->tm_year
& 3);
2029 int a100
= a4
/ 25 - (a4
% 25 < 0);
2030 int b100
= b4
/ 25 - (b4
% 25 < 0);
2031 int a400
= a100
>> 2;
2032 int b400
= b100
>> 2;
2033 int intervening_leap_days
= (a4
- b4
) - (a100
- b100
) + (a400
- b400
);
2034 int years
= a
->tm_year
- b
->tm_year
;
2035 int days
= (365 * years
+ intervening_leap_days
2036 + (a
->tm_yday
- b
->tm_yday
));
2037 return (60 * (60 * (24 * days
+ (a
->tm_hour
- b
->tm_hour
))
2038 + (a
->tm_min
- b
->tm_min
))
2039 + (a
->tm_sec
- b
->tm_sec
));
2042 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 1, 0,
2043 doc
: /* Return the offset and name for the local time zone.
2044 This returns a list of the form (OFFSET NAME).
2045 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).
2046 A negative value means west of Greenwich.
2047 NAME is a string giving the name of the time zone.
2048 If SPECIFIED-TIME is given, the time zone offset is determined from it
2049 instead of using the current time. The argument should have the form
2050 (HIGH LOW . IGNORED). Thus, you can use times obtained from
2051 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
2052 have the form (HIGH . LOW), but this is considered obsolete.
2054 Some operating systems cannot provide all this information to Emacs;
2055 in this case, `current-time-zone' returns a list containing nil for
2056 the data it can't find. */)
2057 (Lisp_Object specified_time
)
2059 struct timespec value
;
2063 Lisp_Object zone_offset
, zone_name
;
2066 value
= make_timespec (lisp_seconds_argument (specified_time
), 0);
2067 zone_name
= format_time_string ("%Z", sizeof "%Z" - 1, value
, 0, &localtm
);
2069 t
= gmtime (&value
.tv_sec
);
2071 offset
= tm_diff (&localtm
, t
);
2076 zone_offset
= make_number (offset
);
2077 if (SCHARS (zone_name
) == 0)
2079 /* No local time zone name is available; use "+-NNNN" instead. */
2080 int m
= offset
/ 60;
2081 int am
= offset
< 0 ? - m
: m
;
2082 char buf
[sizeof "+00" + INT_STRLEN_BOUND (int)];
2083 zone_name
= make_formatted_string (buf
, "%c%02d%02d",
2084 (offset
< 0 ? '-' : '+'),
2089 return list2 (zone_offset
, zone_name
);
2092 DEFUN ("set-time-zone-rule", Fset_time_zone_rule
, Sset_time_zone_rule
, 1, 1, 0,
2093 doc
: /* Set the local time zone using TZ, a string specifying a time zone rule.
2094 If TZ is nil, use implementation-defined default time zone information.
2095 If TZ is t, use Universal Time.
2097 Instead of calling this function, you typically want (setenv "TZ" TZ).
2098 That changes both the environment of the Emacs process and the
2099 variable `process-environment', whereas `set-time-zone-rule' affects
2100 only the former. */)
2103 const char *tzstring
;
2105 if (! (NILP (tz
) || EQ (tz
, Qt
)))
2109 tzstring
= initial_tz
;
2110 else if (EQ (tz
, Qt
))
2113 tzstring
= SSDATA (tz
);
2116 set_time_zone_rule (tzstring
);
2122 /* Set the local time zone rule to TZSTRING.
2124 This function is not thread-safe, partly because putenv, unsetenv
2125 and tzset are not, and partly because of the static storage it
2126 updates. Other threads that invoke localtime etc. may be adversely
2127 affected while this function is executing. */
2130 set_time_zone_rule (const char *tzstring
)
2132 /* A buffer holding a string of the form "TZ=value", intended
2133 to be part of the environment. */
2134 static char *tzvalbuf
;
2135 static ptrdiff_t tzvalbufsize
;
2137 int tzeqlen
= sizeof "TZ=" - 1;
2139 #ifdef LOCALTIME_CACHE
2140 /* These two values are known to load tz files in buggy implementations,
2141 i.e., Solaris 1 executables running under either Solaris 1 or Solaris 2.
2142 Their values shouldn't matter in non-buggy implementations.
2143 We don't use string literals for these strings,
2144 since if a string in the environment is in readonly
2145 storage, it runs afoul of bugs in SVR4 and Solaris 2.3.
2146 See Sun bugs 1113095 and 1114114, ``Timezone routines
2147 improperly modify environment''. */
2149 static char set_time_zone_rule_tz
[][sizeof "TZ=GMT+0"]
2150 = { "TZ=GMT+0", "TZ=GMT+1" };
2152 /* In SunOS 4.1.3_U1 and 4.1.4, if TZ has a value like
2153 "US/Pacific" that loads a tz file, then changes to a value like
2154 "XXX0" that does not load a tz file, and then changes back to
2155 its original value, the last change is (incorrectly) ignored.
2156 Also, if TZ changes twice in succession to values that do
2157 not load a tz file, tzset can dump core (see Sun bug#1225179).
2158 The following code works around these bugs. */
2162 /* Temporarily set TZ to a value that loads a tz file
2163 and that differs from tzstring. */
2164 bool eq0
= strcmp (tzstring
, set_time_zone_rule_tz
[0] + tzeqlen
) == 0;
2165 xputenv (set_time_zone_rule_tz
[eq0
]);
2169 /* The implied tzstring is unknown, so temporarily set TZ to
2170 two different values that each load a tz file. */
2171 xputenv (set_time_zone_rule_tz
[0]);
2173 xputenv (set_time_zone_rule_tz
[1]);
2176 tzvalbuf_in_environ
= 0;
2182 tzvalbuf_in_environ
= 0;
2186 ptrdiff_t tzstringlen
= strlen (tzstring
);
2188 if (tzvalbufsize
<= tzeqlen
+ tzstringlen
)
2191 tzvalbuf_in_environ
= 0;
2192 tzvalbuf
= xpalloc (tzvalbuf
, &tzvalbufsize
,
2193 tzeqlen
+ tzstringlen
- tzvalbufsize
+ 1, -1, 1);
2194 memcpy (tzvalbuf
, "TZ=", tzeqlen
);
2197 strcpy (tzvalbuf
+ tzeqlen
, tzstring
);
2199 if (!tzvalbuf_in_environ
)
2202 tzvalbuf_in_environ
= 1;
2206 #ifdef LOCALTIME_CACHE
2211 /* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC
2212 (if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a
2213 type of object is Lisp_String). INHERIT is passed to
2214 INSERT_FROM_STRING_FUNC as the last argument. */
2217 general_insert_function (void (*insert_func
)
2218 (const char *, ptrdiff_t),
2219 void (*insert_from_string_func
)
2220 (Lisp_Object
, ptrdiff_t, ptrdiff_t,
2221 ptrdiff_t, ptrdiff_t, bool),
2222 bool inherit
, ptrdiff_t nargs
, Lisp_Object
*args
)
2227 for (argnum
= 0; argnum
< nargs
; argnum
++)
2230 if (CHARACTERP (val
))
2232 int c
= XFASTINT (val
);
2233 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2236 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2237 len
= CHAR_STRING (c
, str
);
2240 str
[0] = ASCII_CHAR_P (c
) ? c
: multibyte_char_to_unibyte (c
);
2243 (*insert_func
) ((char *) str
, len
);
2245 else if (STRINGP (val
))
2247 (*insert_from_string_func
) (val
, 0, 0,
2253 wrong_type_argument (Qchar_or_string_p
, val
);
2258 insert1 (Lisp_Object arg
)
2264 /* Callers passing one argument to Finsert need not gcpro the
2265 argument "array", since the only element of the array will
2266 not be used after calling insert or insert_from_string, so
2267 we don't care if it gets trashed. */
2269 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
2270 doc
: /* Insert the arguments, either strings or characters, at point.
2271 Point and before-insertion markers move forward to end up
2272 after the inserted text.
2273 Any other markers at the point of insertion remain before the text.
2275 If the current buffer is multibyte, unibyte strings are converted
2276 to multibyte for insertion (see `string-make-multibyte').
2277 If the current buffer is unibyte, multibyte strings are converted
2278 to unibyte for insertion (see `string-make-unibyte').
2280 When operating on binary data, it may be necessary to preserve the
2281 original bytes of a unibyte string when inserting it into a multibyte
2282 buffer; to accomplish this, apply `string-as-multibyte' to the string
2283 and insert the result.
2285 usage: (insert &rest ARGS) */)
2286 (ptrdiff_t nargs
, Lisp_Object
*args
)
2288 general_insert_function (insert
, insert_from_string
, 0, nargs
, args
);
2292 DEFUN ("insert-and-inherit", Finsert_and_inherit
, Sinsert_and_inherit
,
2294 doc
: /* Insert the arguments at point, inheriting properties from adjoining text.
2295 Point and before-insertion markers move forward to end up
2296 after the inserted text.
2297 Any other markers at the point of insertion remain before the text.
2299 If the current buffer is multibyte, unibyte strings are converted
2300 to multibyte for insertion (see `unibyte-char-to-multibyte').
2301 If the current buffer is unibyte, multibyte strings are converted
2302 to unibyte for insertion.
2304 usage: (insert-and-inherit &rest ARGS) */)
2305 (ptrdiff_t nargs
, Lisp_Object
*args
)
2307 general_insert_function (insert_and_inherit
, insert_from_string
, 1,
2312 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
2313 doc
: /* Insert strings or characters at point, relocating markers after the text.
2314 Point and markers move forward to end up after the inserted text.
2316 If the current buffer is multibyte, unibyte strings are converted
2317 to multibyte for insertion (see `unibyte-char-to-multibyte').
2318 If the current buffer is unibyte, multibyte strings are converted
2319 to unibyte for insertion.
2321 If an overlay begins at the insertion point, the inserted text falls
2322 outside the overlay; if a nonempty overlay ends at the insertion
2323 point, the inserted text falls inside that overlay.
2325 usage: (insert-before-markers &rest ARGS) */)
2326 (ptrdiff_t nargs
, Lisp_Object
*args
)
2328 general_insert_function (insert_before_markers
,
2329 insert_from_string_before_markers
, 0,
2334 DEFUN ("insert-before-markers-and-inherit", Finsert_and_inherit_before_markers
,
2335 Sinsert_and_inherit_before_markers
, 0, MANY
, 0,
2336 doc
: /* Insert text at point, relocating markers and inheriting properties.
2337 Point and markers move forward to end up after the inserted text.
2339 If the current buffer is multibyte, unibyte strings are converted
2340 to multibyte for insertion (see `unibyte-char-to-multibyte').
2341 If the current buffer is unibyte, multibyte strings are converted
2342 to unibyte for insertion.
2344 usage: (insert-before-markers-and-inherit &rest ARGS) */)
2345 (ptrdiff_t nargs
, Lisp_Object
*args
)
2347 general_insert_function (insert_before_markers_and_inherit
,
2348 insert_from_string_before_markers
, 1,
2353 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 1, 3,
2354 "(list (read-char-by-name \"Insert character (Unicode name or hex): \")\
2355 (prefix-numeric-value current-prefix-arg)\
2357 doc
: /* Insert COUNT copies of CHARACTER.
2358 Interactively, prompt for CHARACTER. You can specify CHARACTER in one
2361 - As its Unicode character name, e.g. \"LATIN SMALL LETTER A\".
2362 Completion is available; if you type a substring of the name
2363 preceded by an asterisk `*', Emacs shows all names which include
2364 that substring, not necessarily at the beginning of the name.
2366 - As a hexadecimal code point, e.g. 263A. Note that code points in
2367 Emacs are equivalent to Unicode up to 10FFFF (which is the limit of
2368 the Unicode code space).
2370 - As a code point with a radix specified with #, e.g. #o21430
2371 (octal), #x2318 (hex), or #10r8984 (decimal).
2373 If called interactively, COUNT is given by the prefix argument. If
2374 omitted or nil, it defaults to 1.
2376 Inserting the character(s) relocates point and before-insertion
2377 markers in the same ways as the function `insert'.
2379 The optional third argument INHERIT, if non-nil, says to inherit text
2380 properties from adjoining text, if those properties are sticky. If
2381 called interactively, INHERIT is t. */)
2382 (Lisp_Object character
, Lisp_Object count
, Lisp_Object inherit
)
2385 register ptrdiff_t n
;
2387 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2390 CHECK_CHARACTER (character
);
2392 XSETFASTINT (count
, 1);
2393 CHECK_NUMBER (count
);
2394 c
= XFASTINT (character
);
2396 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2397 len
= CHAR_STRING (c
, str
);
2399 str
[0] = c
, len
= 1;
2400 if (XINT (count
) <= 0)
2402 if (BUF_BYTES_MAX
/ len
< XINT (count
))
2404 n
= XINT (count
) * len
;
2405 stringlen
= min (n
, sizeof string
- sizeof string
% len
);
2406 for (i
= 0; i
< stringlen
; i
++)
2407 string
[i
] = str
[i
% len
];
2408 while (n
> stringlen
)
2411 if (!NILP (inherit
))
2412 insert_and_inherit (string
, stringlen
);
2414 insert (string
, stringlen
);
2417 if (!NILP (inherit
))
2418 insert_and_inherit (string
, n
);
2424 DEFUN ("insert-byte", Finsert_byte
, Sinsert_byte
, 2, 3, 0,
2425 doc
: /* Insert COUNT (second arg) copies of BYTE (first arg).
2426 Both arguments are required.
2427 BYTE is a number of the range 0..255.
2429 If BYTE is 128..255 and the current buffer is multibyte, the
2430 corresponding eight-bit character is inserted.
2432 Point, and before-insertion markers, are relocated as in the function `insert'.
2433 The optional third arg INHERIT, if non-nil, says to inherit text properties
2434 from adjoining text, if those properties are sticky. */)
2435 (Lisp_Object byte
, Lisp_Object count
, Lisp_Object inherit
)
2437 CHECK_NUMBER (byte
);
2438 if (XINT (byte
) < 0 || XINT (byte
) > 255)
2439 args_out_of_range_3 (byte
, make_number (0), make_number (255));
2440 if (XINT (byte
) >= 128
2441 && ! NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2442 XSETFASTINT (byte
, BYTE8_TO_CHAR (XINT (byte
)));
2443 return Finsert_char (byte
, count
, inherit
);
2447 /* Making strings from buffer contents. */
2449 /* Return a Lisp_String containing the text of the current buffer from
2450 START to END. If text properties are in use and the current buffer
2451 has properties in the range specified, the resulting string will also
2452 have them, if PROPS is true.
2454 We don't want to use plain old make_string here, because it calls
2455 make_uninit_string, which can cause the buffer arena to be
2456 compacted. make_string has no way of knowing that the data has
2457 been moved, and thus copies the wrong data into the string. This
2458 doesn't effect most of the other users of make_string, so it should
2459 be left as is. But we should use this function when conjuring
2460 buffer substrings. */
2463 make_buffer_string (ptrdiff_t start
, ptrdiff_t end
, bool props
)
2465 ptrdiff_t start_byte
= CHAR_TO_BYTE (start
);
2466 ptrdiff_t end_byte
= CHAR_TO_BYTE (end
);
2468 return make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
);
2471 /* Return a Lisp_String containing the text of the current buffer from
2472 START / START_BYTE to END / END_BYTE.
2474 If text properties are in use and the current buffer
2475 has properties in the range specified, the resulting string will also
2476 have them, if PROPS is true.
2478 We don't want to use plain old make_string here, because it calls
2479 make_uninit_string, which can cause the buffer arena to be
2480 compacted. make_string has no way of knowing that the data has
2481 been moved, and thus copies the wrong data into the string. This
2482 doesn't effect most of the other users of make_string, so it should
2483 be left as is. But we should use this function when conjuring
2484 buffer substrings. */
2487 make_buffer_string_both (ptrdiff_t start
, ptrdiff_t start_byte
,
2488 ptrdiff_t end
, ptrdiff_t end_byte
, bool props
)
2490 Lisp_Object result
, tem
, tem1
;
2492 if (start
< GPT
&& GPT
< end
)
2493 move_gap_both (start
, start_byte
);
2495 if (! NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2496 result
= make_uninit_multibyte_string (end
- start
, end_byte
- start_byte
);
2498 result
= make_uninit_string (end
- start
);
2499 memcpy (SDATA (result
), BYTE_POS_ADDR (start_byte
), end_byte
- start_byte
);
2501 /* If desired, update and copy the text properties. */
2504 update_buffer_properties (start
, end
);
2506 tem
= Fnext_property_change (make_number (start
), Qnil
, make_number (end
));
2507 tem1
= Ftext_properties_at (make_number (start
), Qnil
);
2509 if (XINT (tem
) != end
|| !NILP (tem1
))
2510 copy_intervals_to_string (result
, current_buffer
, start
,
2517 /* Call Vbuffer_access_fontify_functions for the range START ... END
2518 in the current buffer, if necessary. */
2521 update_buffer_properties (ptrdiff_t start
, ptrdiff_t end
)
2523 /* If this buffer has some access functions,
2524 call them, specifying the range of the buffer being accessed. */
2525 if (!NILP (Vbuffer_access_fontify_functions
))
2527 Lisp_Object args
[3];
2530 args
[0] = Qbuffer_access_fontify_functions
;
2531 XSETINT (args
[1], start
);
2532 XSETINT (args
[2], end
);
2534 /* But don't call them if we can tell that the work
2535 has already been done. */
2536 if (!NILP (Vbuffer_access_fontified_property
))
2538 tem
= Ftext_property_any (args
[1], args
[2],
2539 Vbuffer_access_fontified_property
,
2542 Frun_hook_with_args (3, args
);
2545 Frun_hook_with_args (3, args
);
2549 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
2550 doc
: /* Return the contents of part of the current buffer as a string.
2551 The two arguments START and END are character positions;
2552 they can be in either order.
2553 The string returned is multibyte if the buffer is multibyte.
2555 This function copies the text properties of that part of the buffer
2556 into the result string; if you don't want the text properties,
2557 use `buffer-substring-no-properties' instead. */)
2558 (Lisp_Object start
, Lisp_Object end
)
2560 register ptrdiff_t b
, e
;
2562 validate_region (&start
, &end
);
2566 return make_buffer_string (b
, e
, 1);
2569 DEFUN ("buffer-substring-no-properties", Fbuffer_substring_no_properties
,
2570 Sbuffer_substring_no_properties
, 2, 2, 0,
2571 doc
: /* Return the characters of part of the buffer, without the text properties.
2572 The two arguments START and END are character positions;
2573 they can be in either order. */)
2574 (Lisp_Object start
, Lisp_Object end
)
2576 register ptrdiff_t b
, e
;
2578 validate_region (&start
, &end
);
2582 return make_buffer_string (b
, e
, 0);
2585 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
2586 doc
: /* Return the contents of the current buffer as a string.
2587 If narrowing is in effect, this function returns only the visible part
2591 return make_buffer_string_both (BEGV
, BEGV_BYTE
, ZV
, ZV_BYTE
, 1);
2594 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
2596 doc
: /* Insert before point a substring of the contents of BUFFER.
2597 BUFFER may be a buffer or a buffer name.
2598 Arguments START and END are character positions specifying the substring.
2599 They default to the values of (point-min) and (point-max) in BUFFER. */)
2600 (Lisp_Object buffer
, Lisp_Object start
, Lisp_Object end
)
2602 register EMACS_INT b
, e
, temp
;
2603 register struct buffer
*bp
, *obuf
;
2606 buf
= Fget_buffer (buffer
);
2610 if (!BUFFER_LIVE_P (bp
))
2611 error ("Selecting deleted buffer");
2617 CHECK_NUMBER_COERCE_MARKER (start
);
2624 CHECK_NUMBER_COERCE_MARKER (end
);
2629 temp
= b
, b
= e
, e
= temp
;
2631 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
2632 args_out_of_range (start
, end
);
2634 obuf
= current_buffer
;
2635 set_buffer_internal_1 (bp
);
2636 update_buffer_properties (b
, e
);
2637 set_buffer_internal_1 (obuf
);
2639 insert_from_buffer (bp
, b
, e
- b
, 0);
2643 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
2645 doc
: /* Compare two substrings of two buffers; return result as number.
2646 Return -N if first string is less after N-1 chars, +N if first string is
2647 greater after N-1 chars, or 0 if strings match. Each substring is
2648 represented as three arguments: BUFFER, START and END. That makes six
2649 args in all, three for each substring.
2651 The value of `case-fold-search' in the current buffer
2652 determines whether case is significant or ignored. */)
2653 (Lisp_Object buffer1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object buffer2
, Lisp_Object start2
, Lisp_Object end2
)
2655 register EMACS_INT begp1
, endp1
, begp2
, endp2
, temp
;
2656 register struct buffer
*bp1
, *bp2
;
2657 register Lisp_Object trt
2658 = (!NILP (BVAR (current_buffer
, case_fold_search
))
2659 ? BVAR (current_buffer
, case_canon_table
) : Qnil
);
2660 ptrdiff_t chars
= 0;
2661 ptrdiff_t i1
, i2
, i1_byte
, i2_byte
;
2663 /* Find the first buffer and its substring. */
2666 bp1
= current_buffer
;
2670 buf1
= Fget_buffer (buffer1
);
2673 bp1
= XBUFFER (buf1
);
2674 if (!BUFFER_LIVE_P (bp1
))
2675 error ("Selecting deleted buffer");
2679 begp1
= BUF_BEGV (bp1
);
2682 CHECK_NUMBER_COERCE_MARKER (start1
);
2683 begp1
= XINT (start1
);
2686 endp1
= BUF_ZV (bp1
);
2689 CHECK_NUMBER_COERCE_MARKER (end1
);
2690 endp1
= XINT (end1
);
2694 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
2696 if (!(BUF_BEGV (bp1
) <= begp1
2698 && endp1
<= BUF_ZV (bp1
)))
2699 args_out_of_range (start1
, end1
);
2701 /* Likewise for second substring. */
2704 bp2
= current_buffer
;
2708 buf2
= Fget_buffer (buffer2
);
2711 bp2
= XBUFFER (buf2
);
2712 if (!BUFFER_LIVE_P (bp2
))
2713 error ("Selecting deleted buffer");
2717 begp2
= BUF_BEGV (bp2
);
2720 CHECK_NUMBER_COERCE_MARKER (start2
);
2721 begp2
= XINT (start2
);
2724 endp2
= BUF_ZV (bp2
);
2727 CHECK_NUMBER_COERCE_MARKER (end2
);
2728 endp2
= XINT (end2
);
2732 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
2734 if (!(BUF_BEGV (bp2
) <= begp2
2736 && endp2
<= BUF_ZV (bp2
)))
2737 args_out_of_range (start2
, end2
);
2741 i1_byte
= buf_charpos_to_bytepos (bp1
, i1
);
2742 i2_byte
= buf_charpos_to_bytepos (bp2
, i2
);
2744 while (i1
< endp1
&& i2
< endp2
)
2746 /* When we find a mismatch, we must compare the
2747 characters, not just the bytes. */
2752 if (! NILP (BVAR (bp1
, enable_multibyte_characters
)))
2754 c1
= BUF_FETCH_MULTIBYTE_CHAR (bp1
, i1_byte
);
2755 BUF_INC_POS (bp1
, i1_byte
);
2760 c1
= BUF_FETCH_BYTE (bp1
, i1
);
2761 MAKE_CHAR_MULTIBYTE (c1
);
2765 if (! NILP (BVAR (bp2
, enable_multibyte_characters
)))
2767 c2
= BUF_FETCH_MULTIBYTE_CHAR (bp2
, i2_byte
);
2768 BUF_INC_POS (bp2
, i2_byte
);
2773 c2
= BUF_FETCH_BYTE (bp2
, i2
);
2774 MAKE_CHAR_MULTIBYTE (c2
);
2780 c1
= char_table_translate (trt
, c1
);
2781 c2
= char_table_translate (trt
, c2
);
2784 return make_number (- 1 - chars
);
2786 return make_number (chars
+ 1);
2791 /* The strings match as far as they go.
2792 If one is shorter, that one is less. */
2793 if (chars
< endp1
- begp1
)
2794 return make_number (chars
+ 1);
2795 else if (chars
< endp2
- begp2
)
2796 return make_number (- chars
- 1);
2798 /* Same length too => they are equal. */
2799 return make_number (0);
2803 subst_char_in_region_unwind (Lisp_Object arg
)
2805 bset_undo_list (current_buffer
, arg
);
2809 subst_char_in_region_unwind_1 (Lisp_Object arg
)
2811 bset_filename (current_buffer
, arg
);
2814 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
2815 Ssubst_char_in_region
, 4, 5, 0,
2816 doc
: /* From START to END, replace FROMCHAR with TOCHAR each time it occurs.
2817 If optional arg NOUNDO is non-nil, don't record this change for undo
2818 and don't mark the buffer as really changed.
2819 Both characters must have the same length of multi-byte form. */)
2820 (Lisp_Object start
, Lisp_Object end
, Lisp_Object fromchar
, Lisp_Object tochar
, Lisp_Object noundo
)
2822 register ptrdiff_t pos
, pos_byte
, stop
, i
, len
, end_byte
;
2823 /* Keep track of the first change in the buffer:
2824 if 0 we haven't found it yet.
2825 if < 0 we've found it and we've run the before-change-function.
2826 if > 0 we've actually performed it and the value is its position. */
2827 ptrdiff_t changed
= 0;
2828 unsigned char fromstr
[MAX_MULTIBYTE_LENGTH
], tostr
[MAX_MULTIBYTE_LENGTH
];
2830 ptrdiff_t count
= SPECPDL_INDEX ();
2831 #define COMBINING_NO 0
2832 #define COMBINING_BEFORE 1
2833 #define COMBINING_AFTER 2
2834 #define COMBINING_BOTH (COMBINING_BEFORE | COMBINING_AFTER)
2835 int maybe_byte_combining
= COMBINING_NO
;
2836 ptrdiff_t last_changed
= 0;
2838 = !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
2843 validate_region (&start
, &end
);
2844 CHECK_CHARACTER (fromchar
);
2845 CHECK_CHARACTER (tochar
);
2846 fromc
= XFASTINT (fromchar
);
2847 toc
= XFASTINT (tochar
);
2851 len
= CHAR_STRING (fromc
, fromstr
);
2852 if (CHAR_STRING (toc
, tostr
) != len
)
2853 error ("Characters in `subst-char-in-region' have different byte-lengths");
2854 if (!ASCII_BYTE_P (*tostr
))
2856 /* If *TOSTR is in the range 0x80..0x9F and TOCHAR is not a
2857 complete multibyte character, it may be combined with the
2858 after bytes. If it is in the range 0xA0..0xFF, it may be
2859 combined with the before and after bytes. */
2860 if (!CHAR_HEAD_P (*tostr
))
2861 maybe_byte_combining
= COMBINING_BOTH
;
2862 else if (BYTES_BY_CHAR_HEAD (*tostr
) > len
)
2863 maybe_byte_combining
= COMBINING_AFTER
;
2874 pos_byte
= CHAR_TO_BYTE (pos
);
2875 stop
= CHAR_TO_BYTE (XINT (end
));
2878 /* If we don't want undo, turn off putting stuff on the list.
2879 That's faster than getting rid of things,
2880 and it prevents even the entry for a first change.
2881 Also inhibit locking the file. */
2882 if (!changed
&& !NILP (noundo
))
2884 record_unwind_protect (subst_char_in_region_unwind
,
2885 BVAR (current_buffer
, undo_list
));
2886 bset_undo_list (current_buffer
, Qt
);
2887 /* Don't do file-locking. */
2888 record_unwind_protect (subst_char_in_region_unwind_1
,
2889 BVAR (current_buffer
, filename
));
2890 bset_filename (current_buffer
, Qnil
);
2893 if (pos_byte
< GPT_BYTE
)
2894 stop
= min (stop
, GPT_BYTE
);
2897 ptrdiff_t pos_byte_next
= pos_byte
;
2899 if (pos_byte
>= stop
)
2901 if (pos_byte
>= end_byte
) break;
2904 p
= BYTE_POS_ADDR (pos_byte
);
2906 INC_POS (pos_byte_next
);
2909 if (pos_byte_next
- pos_byte
== len
2910 && p
[0] == fromstr
[0]
2912 || (p
[1] == fromstr
[1]
2913 && (len
== 2 || (p
[2] == fromstr
[2]
2914 && (len
== 3 || p
[3] == fromstr
[3]))))))
2917 /* We've already seen this and run the before-change-function;
2918 this time we only need to record the actual position. */
2923 modify_text (pos
, XINT (end
));
2925 if (! NILP (noundo
))
2927 if (MODIFF
- 1 == SAVE_MODIFF
)
2929 if (MODIFF
- 1 == BUF_AUTOSAVE_MODIFF (current_buffer
))
2930 BUF_AUTOSAVE_MODIFF (current_buffer
)++;
2933 /* The before-change-function may have moved the gap
2934 or even modified the buffer so we should start over. */
2938 /* Take care of the case where the new character
2939 combines with neighboring bytes. */
2940 if (maybe_byte_combining
2941 && (maybe_byte_combining
== COMBINING_AFTER
2942 ? (pos_byte_next
< Z_BYTE
2943 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2944 : ((pos_byte_next
< Z_BYTE
2945 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2946 || (pos_byte
> BEG_BYTE
2947 && ! ASCII_BYTE_P (FETCH_BYTE (pos_byte
- 1))))))
2949 Lisp_Object tem
, string
;
2951 struct gcpro gcpro1
;
2953 tem
= BVAR (current_buffer
, undo_list
);
2956 /* Make a multibyte string containing this single character. */
2957 string
= make_multibyte_string ((char *) tostr
, 1, len
);
2958 /* replace_range is less efficient, because it moves the gap,
2959 but it handles combining correctly. */
2960 replace_range (pos
, pos
+ 1, string
,
2962 pos_byte_next
= CHAR_TO_BYTE (pos
);
2963 if (pos_byte_next
> pos_byte
)
2964 /* Before combining happened. We should not increment
2965 POS. So, to cancel the later increment of POS,
2969 INC_POS (pos_byte_next
);
2971 if (! NILP (noundo
))
2972 bset_undo_list (current_buffer
, tem
);
2979 record_change (pos
, 1);
2980 for (i
= 0; i
< len
; i
++) *p
++ = tostr
[i
];
2982 last_changed
= pos
+ 1;
2984 pos_byte
= pos_byte_next
;
2990 signal_after_change (changed
,
2991 last_changed
- changed
, last_changed
- changed
);
2992 update_compositions (changed
, last_changed
, CHECK_ALL
);
2995 unbind_to (count
, Qnil
);
3000 static Lisp_Object
check_translation (ptrdiff_t, ptrdiff_t, ptrdiff_t,
3003 /* Helper function for Ftranslate_region_internal.
3005 Check if a character sequence at POS (POS_BYTE) matches an element
3006 of VAL. VAL is a list (([FROM-CHAR ...] . TO) ...). If a matching
3007 element is found, return it. Otherwise return Qnil. */
3010 check_translation (ptrdiff_t pos
, ptrdiff_t pos_byte
, ptrdiff_t end
,
3013 int buf_size
= 16, buf_used
= 0;
3014 int *buf
= alloca (sizeof (int) * buf_size
);
3016 for (; CONSP (val
); val
= XCDR (val
))
3025 if (! VECTORP (elt
))
3028 if (len
<= end
- pos
)
3030 for (i
= 0; i
< len
; i
++)
3034 unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
3037 if (buf_used
== buf_size
)
3042 newbuf
= alloca (sizeof (int) * buf_size
);
3043 memcpy (newbuf
, buf
, sizeof (int) * buf_used
);
3046 buf
[buf_used
++] = STRING_CHAR_AND_LENGTH (p
, len1
);
3049 if (XINT (AREF (elt
, i
)) != buf
[i
])
3060 DEFUN ("translate-region-internal", Ftranslate_region_internal
,
3061 Stranslate_region_internal
, 3, 3, 0,
3062 doc
: /* Internal use only.
3063 From START to END, translate characters according to TABLE.
3064 TABLE is a string or a char-table; the Nth character in it is the
3065 mapping for the character with code N.
3066 It returns the number of characters changed. */)
3067 (Lisp_Object start
, Lisp_Object end
, register Lisp_Object table
)
3069 register unsigned char *tt
; /* Trans table. */
3070 register int nc
; /* New character. */
3071 int cnt
; /* Number of changes made. */
3072 ptrdiff_t size
; /* Size of translate table. */
3073 ptrdiff_t pos
, pos_byte
, end_pos
;
3074 bool multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3075 bool string_multibyte
IF_LINT (= 0);
3077 validate_region (&start
, &end
);
3078 if (CHAR_TABLE_P (table
))
3080 if (! EQ (XCHAR_TABLE (table
)->purpose
, Qtranslation_table
))
3081 error ("Not a translation table");
3087 CHECK_STRING (table
);
3089 if (! multibyte
&& (SCHARS (table
) < SBYTES (table
)))
3090 table
= string_make_unibyte (table
);
3091 string_multibyte
= SCHARS (table
) < SBYTES (table
);
3092 size
= SBYTES (table
);
3097 pos_byte
= CHAR_TO_BYTE (pos
);
3098 end_pos
= XINT (end
);
3099 modify_text (pos
, end_pos
);
3102 for (; pos
< end_pos
; )
3104 register unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
3105 unsigned char *str
, buf
[MAX_MULTIBYTE_LENGTH
];
3111 oc
= STRING_CHAR_AND_LENGTH (p
, len
);
3118 /* Reload as signal_after_change in last iteration may GC. */
3120 if (string_multibyte
)
3122 str
= tt
+ string_char_to_byte (table
, oc
);
3123 nc
= STRING_CHAR_AND_LENGTH (str
, str_len
);
3128 if (! ASCII_BYTE_P (nc
) && multibyte
)
3130 str_len
= BYTE8_STRING (nc
, buf
);
3143 val
= CHAR_TABLE_REF (table
, oc
);
3144 if (CHARACTERP (val
))
3146 nc
= XFASTINT (val
);
3147 str_len
= CHAR_STRING (nc
, buf
);
3150 else if (VECTORP (val
) || (CONSP (val
)))
3152 /* VAL is [TO_CHAR ...] or (([FROM-CHAR ...] . TO) ...)
3153 where TO is TO-CHAR or [TO-CHAR ...]. */
3158 if (nc
!= oc
&& nc
>= 0)
3160 /* Simple one char to one char translation. */
3165 /* This is less efficient, because it moves the gap,
3166 but it should handle multibyte characters correctly. */
3167 string
= make_multibyte_string ((char *) str
, 1, str_len
);
3168 replace_range (pos
, pos
+ 1, string
, 1, 0, 1);
3173 record_change (pos
, 1);
3174 while (str_len
-- > 0)
3176 signal_after_change (pos
, 1, 1);
3177 update_compositions (pos
, pos
+ 1, CHECK_BORDER
);
3187 val
= check_translation (pos
, pos_byte
, end_pos
, val
);
3194 /* VAL is ([FROM-CHAR ...] . TO). */
3195 len
= ASIZE (XCAR (val
));
3203 string
= Fconcat (1, &val
);
3207 string
= Fmake_string (make_number (1), val
);
3209 replace_range (pos
, pos
+ len
, string
, 1, 0, 1);
3210 pos_byte
+= SBYTES (string
);
3211 pos
+= SCHARS (string
);
3212 cnt
+= SCHARS (string
);
3213 end_pos
+= SCHARS (string
) - len
;
3221 return make_number (cnt
);
3224 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
3225 doc
: /* Delete the text between START and END.
3226 If called interactively, delete the region between point and mark.
3227 This command deletes buffer text without modifying the kill ring. */)
3228 (Lisp_Object start
, Lisp_Object end
)
3230 validate_region (&start
, &end
);
3231 del_range (XINT (start
), XINT (end
));
3235 DEFUN ("delete-and-extract-region", Fdelete_and_extract_region
,
3236 Sdelete_and_extract_region
, 2, 2, 0,
3237 doc
: /* Delete the text between START and END and return it. */)
3238 (Lisp_Object start
, Lisp_Object end
)
3240 validate_region (&start
, &end
);
3241 if (XINT (start
) == XINT (end
))
3242 return empty_unibyte_string
;
3243 return del_range_1 (XINT (start
), XINT (end
), 1, 1);
3246 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
3247 doc
: /* Remove restrictions (narrowing) from current buffer.
3248 This allows the buffer's full text to be seen and edited. */)
3251 if (BEG
!= BEGV
|| Z
!= ZV
)
3252 current_buffer
->clip_changed
= 1;
3254 BEGV_BYTE
= BEG_BYTE
;
3255 SET_BUF_ZV_BOTH (current_buffer
, Z
, Z_BYTE
);
3256 /* Changing the buffer bounds invalidates any recorded current column. */
3257 invalidate_current_column ();
3261 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
3262 doc
: /* Restrict editing in this buffer to the current region.
3263 The rest of the text becomes temporarily invisible and untouchable
3264 but is not deleted; if you save the buffer in a file, the invisible
3265 text is included in the file. \\[widen] makes all visible again.
3266 See also `save-restriction'.
3268 When calling from a program, pass two arguments; positions (integers
3269 or markers) bounding the text that should remain visible. */)
3270 (register Lisp_Object start
, Lisp_Object end
)
3272 CHECK_NUMBER_COERCE_MARKER (start
);
3273 CHECK_NUMBER_COERCE_MARKER (end
);
3275 if (XINT (start
) > XINT (end
))
3278 tem
= start
; start
= end
; end
= tem
;
3281 if (!(BEG
<= XINT (start
) && XINT (start
) <= XINT (end
) && XINT (end
) <= Z
))
3282 args_out_of_range (start
, end
);
3284 if (BEGV
!= XFASTINT (start
) || ZV
!= XFASTINT (end
))
3285 current_buffer
->clip_changed
= 1;
3287 SET_BUF_BEGV (current_buffer
, XFASTINT (start
));
3288 SET_BUF_ZV (current_buffer
, XFASTINT (end
));
3289 if (PT
< XFASTINT (start
))
3290 SET_PT (XFASTINT (start
));
3291 if (PT
> XFASTINT (end
))
3292 SET_PT (XFASTINT (end
));
3293 /* Changing the buffer bounds invalidates any recorded current column. */
3294 invalidate_current_column ();
3299 save_restriction_save (void)
3301 if (BEGV
== BEG
&& ZV
== Z
)
3302 /* The common case that the buffer isn't narrowed.
3303 We return just the buffer object, which save_restriction_restore
3304 recognizes as meaning `no restriction'. */
3305 return Fcurrent_buffer ();
3307 /* We have to save a restriction, so return a pair of markers, one
3308 for the beginning and one for the end. */
3310 Lisp_Object beg
, end
;
3312 beg
= build_marker (current_buffer
, BEGV
, BEGV_BYTE
);
3313 end
= build_marker (current_buffer
, ZV
, ZV_BYTE
);
3315 /* END must move forward if text is inserted at its exact location. */
3316 XMARKER (end
)->insertion_type
= 1;
3318 return Fcons (beg
, end
);
3323 save_restriction_restore (Lisp_Object data
)
3325 struct buffer
*cur
= NULL
;
3326 struct buffer
*buf
= (CONSP (data
)
3327 ? XMARKER (XCAR (data
))->buffer
3330 if (buf
&& buf
!= current_buffer
&& !NILP (BVAR (buf
, pt_marker
)))
3331 { /* If `buf' uses markers to keep track of PT, BEGV, and ZV (as
3332 is the case if it is or has an indirect buffer), then make
3333 sure it is current before we update BEGV, so
3334 set_buffer_internal takes care of managing those markers. */
3335 cur
= current_buffer
;
3336 set_buffer_internal (buf
);
3340 /* A pair of marks bounding a saved restriction. */
3342 struct Lisp_Marker
*beg
= XMARKER (XCAR (data
));
3343 struct Lisp_Marker
*end
= XMARKER (XCDR (data
));
3344 eassert (buf
== end
->buffer
);
3346 if (buf
/* Verify marker still points to a buffer. */
3347 && (beg
->charpos
!= BUF_BEGV (buf
) || end
->charpos
!= BUF_ZV (buf
)))
3348 /* The restriction has changed from the saved one, so restore
3349 the saved restriction. */
3351 ptrdiff_t pt
= BUF_PT (buf
);
3353 SET_BUF_BEGV_BOTH (buf
, beg
->charpos
, beg
->bytepos
);
3354 SET_BUF_ZV_BOTH (buf
, end
->charpos
, end
->bytepos
);
3356 if (pt
< beg
->charpos
|| pt
> end
->charpos
)
3357 /* The point is outside the new visible range, move it inside. */
3358 SET_BUF_PT_BOTH (buf
,
3359 clip_to_bounds (beg
->charpos
, pt
, end
->charpos
),
3360 clip_to_bounds (beg
->bytepos
, BUF_PT_BYTE (buf
),
3363 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3365 /* These aren't needed anymore, so don't wait for GC. */
3366 free_marker (XCAR (data
));
3367 free_marker (XCDR (data
));
3368 free_cons (XCONS (data
));
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
;
3411 ptrdiff_t count
= SPECPDL_INDEX ();
3413 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
3414 val
= Fprogn (body
);
3415 return unbind_to (count
, val
);
3418 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
3419 doc
: /* Display a message at the bottom of the screen.
3420 The message also goes into the `*Messages*' buffer, if `message-log-max'
3421 is non-nil. (In keyboard macros, that's all it does.)
3424 In batch mode, the message is printed to the standard error stream,
3425 followed by a newline.
3427 The first argument is a format control string, and the rest are data
3428 to be formatted under control of the string. See `format' for details.
3430 Note: Use (message "%s" VALUE) to print the value of expressions and
3431 variables to avoid accidentally interpreting `%' as format specifiers.
3433 If the first argument is nil or the empty string, the function clears
3434 any existing message; this lets the minibuffer contents show. See
3435 also `current-message'.
3437 usage: (message FORMAT-STRING &rest ARGS) */)
3438 (ptrdiff_t nargs
, Lisp_Object
*args
)
3441 || (STRINGP (args
[0])
3442 && SBYTES (args
[0]) == 0))
3449 register Lisp_Object val
;
3450 val
= Fformat (nargs
, args
);
3456 DEFUN ("message-box", Fmessage_box
, Smessage_box
, 1, MANY
, 0,
3457 doc
: /* Display a message, in a dialog box if possible.
3458 If a dialog box is not available, use the echo area.
3459 The first argument is a format control string, and the rest are data
3460 to be formatted under control of the string. See `format' for details.
3462 If the first argument is nil or the empty string, clear any existing
3463 message; let the minibuffer contents show.
3465 usage: (message-box FORMAT-STRING &rest ARGS) */)
3466 (ptrdiff_t nargs
, Lisp_Object
*args
)
3475 Lisp_Object val
= Fformat (nargs
, args
);
3476 Lisp_Object pane
, menu
;
3477 struct gcpro gcpro1
;
3479 pane
= list1 (Fcons (build_string ("OK"), Qt
));
3481 menu
= Fcons (val
, pane
);
3482 Fx_popup_dialog (Qt
, menu
, Qt
);
3488 DEFUN ("message-or-box", Fmessage_or_box
, Smessage_or_box
, 1, MANY
, 0,
3489 doc
: /* Display a message in a dialog box or in the echo area.
3490 If this command was invoked with the mouse, use a dialog box if
3491 `use-dialog-box' is non-nil.
3492 Otherwise, use the echo area.
3493 The first argument is a format control string, and the rest are data
3494 to be formatted under control of the string. See `format' for details.
3496 If the first argument is nil or the empty string, clear any existing
3497 message; let the minibuffer contents show.
3499 usage: (message-or-box FORMAT-STRING &rest ARGS) */)
3500 (ptrdiff_t nargs
, Lisp_Object
*args
)
3502 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3504 return Fmessage_box (nargs
, args
);
3505 return Fmessage (nargs
, args
);
3508 DEFUN ("current-message", Fcurrent_message
, Scurrent_message
, 0, 0, 0,
3509 doc
: /* Return the string currently displayed in the echo area, or nil if none. */)
3512 return current_message ();
3516 DEFUN ("propertize", Fpropertize
, Spropertize
, 1, MANY
, 0,
3517 doc
: /* Return a copy of STRING with text properties added.
3518 First argument is the string to copy.
3519 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
3520 properties to add to the result.
3521 usage: (propertize STRING &rest PROPERTIES) */)
3522 (ptrdiff_t nargs
, Lisp_Object
*args
)
3524 Lisp_Object properties
, string
;
3525 struct gcpro gcpro1
, gcpro2
;
3528 /* Number of args must be odd. */
3529 if ((nargs
& 1) == 0)
3530 error ("Wrong number of arguments");
3532 properties
= string
= Qnil
;
3533 GCPRO2 (properties
, string
);
3535 /* First argument must be a string. */
3536 CHECK_STRING (args
[0]);
3537 string
= Fcopy_sequence (args
[0]);
3539 for (i
= 1; i
< nargs
; i
+= 2)
3540 properties
= Fcons (args
[i
], Fcons (args
[i
+ 1], properties
));
3542 Fadd_text_properties (make_number (0),
3543 make_number (SCHARS (string
)),
3544 properties
, string
);
3545 RETURN_UNGCPRO (string
);
3548 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
3549 doc
: /* Format a string out of a format-string and arguments.
3550 The first argument is a format control string.
3551 The other arguments are substituted into it to make the result, a string.
3553 The format control string may contain %-sequences meaning to substitute
3554 the next available argument:
3556 %s means print a string argument. Actually, prints any object, with `princ'.
3557 %d means print as number in decimal (%o octal, %x hex).
3558 %X is like %x, but uses upper case.
3559 %e means print a number in exponential notation.
3560 %f means print a number in decimal-point notation.
3561 %g means print a number in exponential notation
3562 or decimal-point notation, whichever uses fewer characters.
3563 %c means print a number as a single character.
3564 %S means print any object as an s-expression (using `prin1').
3566 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.
3567 Use %% to put a single % into the output.
3569 A %-sequence may contain optional flag, width, and precision
3570 specifiers, as follows:
3572 %<flags><width><precision>character
3574 where flags is [+ #-0]+, width is [0-9]+, and precision is .[0-9]+
3576 The + flag character inserts a + before any positive number, while a
3577 space inserts a space before any positive number; these flags only
3578 affect %d, %e, %f, and %g sequences, and the + flag takes precedence.
3579 The - and 0 flags affect the width specifier, as described below.
3581 The # flag means to use an alternate display form for %o, %x, %X, %e,
3582 %f, and %g sequences: for %o, it ensures that the result begins with
3583 \"0\"; for %x and %X, it prefixes the result with \"0x\" or \"0X\";
3584 for %e, %f, and %g, it causes a decimal point to be included even if
3585 the precision is zero.
3587 The width specifier supplies a lower limit for the length of the
3588 printed representation. The padding, if any, normally goes on the
3589 left, but it goes on the right if the - flag is present. The padding
3590 character is normally a space, but it is 0 if the 0 flag is present.
3591 The 0 flag is ignored if the - flag is present, or the format sequence
3592 is something other than %d, %e, %f, and %g.
3594 For %e, %f, and %g sequences, the number after the "." in the
3595 precision specifier says how many decimal places to show; if zero, the
3596 decimal point itself is omitted. For %s and %S, the precision
3597 specifier truncates the string to the given width.
3599 usage: (format STRING &rest OBJECTS) */)
3600 (ptrdiff_t nargs
, Lisp_Object
*args
)
3602 ptrdiff_t n
; /* The number of the next arg to substitute */
3603 char initial_buffer
[4000];
3604 char *buf
= initial_buffer
;
3605 ptrdiff_t bufsize
= sizeof initial_buffer
;
3606 ptrdiff_t max_bufsize
= STRING_BYTES_BOUND
+ 1;
3608 ptrdiff_t buf_save_value_index
IF_LINT (= 0);
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 unsigned converted_to_string
: 1;
3639 unsigned 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_BYTE_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_BYTE_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_BYTE_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 (bufsize
);
4217 buf_save_value_index
= SPECPDL_INDEX ();
4218 record_unwind_protect_ptr (xfree
, buf
);
4219 memcpy (buf
, initial_buffer
, used
);
4223 buf
= xrealloc (buf
, bufsize
);
4224 set_unwind_protect_ptr (buf_save_value_index
, xfree
, buf
);
4234 if (bufsize
< p
- buf
)
4237 if (maybe_combine_byte
)
4238 nchars
= multibyte_chars_in_text ((unsigned char *) buf
, p
- buf
);
4239 val
= make_specified_string (buf
, nchars
, p
- buf
, multibyte
);
4241 /* If we allocated BUF with malloc, free it too. */
4244 /* If the format string has text properties, or any of the string
4245 arguments has text properties, set up text properties of the
4248 if (string_intervals (args
[0]) || arg_intervals
)
4250 Lisp_Object len
, new_len
, props
;
4251 struct gcpro gcpro1
;
4253 /* Add text properties from the format string. */
4254 len
= make_number (SCHARS (args
[0]));
4255 props
= text_property_list (args
[0], make_number (0), len
, Qnil
);
4260 ptrdiff_t bytepos
= 0, position
= 0, translated
= 0;
4264 /* Adjust the bounds of each text property
4265 to the proper start and end in the output string. */
4267 /* Put the positions in PROPS in increasing order, so that
4268 we can do (effectively) one scan through the position
4269 space of the format string. */
4270 props
= Fnreverse (props
);
4272 /* BYTEPOS is the byte position in the format string,
4273 POSITION is the untranslated char position in it,
4274 TRANSLATED is the translated char position in BUF,
4275 and ARGN is the number of the next arg we will come to. */
4276 for (list
= props
; CONSP (list
); list
= XCDR (list
))
4283 /* First adjust the property start position. */
4284 pos
= XINT (XCAR (item
));
4286 /* Advance BYTEPOS, POSITION, TRANSLATED and ARGN
4287 up to this position. */
4288 for (; position
< pos
; bytepos
++)
4290 if (! discarded
[bytepos
])
4291 position
++, translated
++;
4292 else if (discarded
[bytepos
] == 1)
4295 if (translated
== info
[argn
].start
)
4297 translated
+= info
[argn
].end
- info
[argn
].start
;
4303 XSETCAR (item
, make_number (translated
));
4305 /* Likewise adjust the property end position. */
4306 pos
= XINT (XCAR (XCDR (item
)));
4308 for (; position
< pos
; bytepos
++)
4310 if (! discarded
[bytepos
])
4311 position
++, translated
++;
4312 else if (discarded
[bytepos
] == 1)
4315 if (translated
== info
[argn
].start
)
4317 translated
+= info
[argn
].end
- info
[argn
].start
;
4323 XSETCAR (XCDR (item
), make_number (translated
));
4326 add_text_properties_from_list (val
, props
, make_number (0));
4329 /* Add text properties from arguments. */
4331 for (n
= 1; n
< nargs
; ++n
)
4332 if (info
[n
].intervals
)
4334 len
= make_number (SCHARS (args
[n
]));
4335 new_len
= make_number (info
[n
].end
- info
[n
].start
);
4336 props
= text_property_list (args
[n
], make_number (0), len
, Qnil
);
4337 props
= extend_property_ranges (props
, new_len
);
4338 /* If successive arguments have properties, be sure that
4339 the value of `composition' property be the copy. */
4340 if (n
> 1 && info
[n
- 1].end
)
4341 make_composition_value_copy (props
);
4342 add_text_properties_from_list (val
, props
,
4343 make_number (info
[n
].start
));
4353 format2 (const char *string1
, Lisp_Object arg0
, Lisp_Object arg1
)
4355 Lisp_Object args
[3];
4356 args
[0] = build_string (string1
);
4359 return Fformat (3, args
);
4362 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
4363 doc
: /* Return t if two characters match, optionally ignoring case.
4364 Both arguments must be characters (i.e. integers).
4365 Case is ignored if `case-fold-search' is non-nil in the current buffer. */)
4366 (register Lisp_Object c1
, Lisp_Object c2
)
4369 /* Check they're chars, not just integers, otherwise we could get array
4370 bounds violations in downcase. */
4371 CHECK_CHARACTER (c1
);
4372 CHECK_CHARACTER (c2
);
4374 if (XINT (c1
) == XINT (c2
))
4376 if (NILP (BVAR (current_buffer
, case_fold_search
)))
4380 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
))
4381 && ! ASCII_CHAR_P (i1
))
4383 MAKE_CHAR_MULTIBYTE (i1
);
4386 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
))
4387 && ! ASCII_CHAR_P (i2
))
4389 MAKE_CHAR_MULTIBYTE (i2
);
4391 return (downcase (i1
) == downcase (i2
) ? Qt
: Qnil
);
4394 /* Transpose the markers in two regions of the current buffer, and
4395 adjust the ones between them if necessary (i.e.: if the regions
4398 START1, END1 are the character positions of the first region.
4399 START1_BYTE, END1_BYTE are the byte positions.
4400 START2, END2 are the character positions of the second region.
4401 START2_BYTE, END2_BYTE are the byte positions.
4403 Traverses the entire marker list of the buffer to do so, adding an
4404 appropriate amount to some, subtracting from some, and leaving the
4405 rest untouched. Most of this is copied from adjust_markers in insdel.c.
4407 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
4410 transpose_markers (ptrdiff_t start1
, ptrdiff_t end1
,
4411 ptrdiff_t start2
, ptrdiff_t end2
,
4412 ptrdiff_t start1_byte
, ptrdiff_t end1_byte
,
4413 ptrdiff_t start2_byte
, ptrdiff_t end2_byte
)
4415 register ptrdiff_t amt1
, amt1_byte
, amt2
, amt2_byte
, diff
, diff_byte
, mpos
;
4416 register struct Lisp_Marker
*marker
;
4418 /* Update point as if it were a marker. */
4422 TEMP_SET_PT_BOTH (PT
+ (end2
- end1
),
4423 PT_BYTE
+ (end2_byte
- end1_byte
));
4424 else if (PT
< start2
)
4425 TEMP_SET_PT_BOTH (PT
+ (end2
- start2
) - (end1
- start1
),
4426 (PT_BYTE
+ (end2_byte
- start2_byte
)
4427 - (end1_byte
- start1_byte
)));
4429 TEMP_SET_PT_BOTH (PT
- (start2
- start1
),
4430 PT_BYTE
- (start2_byte
- start1_byte
));
4432 /* We used to adjust the endpoints here to account for the gap, but that
4433 isn't good enough. Even if we assume the caller has tried to move the
4434 gap out of our way, it might still be at start1 exactly, for example;
4435 and that places it `inside' the interval, for our purposes. The amount
4436 of adjustment is nontrivial if there's a `denormalized' marker whose
4437 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
4438 the dirty work to Fmarker_position, below. */
4440 /* The difference between the region's lengths */
4441 diff
= (end2
- start2
) - (end1
- start1
);
4442 diff_byte
= (end2_byte
- start2_byte
) - (end1_byte
- start1_byte
);
4444 /* For shifting each marker in a region by the length of the other
4445 region plus the distance between the regions. */
4446 amt1
= (end2
- start2
) + (start2
- end1
);
4447 amt2
= (end1
- start1
) + (start2
- end1
);
4448 amt1_byte
= (end2_byte
- start2_byte
) + (start2_byte
- end1_byte
);
4449 amt2_byte
= (end1_byte
- start1_byte
) + (start2_byte
- end1_byte
);
4451 for (marker
= BUF_MARKERS (current_buffer
); marker
; marker
= marker
->next
)
4453 mpos
= marker
->bytepos
;
4454 if (mpos
>= start1_byte
&& mpos
< end2_byte
)
4456 if (mpos
< end1_byte
)
4458 else if (mpos
< start2_byte
)
4462 marker
->bytepos
= mpos
;
4464 mpos
= marker
->charpos
;
4465 if (mpos
>= start1
&& mpos
< end2
)
4469 else if (mpos
< start2
)
4474 marker
->charpos
= mpos
;
4478 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
4479 doc
: /* Transpose region STARTR1 to ENDR1 with STARTR2 to ENDR2.
4480 The regions should not be overlapping, because the size of the buffer is
4481 never changed in a transposition.
4483 Optional fifth arg LEAVE-MARKERS, if non-nil, means don't update
4484 any markers that happen to be located in the regions.
4486 Transposing beyond buffer boundaries is an error. */)
4487 (Lisp_Object startr1
, Lisp_Object endr1
, Lisp_Object startr2
, Lisp_Object endr2
, Lisp_Object leave_markers
)
4489 register ptrdiff_t start1
, end1
, start2
, end2
;
4490 ptrdiff_t start1_byte
, start2_byte
, len1_byte
, len2_byte
, end2_byte
;
4491 ptrdiff_t gap
, len1
, len_mid
, len2
;
4492 unsigned char *start1_addr
, *start2_addr
, *temp
;
4494 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
, tmp_interval3
;
4497 XSETBUFFER (buf
, current_buffer
);
4498 cur_intv
= buffer_intervals (current_buffer
);
4500 validate_region (&startr1
, &endr1
);
4501 validate_region (&startr2
, &endr2
);
4503 start1
= XFASTINT (startr1
);
4504 end1
= XFASTINT (endr1
);
4505 start2
= XFASTINT (startr2
);
4506 end2
= XFASTINT (endr2
);
4509 /* Swap the regions if they're reversed. */
4512 register ptrdiff_t glumph
= start1
;
4520 len1
= end1
- start1
;
4521 len2
= end2
- start2
;
4524 error ("Transposed regions overlap");
4525 /* Nothing to change for adjacent regions with one being empty */
4526 else if ((start1
== end1
|| start2
== end2
) && end1
== start2
)
4529 /* The possibilities are:
4530 1. Adjacent (contiguous) regions, or separate but equal regions
4531 (no, really equal, in this case!), or
4532 2. Separate regions of unequal size.
4534 The worst case is usually No. 2. It means that (aside from
4535 potential need for getting the gap out of the way), there also
4536 needs to be a shifting of the text between the two regions. So
4537 if they are spread far apart, we are that much slower... sigh. */
4539 /* It must be pointed out that the really studly thing to do would
4540 be not to move the gap at all, but to leave it in place and work
4541 around it if necessary. This would be extremely efficient,
4542 especially considering that people are likely to do
4543 transpositions near where they are working interactively, which
4544 is exactly where the gap would be found. However, such code
4545 would be much harder to write and to read. So, if you are
4546 reading this comment and are feeling squirrely, by all means have
4547 a go! I just didn't feel like doing it, so I will simply move
4548 the gap the minimum distance to get it out of the way, and then
4549 deal with an unbroken array. */
4551 start1_byte
= CHAR_TO_BYTE (start1
);
4552 end2_byte
= CHAR_TO_BYTE (end2
);
4554 /* Make sure the gap won't interfere, by moving it out of the text
4555 we will operate on. */
4556 if (start1
< gap
&& gap
< end2
)
4558 if (gap
- start1
< end2
- gap
)
4559 move_gap_both (start1
, start1_byte
);
4561 move_gap_both (end2
, end2_byte
);
4564 start2_byte
= CHAR_TO_BYTE (start2
);
4565 len1_byte
= CHAR_TO_BYTE (end1
) - start1_byte
;
4566 len2_byte
= end2_byte
- start2_byte
;
4568 #ifdef BYTE_COMBINING_DEBUG
4571 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4572 len2_byte
, start1
, start1_byte
)
4573 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4574 len1_byte
, end2
, start2_byte
+ len2_byte
)
4575 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4576 len1_byte
, end2
, start2_byte
+ len2_byte
))
4581 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4582 len2_byte
, start1
, start1_byte
)
4583 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4584 len1_byte
, start2
, start2_byte
)
4585 || count_combining_after (BYTE_POS_ADDR (start2_byte
),
4586 len2_byte
, end1
, start1_byte
+ len1_byte
)
4587 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4588 len1_byte
, end2
, start2_byte
+ len2_byte
))
4593 /* Hmmm... how about checking to see if the gap is large
4594 enough to use as the temporary storage? That would avoid an
4595 allocation... interesting. Later, don't fool with it now. */
4597 /* Working without memmove, for portability (sigh), so must be
4598 careful of overlapping subsections of the array... */
4600 if (end1
== start2
) /* adjacent regions */
4602 modify_text (start1
, end2
);
4603 record_change (start1
, len1
+ len2
);
4605 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4606 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4607 /* Don't use Fset_text_properties: that can cause GC, which can
4608 clobber objects stored in the tmp_intervals. */
4609 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4611 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4613 /* First region smaller than second. */
4614 if (len1_byte
< len2_byte
)
4618 temp
= SAFE_ALLOCA (len2_byte
);
4620 /* Don't precompute these addresses. We have to compute them
4621 at the last minute, because the relocating allocator might
4622 have moved the buffer around during the xmalloc. */
4623 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4624 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4626 memcpy (temp
, start2_addr
, len2_byte
);
4627 memcpy (start1_addr
+ len2_byte
, start1_addr
, len1_byte
);
4628 memcpy (start1_addr
, temp
, len2_byte
);
4632 /* First region not smaller than second. */
4636 temp
= SAFE_ALLOCA (len1_byte
);
4637 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4638 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4639 memcpy (temp
, start1_addr
, len1_byte
);
4640 memcpy (start1_addr
, start2_addr
, len2_byte
);
4641 memcpy (start1_addr
+ len2_byte
, temp
, len1_byte
);
4644 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
4645 len1
, current_buffer
, 0);
4646 graft_intervals_into_buffer (tmp_interval2
, start1
,
4647 len2
, current_buffer
, 0);
4648 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4649 update_compositions (start1
+ len2
, end2
, CHECK_TAIL
);
4651 /* Non-adjacent regions, because end1 != start2, bleagh... */
4654 len_mid
= start2_byte
- (start1_byte
+ len1_byte
);
4656 if (len1_byte
== len2_byte
)
4657 /* Regions are same size, though, how nice. */
4661 modify_text (start1
, end1
);
4662 modify_text (start2
, end2
);
4663 record_change (start1
, len1
);
4664 record_change (start2
, len2
);
4665 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4666 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4668 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr1
, 0);
4670 set_text_properties_1 (startr1
, endr1
, Qnil
, buf
, tmp_interval3
);
4672 tmp_interval3
= validate_interval_range (buf
, &startr2
, &endr2
, 0);
4674 set_text_properties_1 (startr2
, endr2
, Qnil
, buf
, tmp_interval3
);
4676 temp
= SAFE_ALLOCA (len1_byte
);
4677 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4678 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4679 memcpy (temp
, start1_addr
, len1_byte
);
4680 memcpy (start1_addr
, start2_addr
, len2_byte
);
4681 memcpy (start2_addr
, temp
, len1_byte
);
4684 graft_intervals_into_buffer (tmp_interval1
, start2
,
4685 len1
, current_buffer
, 0);
4686 graft_intervals_into_buffer (tmp_interval2
, start1
,
4687 len2
, current_buffer
, 0);
4690 else if (len1_byte
< len2_byte
) /* Second region larger than first */
4691 /* Non-adjacent & unequal size, area between must also be shifted. */
4695 modify_text (start1
, end2
);
4696 record_change (start1
, (end2
- start1
));
4697 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4698 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4699 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4701 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4703 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4705 /* holds region 2 */
4706 temp
= SAFE_ALLOCA (len2_byte
);
4707 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4708 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4709 memcpy (temp
, start2_addr
, len2_byte
);
4710 memcpy (start1_addr
+ len_mid
+ len2_byte
, start1_addr
, len1_byte
);
4711 memmove (start1_addr
+ len2_byte
, start1_addr
+ len1_byte
, len_mid
);
4712 memcpy (start1_addr
, temp
, len2_byte
);
4715 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4716 len1
, current_buffer
, 0);
4717 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4718 len_mid
, current_buffer
, 0);
4719 graft_intervals_into_buffer (tmp_interval2
, start1
,
4720 len2
, current_buffer
, 0);
4723 /* Second region smaller than first. */
4727 record_change (start1
, (end2
- start1
));
4728 modify_text (start1
, end2
);
4730 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4731 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4732 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4734 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4736 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4738 /* holds region 1 */
4739 temp
= SAFE_ALLOCA (len1_byte
);
4740 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4741 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4742 memcpy (temp
, start1_addr
, len1_byte
);
4743 memcpy (start1_addr
, start2_addr
, len2_byte
);
4744 memcpy (start1_addr
+ len2_byte
, start1_addr
+ len1_byte
, len_mid
);
4745 memcpy (start1_addr
+ len2_byte
+ len_mid
, temp
, len1_byte
);
4748 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4749 len1
, current_buffer
, 0);
4750 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4751 len_mid
, current_buffer
, 0);
4752 graft_intervals_into_buffer (tmp_interval2
, start1
,
4753 len2
, current_buffer
, 0);
4756 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4757 update_compositions (end2
- len1
, end2
, CHECK_BORDER
);
4760 /* When doing multiple transpositions, it might be nice
4761 to optimize this. Perhaps the markers in any one buffer
4762 should be organized in some sorted data tree. */
4763 if (NILP (leave_markers
))
4765 transpose_markers (start1
, end1
, start2
, end2
,
4766 start1_byte
, start1_byte
+ len1_byte
,
4767 start2_byte
, start2_byte
+ len2_byte
);
4768 fix_start_end_in_overlays (start1
, end2
);
4771 signal_after_change (start1
, end2
- start1
, end2
- start1
);
4777 syms_of_editfns (void)
4779 DEFSYM (Qbuffer_access_fontify_functions
, "buffer-access-fontify-functions");
4781 DEFVAR_LISP ("inhibit-field-text-motion", Vinhibit_field_text_motion
,
4782 doc
: /* Non-nil means text motion commands don't notice fields. */);
4783 Vinhibit_field_text_motion
= Qnil
;
4785 DEFVAR_LISP ("buffer-access-fontify-functions",
4786 Vbuffer_access_fontify_functions
,
4787 doc
: /* List of functions called by `buffer-substring' to fontify if necessary.
4788 Each function is called with two arguments which specify the range
4789 of the buffer being accessed. */);
4790 Vbuffer_access_fontify_functions
= Qnil
;
4794 obuf
= Fcurrent_buffer ();
4795 /* Do this here, because init_buffer_once is too early--it won't work. */
4796 Fset_buffer (Vprin1_to_string_buffer
);
4797 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
4798 Fset (Fmake_local_variable (intern_c_string ("buffer-access-fontify-functions")),
4803 DEFVAR_LISP ("buffer-access-fontified-property",
4804 Vbuffer_access_fontified_property
,
4805 doc
: /* Property which (if non-nil) indicates text has been fontified.
4806 `buffer-substring' need not call the `buffer-access-fontify-functions'
4807 functions if all the text being accessed has this property. */);
4808 Vbuffer_access_fontified_property
= Qnil
;
4810 DEFVAR_LISP ("system-name", Vsystem_name
,
4811 doc
: /* The host name of the machine Emacs is running on. */);
4813 DEFVAR_LISP ("user-full-name", Vuser_full_name
,
4814 doc
: /* The full name of the user logged in. */);
4816 DEFVAR_LISP ("user-login-name", Vuser_login_name
,
4817 doc
: /* The user's name, taken from environment variables if possible. */);
4819 DEFVAR_LISP ("user-real-login-name", Vuser_real_login_name
,
4820 doc
: /* The user's name, based upon the real uid only. */);
4822 DEFVAR_LISP ("operating-system-release", Voperating_system_release
,
4823 doc
: /* The release of the operating system Emacs is running on. */);
4825 defsubr (&Spropertize
);
4826 defsubr (&Schar_equal
);
4827 defsubr (&Sgoto_char
);
4828 defsubr (&Sstring_to_char
);
4829 defsubr (&Schar_to_string
);
4830 defsubr (&Sbyte_to_string
);
4831 defsubr (&Sbuffer_substring
);
4832 defsubr (&Sbuffer_substring_no_properties
);
4833 defsubr (&Sbuffer_string
);
4834 defsubr (&Sget_pos_property
);
4836 defsubr (&Spoint_marker
);
4837 defsubr (&Smark_marker
);
4839 defsubr (&Sregion_beginning
);
4840 defsubr (&Sregion_end
);
4842 DEFSYM (Qfield
, "field");
4843 DEFSYM (Qboundary
, "boundary");
4844 defsubr (&Sfield_beginning
);
4845 defsubr (&Sfield_end
);
4846 defsubr (&Sfield_string
);
4847 defsubr (&Sfield_string_no_properties
);
4848 defsubr (&Sdelete_field
);
4849 defsubr (&Sconstrain_to_field
);
4851 defsubr (&Sline_beginning_position
);
4852 defsubr (&Sline_end_position
);
4854 defsubr (&Ssave_excursion
);
4855 defsubr (&Ssave_current_buffer
);
4857 defsubr (&Sbuffer_size
);
4858 defsubr (&Spoint_max
);
4859 defsubr (&Spoint_min
);
4860 defsubr (&Spoint_min_marker
);
4861 defsubr (&Spoint_max_marker
);
4862 defsubr (&Sgap_position
);
4863 defsubr (&Sgap_size
);
4864 defsubr (&Sposition_bytes
);
4865 defsubr (&Sbyte_to_position
);
4871 defsubr (&Sfollowing_char
);
4872 defsubr (&Sprevious_char
);
4873 defsubr (&Schar_after
);
4874 defsubr (&Schar_before
);
4876 defsubr (&Sinsert_before_markers
);
4877 defsubr (&Sinsert_and_inherit
);
4878 defsubr (&Sinsert_and_inherit_before_markers
);
4879 defsubr (&Sinsert_char
);
4880 defsubr (&Sinsert_byte
);
4882 defsubr (&Suser_login_name
);
4883 defsubr (&Suser_real_login_name
);
4884 defsubr (&Suser_uid
);
4885 defsubr (&Suser_real_uid
);
4886 defsubr (&Sgroup_gid
);
4887 defsubr (&Sgroup_real_gid
);
4888 defsubr (&Suser_full_name
);
4889 defsubr (&Semacs_pid
);
4890 defsubr (&Scurrent_time
);
4891 defsubr (&Sget_internal_run_time
);
4892 defsubr (&Sformat_time_string
);
4893 defsubr (&Sfloat_time
);
4894 defsubr (&Sdecode_time
);
4895 defsubr (&Sencode_time
);
4896 defsubr (&Scurrent_time_string
);
4897 defsubr (&Scurrent_time_zone
);
4898 defsubr (&Sset_time_zone_rule
);
4899 defsubr (&Ssystem_name
);
4900 defsubr (&Smessage
);
4901 defsubr (&Smessage_box
);
4902 defsubr (&Smessage_or_box
);
4903 defsubr (&Scurrent_message
);
4906 defsubr (&Sinsert_buffer_substring
);
4907 defsubr (&Scompare_buffer_substrings
);
4908 defsubr (&Ssubst_char_in_region
);
4909 defsubr (&Stranslate_region_internal
);
4910 defsubr (&Sdelete_region
);
4911 defsubr (&Sdelete_and_extract_region
);
4913 defsubr (&Snarrow_to_region
);
4914 defsubr (&Ssave_restriction
);
4915 defsubr (&Stranspose_regions
);