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, EMACS_TIME
,
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
)
238 if (MARKERP (position
)
239 && current_buffer
== XMARKER (position
)->buffer
)
241 pos
= marker_position (position
);
243 SET_PT_BOTH (BEGV
, BEGV_BYTE
);
245 SET_PT_BOTH (ZV
, ZV_BYTE
);
247 SET_PT_BOTH (pos
, marker_byte_position (position
));
252 CHECK_NUMBER_COERCE_MARKER (position
);
254 pos
= clip_to_bounds (BEGV
, XINT (position
), ZV
);
260 /* Return the start or end position of the region.
261 BEGINNINGP means return the start.
262 If there is no region active, signal an error. */
265 region_limit (bool beginningp
)
269 if (!NILP (Vtransient_mark_mode
)
270 && NILP (Vmark_even_if_inactive
)
271 && NILP (BVAR (current_buffer
, mark_active
)))
272 xsignal0 (Qmark_inactive
);
274 m
= Fmarker_position (BVAR (current_buffer
, mark
));
276 error ("The mark is not set now, so there is no region");
278 /* Clip to the current narrowing (bug#11770). */
279 return make_number ((PT
< XFASTINT (m
)) == beginningp
281 : clip_to_bounds (BEGV
, XFASTINT (m
), ZV
));
284 DEFUN ("region-beginning", Fregion_beginning
, Sregion_beginning
, 0, 0, 0,
285 doc
: /* Return the integer value of point or mark, whichever is smaller. */)
288 return region_limit (1);
291 DEFUN ("region-end", Fregion_end
, Sregion_end
, 0, 0, 0,
292 doc
: /* Return the integer value of point or mark, whichever is larger. */)
295 return region_limit (0);
298 DEFUN ("mark-marker", Fmark_marker
, Smark_marker
, 0, 0, 0,
299 doc
: /* Return this buffer's mark, as a marker object.
300 Watch out! Moving this marker changes the mark position.
301 If you set the marker not to point anywhere, the buffer will have no mark. */)
304 return BVAR (current_buffer
, mark
);
308 /* Find all the overlays in the current buffer that touch position POS.
309 Return the number found, and store them in a vector in VEC
313 overlays_around (EMACS_INT pos
, Lisp_Object
*vec
, ptrdiff_t len
)
315 Lisp_Object overlay
, start
, end
;
316 struct Lisp_Overlay
*tail
;
317 ptrdiff_t startpos
, endpos
;
320 for (tail
= current_buffer
->overlays_before
; tail
; tail
= tail
->next
)
322 XSETMISC (overlay
, tail
);
324 end
= OVERLAY_END (overlay
);
325 endpos
= OVERLAY_POSITION (end
);
328 start
= OVERLAY_START (overlay
);
329 startpos
= OVERLAY_POSITION (start
);
334 /* Keep counting overlays even if we can't return them all. */
339 for (tail
= current_buffer
->overlays_after
; tail
; tail
= tail
->next
)
341 XSETMISC (overlay
, tail
);
343 start
= OVERLAY_START (overlay
);
344 startpos
= OVERLAY_POSITION (start
);
347 end
= OVERLAY_END (overlay
);
348 endpos
= OVERLAY_POSITION (end
);
360 /* Return the value of property PROP, in OBJECT at POSITION.
361 It's the value of PROP that a char inserted at POSITION would get.
362 OBJECT is optional and defaults to the current buffer.
363 If OBJECT is a buffer, then overlay properties are considered as well as
365 If OBJECT is a window, then that window's buffer is used, but
366 window-specific overlays are considered only if they are associated
369 get_pos_property (Lisp_Object position
, register Lisp_Object prop
, Lisp_Object object
)
371 CHECK_NUMBER_COERCE_MARKER (position
);
374 XSETBUFFER (object
, current_buffer
);
375 else if (WINDOWP (object
))
376 object
= XWINDOW (object
)->contents
;
378 if (!BUFFERP (object
))
379 /* pos-property only makes sense in buffers right now, since strings
380 have no overlays and no notion of insertion for which stickiness
382 return Fget_text_property (position
, prop
, object
);
385 EMACS_INT posn
= XINT (position
);
387 Lisp_Object
*overlay_vec
, tem
;
388 struct buffer
*obuf
= current_buffer
;
391 set_buffer_temp (XBUFFER (object
));
393 /* First try with room for 40 overlays. */
395 overlay_vec
= alloca (noverlays
* sizeof *overlay_vec
);
396 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
398 /* If there are more than 40,
399 make enough space for all, and try again. */
402 SAFE_ALLOCA_LISP (overlay_vec
, noverlays
);
403 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
405 noverlays
= sort_overlays (overlay_vec
, noverlays
, NULL
);
407 set_buffer_temp (obuf
);
409 /* Now check the overlays in order of decreasing priority. */
410 while (--noverlays
>= 0)
412 Lisp_Object ol
= overlay_vec
[noverlays
];
413 tem
= Foverlay_get (ol
, prop
);
416 /* Check the overlay is indeed active at point. */
417 Lisp_Object start
= OVERLAY_START (ol
), finish
= OVERLAY_END (ol
);
418 if ((OVERLAY_POSITION (start
) == posn
419 && XMARKER (start
)->insertion_type
== 1)
420 || (OVERLAY_POSITION (finish
) == posn
421 && XMARKER (finish
)->insertion_type
== 0))
422 ; /* The overlay will not cover a char inserted at point. */
432 { /* Now check the text properties. */
433 int stickiness
= text_property_stickiness (prop
, position
, object
);
435 return Fget_text_property (position
, prop
, object
);
436 else if (stickiness
< 0
437 && XINT (position
) > BUF_BEGV (XBUFFER (object
)))
438 return Fget_text_property (make_number (XINT (position
) - 1),
446 /* Find the field surrounding POS in *BEG and *END. If POS is nil,
447 the value of point is used instead. If BEG or END is null,
448 means don't store the beginning or end of the field.
450 BEG_LIMIT and END_LIMIT serve to limit the ranged of the returned
451 results; they do not effect boundary behavior.
453 If MERGE_AT_BOUNDARY is non-nil, then if POS is at the very first
454 position of a field, then the beginning of the previous field is
455 returned instead of the beginning of POS's field (since the end of a
456 field is actually also the beginning of the next input field, this
457 behavior is sometimes useful). Additionally in the MERGE_AT_BOUNDARY
458 non-nil case, if two fields are separated by a field with the special
459 value `boundary', and POS lies within it, then the two separated
460 fields are considered to be adjacent, and POS between them, when
461 finding the beginning and ending of the "merged" field.
463 Either BEG or END may be 0, in which case the corresponding value
467 find_field (Lisp_Object pos
, Lisp_Object merge_at_boundary
,
468 Lisp_Object beg_limit
,
469 ptrdiff_t *beg
, Lisp_Object end_limit
, ptrdiff_t *end
)
471 /* Fields right before and after the point. */
472 Lisp_Object before_field
, after_field
;
473 /* True if POS counts as the start of a field. */
474 bool at_field_start
= 0;
475 /* True if POS counts as the end of a field. */
476 bool at_field_end
= 0;
479 XSETFASTINT (pos
, PT
);
481 CHECK_NUMBER_COERCE_MARKER (pos
);
484 = get_char_property_and_overlay (pos
, Qfield
, Qnil
, NULL
);
486 = (XFASTINT (pos
) > BEGV
487 ? get_char_property_and_overlay (make_number (XINT (pos
) - 1),
489 /* Using nil here would be a more obvious choice, but it would
490 fail when the buffer starts with a non-sticky field. */
493 /* See if we need to handle the case where MERGE_AT_BOUNDARY is nil
494 and POS is at beginning of a field, which can also be interpreted
495 as the end of the previous field. Note that the case where if
496 MERGE_AT_BOUNDARY is non-nil (see function comment) is actually the
497 more natural one; then we avoid treating the beginning of a field
499 if (NILP (merge_at_boundary
))
501 Lisp_Object field
= get_pos_property (pos
, Qfield
, Qnil
);
502 if (!EQ (field
, after_field
))
504 if (!EQ (field
, before_field
))
506 if (NILP (field
) && at_field_start
&& at_field_end
)
507 /* If an inserted char would have a nil field while the surrounding
508 text is non-nil, we're probably not looking at a
509 zero-length field, but instead at a non-nil field that's
510 not intended for editing (such as comint's prompts). */
511 at_field_end
= at_field_start
= 0;
514 /* Note about special `boundary' fields:
516 Consider the case where the point (`.') is between the fields `x' and `y':
520 In this situation, if merge_at_boundary is non-nil, consider the
521 `x' and `y' fields as forming one big merged field, and so the end
522 of the field is the end of `y'.
524 However, if `x' and `y' are separated by a special `boundary' field
525 (a field with a `field' char-property of 'boundary), then ignore
526 this special field when merging adjacent fields. Here's the same
527 situation, but with a `boundary' field between the `x' and `y' fields:
531 Here, if point is at the end of `x', the beginning of `y', or
532 anywhere in-between (within the `boundary' field), merge all
533 three fields and consider the beginning as being the beginning of
534 the `x' field, and the end as being the end of the `y' field. */
539 /* POS is at the edge of a field, and we should consider it as
540 the beginning of the following field. */
541 *beg
= XFASTINT (pos
);
543 /* Find the previous field boundary. */
546 if (!NILP (merge_at_boundary
) && EQ (before_field
, Qboundary
))
547 /* Skip a `boundary' field. */
548 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
551 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
553 *beg
= NILP (p
) ? BEGV
: XFASTINT (p
);
560 /* POS is at the edge of a field, and we should consider it as
561 the end of the previous field. */
562 *end
= XFASTINT (pos
);
564 /* Find the next field boundary. */
566 if (!NILP (merge_at_boundary
) && EQ (after_field
, Qboundary
))
567 /* Skip a `boundary' field. */
568 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
571 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
573 *end
= NILP (pos
) ? ZV
: XFASTINT (pos
);
579 DEFUN ("delete-field", Fdelete_field
, Sdelete_field
, 0, 1, 0,
580 doc
: /* Delete the field surrounding POS.
581 A field is a region of text with the same `field' property.
582 If POS is nil, the value of point is used for POS. */)
586 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
588 del_range (beg
, end
);
592 DEFUN ("field-string", Ffield_string
, Sfield_string
, 0, 1, 0,
593 doc
: /* Return the contents of the field surrounding POS as a string.
594 A field is a region of text with the same `field' property.
595 If POS is nil, the value of point is used for POS. */)
599 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
600 return make_buffer_string (beg
, end
, 1);
603 DEFUN ("field-string-no-properties", Ffield_string_no_properties
, Sfield_string_no_properties
, 0, 1, 0,
604 doc
: /* Return the contents of the field around POS, without text properties.
605 A field is a region of text with the same `field' property.
606 If POS is nil, the value of point is used for POS. */)
610 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
611 return make_buffer_string (beg
, end
, 0);
614 DEFUN ("field-beginning", Ffield_beginning
, Sfield_beginning
, 0, 3, 0,
615 doc
: /* Return the beginning 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 beginning of its
619 field, then the beginning of the *previous* field is returned.
620 If LIMIT is non-nil, it is a buffer position; if the beginning of the field
621 is before 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
, limit
, &beg
, Qnil
, 0);
626 return make_number (beg
);
629 DEFUN ("field-end", Ffield_end
, Sfield_end
, 0, 3, 0,
630 doc
: /* Return the end of the field surrounding POS.
631 A field is a region of text with the same `field' property.
632 If POS is nil, the value of point is used for POS.
633 If ESCAPE-FROM-EDGE is non-nil and POS is at the end of its field,
634 then the end of the *following* field is returned.
635 If LIMIT is non-nil, it is a buffer position; if the end of the field
636 is after LIMIT, then LIMIT will be returned instead. */)
637 (Lisp_Object pos
, Lisp_Object escape_from_edge
, Lisp_Object limit
)
640 find_field (pos
, escape_from_edge
, Qnil
, 0, limit
, &end
);
641 return make_number (end
);
644 DEFUN ("constrain-to-field", Fconstrain_to_field
, Sconstrain_to_field
, 2, 5, 0,
645 doc
: /* Return the position closest to NEW-POS that is in the same field as OLD-POS.
646 A field is a region of text with the same `field' property.
648 If NEW-POS is nil, then use the current point instead, and move point
649 to the resulting constrained position, in addition to returning that
652 If OLD-POS is at the boundary of two fields, then the allowable
653 positions for NEW-POS depends on the value of the optional argument
654 ESCAPE-FROM-EDGE: If ESCAPE-FROM-EDGE is nil, then NEW-POS is
655 constrained to the field that has the same `field' char-property
656 as any new characters inserted at OLD-POS, whereas if ESCAPE-FROM-EDGE
657 is non-nil, NEW-POS is constrained to the union of the two adjacent
658 fields. Additionally, if two fields are separated by another field with
659 the special value `boundary', then any point within this special field is
660 also considered to be `on the boundary'.
662 If the optional argument ONLY-IN-LINE is non-nil and constraining
663 NEW-POS would move it to a different line, NEW-POS is returned
664 unconstrained. This useful for commands that move by line, like
665 \\[next-line] or \\[beginning-of-line], which should generally respect field boundaries
666 only in the case where they can still move to the right line.
668 If the optional argument INHIBIT-CAPTURE-PROPERTY is non-nil, and OLD-POS has
669 a non-nil property of that name, then any field boundaries are ignored.
671 Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */)
672 (Lisp_Object new_pos
, Lisp_Object old_pos
, Lisp_Object escape_from_edge
,
673 Lisp_Object only_in_line
, Lisp_Object inhibit_capture_property
)
675 /* If non-zero, then the original point, before re-positioning. */
676 ptrdiff_t orig_point
= 0;
678 Lisp_Object prev_old
, prev_new
;
681 /* Use the current point, and afterwards, set it. */
684 XSETFASTINT (new_pos
, PT
);
687 CHECK_NUMBER_COERCE_MARKER (new_pos
);
688 CHECK_NUMBER_COERCE_MARKER (old_pos
);
690 fwd
= (XINT (new_pos
) > XINT (old_pos
));
692 prev_old
= make_number (XINT (old_pos
) - 1);
693 prev_new
= make_number (XINT (new_pos
) - 1);
695 if (NILP (Vinhibit_field_text_motion
)
696 && !EQ (new_pos
, old_pos
)
697 && (!NILP (Fget_char_property (new_pos
, Qfield
, Qnil
))
698 || !NILP (Fget_char_property (old_pos
, Qfield
, Qnil
))
699 /* To recognize field boundaries, we must also look at the
700 previous positions; we could use `get_pos_property'
701 instead, but in itself that would fail inside non-sticky
702 fields (like comint prompts). */
703 || (XFASTINT (new_pos
) > BEGV
704 && !NILP (Fget_char_property (prev_new
, Qfield
, Qnil
)))
705 || (XFASTINT (old_pos
) > BEGV
706 && !NILP (Fget_char_property (prev_old
, Qfield
, Qnil
))))
707 && (NILP (inhibit_capture_property
)
708 /* Field boundaries are again a problem; but now we must
709 decide the case exactly, so we need to call
710 `get_pos_property' as well. */
711 || (NILP (get_pos_property (old_pos
, inhibit_capture_property
, Qnil
))
712 && (XFASTINT (old_pos
) <= BEGV
713 || NILP (Fget_char_property (old_pos
, inhibit_capture_property
, Qnil
))
714 || NILP (Fget_char_property (prev_old
, inhibit_capture_property
, Qnil
))))))
715 /* It is possible that NEW_POS is not within the same field as
716 OLD_POS; try to move NEW_POS so that it is. */
719 Lisp_Object field_bound
;
722 field_bound
= Ffield_end (old_pos
, escape_from_edge
, new_pos
);
724 field_bound
= Ffield_beginning (old_pos
, escape_from_edge
, new_pos
);
726 if (/* See if ESCAPE_FROM_EDGE caused FIELD_BOUND to jump to the
727 other side of NEW_POS, which would mean that NEW_POS is
728 already acceptable, and it's not necessary to constrain it
730 ((XFASTINT (field_bound
) < XFASTINT (new_pos
)) ? fwd
: !fwd
)
731 /* NEW_POS should be constrained, but only if either
732 ONLY_IN_LINE is nil (in which case any constraint is OK),
733 or NEW_POS and FIELD_BOUND are on the same line (in which
734 case the constraint is OK even if ONLY_IN_LINE is non-nil). */
735 && (NILP (only_in_line
)
736 /* This is the ONLY_IN_LINE case, check that NEW_POS and
737 FIELD_BOUND are on the same line by seeing whether
738 there's an intervening newline or not. */
739 || (find_newline (XFASTINT (new_pos
), -1,
740 XFASTINT (field_bound
), -1,
741 fwd
? -1 : 1, &shortage
, NULL
, 1),
743 /* Constrain NEW_POS to FIELD_BOUND. */
744 new_pos
= field_bound
;
746 if (orig_point
&& XFASTINT (new_pos
) != orig_point
)
747 /* The NEW_POS argument was originally nil, so automatically set PT. */
748 SET_PT (XFASTINT (new_pos
));
755 DEFUN ("line-beginning-position",
756 Fline_beginning_position
, Sline_beginning_position
, 0, 1, 0,
757 doc
: /* Return the character position of the first character on the current line.
758 With optional argument N, scan forward N - 1 lines first.
759 If the scan reaches the end of the buffer, return that position.
761 This function ignores text display directionality; it returns the
762 position of the first character in logical order, i.e. the smallest
763 character position on the line.
765 This function constrains the returned position to the current field
766 unless that position would be on a different line than the original,
767 unconstrained result. If N is nil or 1, and a front-sticky field
768 starts at point, the scan stops as soon as it starts. To ignore field
769 boundaries, bind `inhibit-field-text-motion' to t.
771 This function does not move point. */)
774 ptrdiff_t orig
, orig_byte
, end
;
775 ptrdiff_t count
= SPECPDL_INDEX ();
776 specbind (Qinhibit_point_motion_hooks
, Qt
);
785 Fforward_line (make_number (XINT (n
) - 1));
788 SET_PT_BOTH (orig
, orig_byte
);
790 unbind_to (count
, Qnil
);
792 /* Return END constrained to the current input field. */
793 return Fconstrain_to_field (make_number (end
), make_number (orig
),
794 XINT (n
) != 1 ? Qt
: Qnil
,
798 DEFUN ("line-end-position", Fline_end_position
, Sline_end_position
, 0, 1, 0,
799 doc
: /* Return the character position of the last character on the current line.
800 With argument N not nil or 1, move forward N - 1 lines first.
801 If scan reaches end of buffer, return that position.
803 This function ignores text display directionality; it returns the
804 position of the last character in logical order, i.e. the largest
805 character position on the line.
807 This function constrains the returned position to the current field
808 unless that would be on a different line than the original,
809 unconstrained result. If N is nil or 1, and a rear-sticky field ends
810 at point, the scan stops as soon as it starts. To ignore field
811 boundaries bind `inhibit-field-text-motion' to t.
813 This function does not move point. */)
825 clipped_n
= clip_to_bounds (PTRDIFF_MIN
+ 1, XINT (n
), PTRDIFF_MAX
);
826 end_pos
= find_before_next_newline (orig
, 0, clipped_n
- (clipped_n
<= 0),
829 /* Return END_POS constrained to the current input field. */
830 return Fconstrain_to_field (make_number (end_pos
), make_number (orig
),
834 /* Save current buffer state for `save-excursion' special form.
835 We (ab)use Lisp_Misc_Save_Value to allow explicit free and so
836 offload some work from GC. */
839 save_excursion_save (void)
841 return make_save_obj_obj_obj_obj
843 /* Do not copy the mark if it points to nowhere. */
844 (XMARKER (BVAR (current_buffer
, mark
))->buffer
845 ? Fcopy_marker (BVAR (current_buffer
, mark
), Qnil
)
847 /* Selected window if current buffer is shown in it, nil otherwise. */
848 (EQ (XWINDOW (selected_window
)->contents
, Fcurrent_buffer ())
849 ? selected_window
: Qnil
),
850 BVAR (current_buffer
, mark_active
));
853 /* Restore saved buffer before leaving `save-excursion' special form. */
856 save_excursion_restore (Lisp_Object info
)
858 Lisp_Object tem
, tem1
, omark
, nmark
;
859 struct gcpro gcpro1
, gcpro2
, gcpro3
;
861 tem
= Fmarker_buffer (XSAVE_OBJECT (info
, 0));
862 /* If we're unwinding to top level, saved buffer may be deleted. This
863 means that all of its markers are unchained and so tem is nil. */
867 omark
= nmark
= Qnil
;
868 GCPRO3 (info
, omark
, nmark
);
873 tem
= XSAVE_OBJECT (info
, 0);
875 unchain_marker (XMARKER (tem
));
878 tem
= XSAVE_OBJECT (info
, 1);
879 omark
= Fmarker_position (BVAR (current_buffer
, mark
));
881 unchain_marker (XMARKER (BVAR (current_buffer
, mark
)));
884 Fset_marker (BVAR (current_buffer
, mark
), tem
, Fcurrent_buffer ());
885 nmark
= Fmarker_position (tem
);
886 unchain_marker (XMARKER (tem
));
890 tem
= XSAVE_OBJECT (info
, 3);
891 tem1
= BVAR (current_buffer
, mark_active
);
892 bset_mark_active (current_buffer
, tem
);
894 /* If mark is active now, and either was not active
895 or was at a different place, run the activate hook. */
898 if (! EQ (omark
, nmark
))
900 tem
= intern ("activate-mark-hook");
901 Frun_hooks (1, &tem
);
904 /* If mark has ceased to be active, run deactivate hook. */
905 else if (! NILP (tem1
))
907 tem
= intern ("deactivate-mark-hook");
908 Frun_hooks (1, &tem
);
911 /* If buffer was visible in a window, and a different window was
912 selected, and the old selected window is still showing this
913 buffer, restore point in that window. */
914 tem
= XSAVE_OBJECT (info
, 2);
916 && !EQ (tem
, selected_window
)
917 && (tem1
= XWINDOW (tem
)->contents
,
918 (/* Window is live... */
920 /* ...and it shows the current buffer. */
921 && XBUFFER (tem1
) == current_buffer
)))
922 Fset_window_point (tem
, make_number (PT
));
931 DEFUN ("save-excursion", Fsave_excursion
, Ssave_excursion
, 0, UNEVALLED
, 0,
932 doc
: /* Save point, mark, and current buffer; execute BODY; restore those things.
933 Executes BODY just like `progn'.
934 The values of point, mark and the current buffer are restored
935 even in case of abnormal exit (throw or error).
936 The state of activation of the mark is also restored.
938 This construct does not save `deactivate-mark', and therefore
939 functions that change the buffer will still cause deactivation
940 of the mark at the end of the command. To prevent that, bind
941 `deactivate-mark' with `let'.
943 If you only want to save the current buffer but not point nor mark,
944 then just use `save-current-buffer', or even `with-current-buffer'.
946 usage: (save-excursion &rest BODY) */)
949 register Lisp_Object val
;
950 ptrdiff_t count
= SPECPDL_INDEX ();
952 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
955 return unbind_to (count
, val
);
958 DEFUN ("save-current-buffer", Fsave_current_buffer
, Ssave_current_buffer
, 0, UNEVALLED
, 0,
959 doc
: /* Record which buffer is current; execute BODY; make that buffer current.
960 BODY is executed just like `progn'.
961 usage: (save-current-buffer &rest BODY) */)
964 ptrdiff_t count
= SPECPDL_INDEX ();
966 record_unwind_current_buffer ();
967 return unbind_to (count
, Fprogn (args
));
970 DEFUN ("buffer-size", Fbuffer_size
, Sbuffer_size
, 0, 1, 0,
971 doc
: /* Return the number of characters in the current buffer.
972 If BUFFER, return the number of characters in that buffer instead. */)
976 return make_number (Z
- BEG
);
979 CHECK_BUFFER (buffer
);
980 return make_number (BUF_Z (XBUFFER (buffer
))
981 - BUF_BEG (XBUFFER (buffer
)));
985 DEFUN ("point-min", Fpoint_min
, Spoint_min
, 0, 0, 0,
986 doc
: /* Return the minimum permissible value of point in the current buffer.
987 This is 1, unless narrowing (a buffer restriction) is in effect. */)
991 XSETFASTINT (temp
, BEGV
);
995 DEFUN ("point-min-marker", Fpoint_min_marker
, Spoint_min_marker
, 0, 0, 0,
996 doc
: /* Return a marker to the minimum permissible value of point in this buffer.
997 This is the beginning, unless narrowing (a buffer restriction) is in effect. */)
1000 return build_marker (current_buffer
, BEGV
, BEGV_BYTE
);
1003 DEFUN ("point-max", Fpoint_max
, Spoint_max
, 0, 0, 0,
1004 doc
: /* Return the maximum permissible value of point in the current buffer.
1005 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1006 is in effect, in which case it is less. */)
1010 XSETFASTINT (temp
, ZV
);
1014 DEFUN ("point-max-marker", Fpoint_max_marker
, Spoint_max_marker
, 0, 0, 0,
1015 doc
: /* Return a marker to the maximum permissible value of point in this buffer.
1016 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1017 is in effect, in which case it is less. */)
1020 return build_marker (current_buffer
, ZV
, ZV_BYTE
);
1023 DEFUN ("gap-position", Fgap_position
, Sgap_position
, 0, 0, 0,
1024 doc
: /* Return the position of the gap, in the current buffer.
1025 See also `gap-size'. */)
1029 XSETFASTINT (temp
, GPT
);
1033 DEFUN ("gap-size", Fgap_size
, Sgap_size
, 0, 0, 0,
1034 doc
: /* Return the size of the current buffer's gap.
1035 See also `gap-position'. */)
1039 XSETFASTINT (temp
, GAP_SIZE
);
1043 DEFUN ("position-bytes", Fposition_bytes
, Sposition_bytes
, 1, 1, 0,
1044 doc
: /* Return the byte position for character position POSITION.
1045 If POSITION is out of range, the value is nil. */)
1046 (Lisp_Object position
)
1048 CHECK_NUMBER_COERCE_MARKER (position
);
1049 if (XINT (position
) < BEG
|| XINT (position
) > Z
)
1051 return make_number (CHAR_TO_BYTE (XINT (position
)));
1054 DEFUN ("byte-to-position", Fbyte_to_position
, Sbyte_to_position
, 1, 1, 0,
1055 doc
: /* Return the character position for byte position BYTEPOS.
1056 If BYTEPOS is out of range, the value is nil. */)
1057 (Lisp_Object bytepos
)
1059 CHECK_NUMBER (bytepos
);
1060 if (XINT (bytepos
) < BEG_BYTE
|| XINT (bytepos
) > Z_BYTE
)
1062 return make_number (BYTE_TO_CHAR (XINT (bytepos
)));
1065 DEFUN ("following-char", Ffollowing_char
, Sfollowing_char
, 0, 0, 0,
1066 doc
: /* Return the character following point, as a number.
1067 At the end of the buffer or accessible region, return 0. */)
1072 XSETFASTINT (temp
, 0);
1074 XSETFASTINT (temp
, FETCH_CHAR (PT_BYTE
));
1078 DEFUN ("preceding-char", Fprevious_char
, Sprevious_char
, 0, 0, 0,
1079 doc
: /* Return the character preceding point, as a number.
1080 At the beginning of the buffer or accessible region, return 0. */)
1085 XSETFASTINT (temp
, 0);
1086 else if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
1088 ptrdiff_t pos
= PT_BYTE
;
1090 XSETFASTINT (temp
, FETCH_CHAR (pos
));
1093 XSETFASTINT (temp
, FETCH_BYTE (PT_BYTE
- 1));
1097 DEFUN ("bobp", Fbobp
, Sbobp
, 0, 0, 0,
1098 doc
: /* Return t if point is at the beginning of the buffer.
1099 If the buffer is narrowed, this means the beginning of the narrowed part. */)
1107 DEFUN ("eobp", Feobp
, Seobp
, 0, 0, 0,
1108 doc
: /* Return t if point is at the end of the buffer.
1109 If the buffer is narrowed, this means the end of the narrowed part. */)
1117 DEFUN ("bolp", Fbolp
, Sbolp
, 0, 0, 0,
1118 doc
: /* Return t if point is at the beginning of a line. */)
1121 if (PT
== BEGV
|| FETCH_BYTE (PT_BYTE
- 1) == '\n')
1126 DEFUN ("eolp", Feolp
, Seolp
, 0, 0, 0,
1127 doc
: /* Return t if point is at the end of a line.
1128 `End of a line' includes point being at the end of the buffer. */)
1131 if (PT
== ZV
|| FETCH_BYTE (PT_BYTE
) == '\n')
1136 DEFUN ("char-after", Fchar_after
, Schar_after
, 0, 1, 0,
1137 doc
: /* Return character in current buffer at position POS.
1138 POS is an integer or a marker and defaults to point.
1139 If POS is out of range, the value is nil. */)
1142 register ptrdiff_t pos_byte
;
1147 XSETFASTINT (pos
, PT
);
1152 pos_byte
= marker_byte_position (pos
);
1153 if (pos_byte
< BEGV_BYTE
|| pos_byte
>= ZV_BYTE
)
1158 CHECK_NUMBER_COERCE_MARKER (pos
);
1159 if (XINT (pos
) < BEGV
|| XINT (pos
) >= ZV
)
1162 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1165 return make_number (FETCH_CHAR (pos_byte
));
1168 DEFUN ("char-before", Fchar_before
, Schar_before
, 0, 1, 0,
1169 doc
: /* Return character in current buffer preceding position POS.
1170 POS is an integer or a marker and defaults to point.
1171 If POS is out of range, the value is nil. */)
1174 register Lisp_Object val
;
1175 register ptrdiff_t pos_byte
;
1180 XSETFASTINT (pos
, PT
);
1185 pos_byte
= marker_byte_position (pos
);
1187 if (pos_byte
<= BEGV_BYTE
|| pos_byte
> ZV_BYTE
)
1192 CHECK_NUMBER_COERCE_MARKER (pos
);
1194 if (XINT (pos
) <= BEGV
|| XINT (pos
) > ZV
)
1197 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1200 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
1203 XSETFASTINT (val
, FETCH_CHAR (pos_byte
));
1208 XSETFASTINT (val
, FETCH_BYTE (pos_byte
));
1213 DEFUN ("user-login-name", Fuser_login_name
, Suser_login_name
, 0, 1, 0,
1214 doc
: /* Return the name under which the user logged in, as a string.
1215 This is based on the effective uid, not the real uid.
1216 Also, if the environment variables LOGNAME or USER are set,
1217 that determines the value of this function.
1219 If optional argument UID is an integer or a float, return the login name
1220 of the user with that uid, or nil if there is no such user. */)
1226 /* Set up the user name info if we didn't do it before.
1227 (That can happen if Emacs is dumpable
1228 but you decide to run `temacs -l loadup' and not dump. */
1229 if (INTEGERP (Vuser_login_name
))
1233 return Vuser_login_name
;
1235 CONS_TO_INTEGER (uid
, uid_t
, id
);
1239 return (pw
? build_string (pw
->pw_name
) : Qnil
);
1242 DEFUN ("user-real-login-name", Fuser_real_login_name
, Suser_real_login_name
,
1244 doc
: /* Return the name of the user's real uid, as a string.
1245 This ignores the environment variables LOGNAME and USER, so it differs from
1246 `user-login-name' when running under `su'. */)
1249 /* Set up the user name info if we didn't do it before.
1250 (That can happen if Emacs is dumpable
1251 but you decide to run `temacs -l loadup' and not dump. */
1252 if (INTEGERP (Vuser_login_name
))
1254 return Vuser_real_login_name
;
1257 DEFUN ("user-uid", Fuser_uid
, Suser_uid
, 0, 0, 0,
1258 doc
: /* Return the effective uid of Emacs.
1259 Value is an integer or a float, depending on the value. */)
1262 uid_t euid
= geteuid ();
1263 return make_fixnum_or_float (euid
);
1266 DEFUN ("user-real-uid", Fuser_real_uid
, Suser_real_uid
, 0, 0, 0,
1267 doc
: /* Return the real uid of Emacs.
1268 Value is an integer or a float, depending on the value. */)
1271 uid_t uid
= getuid ();
1272 return make_fixnum_or_float (uid
);
1275 DEFUN ("group-gid", Fgroup_gid
, Sgroup_gid
, 0, 0, 0,
1276 doc
: /* Return the effective gid of Emacs.
1277 Value is an integer or a float, depending on the value. */)
1280 gid_t egid
= getegid ();
1281 return make_fixnum_or_float (egid
);
1284 DEFUN ("group-real-gid", Fgroup_real_gid
, Sgroup_real_gid
, 0, 0, 0,
1285 doc
: /* Return the real gid of Emacs.
1286 Value is an integer or a float, depending on the value. */)
1289 gid_t gid
= getgid ();
1290 return make_fixnum_or_float (gid
);
1293 DEFUN ("user-full-name", Fuser_full_name
, Suser_full_name
, 0, 1, 0,
1294 doc
: /* Return the full name of the user logged in, as a string.
1295 If the full name corresponding to Emacs's userid is not known,
1298 If optional argument UID is an integer or float, return the full name
1299 of the user with that uid, or nil if there is no such user.
1300 If UID is a string, return the full name of the user with that login
1301 name, or nil if there is no such user. */)
1305 register char *p
, *q
;
1309 return Vuser_full_name
;
1310 else if (NUMBERP (uid
))
1313 CONS_TO_INTEGER (uid
, uid_t
, u
);
1318 else if (STRINGP (uid
))
1321 pw
= getpwnam (SSDATA (uid
));
1325 error ("Invalid UID specification");
1331 /* Chop off everything after the first comma. */
1332 q
= strchr (p
, ',');
1333 full
= make_string (p
, q
? q
- p
: strlen (p
));
1335 #ifdef AMPERSAND_FULL_NAME
1337 q
= strchr (p
, '&');
1338 /* Substitute the login name for the &, upcasing the first character. */
1344 login
= Fuser_login_name (make_number (pw
->pw_uid
));
1345 r
= alloca (strlen (p
) + SCHARS (login
) + 1);
1346 memcpy (r
, p
, q
- p
);
1348 strcat (r
, SSDATA (login
));
1349 r
[q
- p
] = upcase ((unsigned char) r
[q
- p
]);
1351 full
= build_string (r
);
1353 #endif /* AMPERSAND_FULL_NAME */
1358 DEFUN ("system-name", Fsystem_name
, Ssystem_name
, 0, 0, 0,
1359 doc
: /* Return the host name of the machine you are running on, as a string. */)
1362 return Vsystem_name
;
1365 DEFUN ("emacs-pid", Femacs_pid
, Semacs_pid
, 0, 0, 0,
1366 doc
: /* Return the process ID of Emacs, as a number. */)
1369 pid_t pid
= getpid ();
1370 return make_fixnum_or_float (pid
);
1376 # define TIME_T_MIN TYPE_MINIMUM (time_t)
1379 # define TIME_T_MAX TYPE_MAXIMUM (time_t)
1382 /* Report that a time value is out of range for Emacs. */
1384 time_overflow (void)
1386 error ("Specified time is not representable");
1389 /* Return the upper part of the time T (everything but the bottom 16 bits). */
1393 time_t hi
= t
>> 16;
1395 /* Check for overflow, helping the compiler for common cases where
1396 no runtime check is needed, and taking care not to convert
1397 negative numbers to unsigned before comparing them. */
1398 if (! ((! TYPE_SIGNED (time_t)
1399 || MOST_NEGATIVE_FIXNUM
<= TIME_T_MIN
>> 16
1400 || MOST_NEGATIVE_FIXNUM
<= hi
)
1401 && (TIME_T_MAX
>> 16 <= MOST_POSITIVE_FIXNUM
1402 || hi
<= MOST_POSITIVE_FIXNUM
)))
1408 /* Return the bottom 16 bits of the time T. */
1412 return t
& ((1 << 16) - 1);
1415 DEFUN ("current-time", Fcurrent_time
, Scurrent_time
, 0, 0, 0,
1416 doc
: /* Return the current time, as the number of seconds since 1970-01-01 00:00:00.
1417 The time is returned as a list of integers (HIGH LOW USEC PSEC).
1418 HIGH has the most significant bits of the seconds, while LOW has the
1419 least significant 16 bits. USEC and PSEC are the microsecond and
1420 picosecond counts. */)
1423 return make_lisp_time (current_emacs_time ());
1426 DEFUN ("get-internal-run-time", Fget_internal_run_time
, Sget_internal_run_time
,
1428 doc
: /* Return the current run time used by Emacs.
1429 The time is returned as a list (HIGH LOW USEC PSEC), using the same
1430 style as (current-time).
1432 On systems that can't determine the run time, `get-internal-run-time'
1433 does the same thing as `current-time'. */)
1436 #ifdef HAVE_GETRUSAGE
1437 struct rusage usage
;
1441 if (getrusage (RUSAGE_SELF
, &usage
) < 0)
1442 /* This shouldn't happen. What action is appropriate? */
1445 /* Sum up user time and system time. */
1446 secs
= usage
.ru_utime
.tv_sec
+ usage
.ru_stime
.tv_sec
;
1447 usecs
= usage
.ru_utime
.tv_usec
+ usage
.ru_stime
.tv_usec
;
1448 if (usecs
>= 1000000)
1453 return make_lisp_time (make_emacs_time (secs
, usecs
* 1000));
1454 #else /* ! HAVE_GETRUSAGE */
1456 return w32_get_internal_run_time ();
1457 #else /* ! WINDOWSNT */
1458 return Fcurrent_time ();
1459 #endif /* WINDOWSNT */
1460 #endif /* HAVE_GETRUSAGE */
1464 /* Make a Lisp list that represents the time T with fraction TAIL. */
1466 make_time_tail (time_t t
, Lisp_Object tail
)
1468 return Fcons (make_number (hi_time (t
)),
1469 Fcons (make_number (lo_time (t
)), tail
));
1472 /* Make a Lisp list that represents the system time T. */
1474 make_time (time_t t
)
1476 return make_time_tail (t
, Qnil
);
1479 /* Make a Lisp list that represents the Emacs time T. T may be an
1480 invalid time, with a slightly negative tv_nsec value such as
1481 UNKNOWN_MODTIME_NSECS; in that case, the Lisp list contains a
1482 correspondingly negative picosecond count. */
1484 make_lisp_time (EMACS_TIME t
)
1486 int ns
= EMACS_NSECS (t
);
1487 return make_time_tail (EMACS_SECS (t
), list2i (ns
/ 1000, ns
% 1000 * 1000));
1490 /* Decode a Lisp list SPECIFIED_TIME that represents a time.
1491 Set *PHIGH, *PLOW, *PUSEC, *PPSEC to its parts; do not check their values.
1492 Return true if successful. */
1494 disassemble_lisp_time (Lisp_Object specified_time
, Lisp_Object
*phigh
,
1495 Lisp_Object
*plow
, Lisp_Object
*pusec
,
1498 if (CONSP (specified_time
))
1500 Lisp_Object low
= XCDR (specified_time
);
1501 Lisp_Object usec
= make_number (0);
1502 Lisp_Object psec
= make_number (0);
1505 Lisp_Object low_tail
= XCDR (low
);
1507 if (CONSP (low_tail
))
1509 usec
= XCAR (low_tail
);
1510 low_tail
= XCDR (low_tail
);
1511 if (CONSP (low_tail
))
1512 psec
= XCAR (low_tail
);
1514 else if (!NILP (low_tail
))
1518 *phigh
= XCAR (specified_time
);
1528 /* From the time components HIGH, LOW, USEC and PSEC taken from a Lisp
1529 list, generate the corresponding time value.
1531 If RESULT is not null, store into *RESULT the converted time;
1532 this can fail if the converted time does not fit into EMACS_TIME.
1533 If *DRESULT is not null, store into *DRESULT the number of
1534 seconds since the start of the POSIX Epoch.
1536 Return true if successful. */
1538 decode_time_components (Lisp_Object high
, Lisp_Object low
, Lisp_Object usec
,
1540 EMACS_TIME
*result
, double *dresult
)
1542 EMACS_INT hi
, lo
, us
, ps
;
1543 if (! (INTEGERP (high
) && INTEGERP (low
)
1544 && INTEGERP (usec
) && INTEGERP (psec
)))
1551 /* Normalize out-of-range lower-order components by carrying
1552 each overflow into the next higher-order component. */
1553 us
+= ps
/ 1000000 - (ps
% 1000000 < 0);
1554 lo
+= us
/ 1000000 - (us
% 1000000 < 0);
1556 ps
= ps
% 1000000 + 1000000 * (ps
% 1000000 < 0);
1557 us
= us
% 1000000 + 1000000 * (us
% 1000000 < 0);
1558 lo
&= (1 << 16) - 1;
1562 if ((TYPE_SIGNED (time_t) ? TIME_T_MIN
>> 16 <= hi
: 0 <= hi
)
1563 && hi
<= TIME_T_MAX
>> 16)
1565 /* Return the greatest representable time that is not greater
1566 than the requested time. */
1568 *result
= make_emacs_time ((sec
<< 16) + lo
, us
* 1000 + ps
/ 1000);
1572 /* Overflow in the highest-order component. */
1578 *dresult
= (us
* 1e6
+ ps
) / 1e12
+ lo
+ hi
* 65536.0;
1583 /* Decode a Lisp list SPECIFIED_TIME that represents a time.
1584 If SPECIFIED_TIME is nil, use the current time.
1586 Round the time down to the nearest EMACS_TIME value.
1587 Return seconds since the Epoch.
1588 Signal an error if unsuccessful. */
1590 lisp_time_argument (Lisp_Object specified_time
)
1593 if (NILP (specified_time
))
1594 t
= current_emacs_time ();
1597 Lisp_Object high
, low
, usec
, psec
;
1598 if (! (disassemble_lisp_time (specified_time
, &high
, &low
, &usec
, &psec
)
1599 && decode_time_components (high
, low
, usec
, psec
, &t
, 0)))
1600 error ("Invalid time specification");
1605 /* Like lisp_time_argument, except decode only the seconds part,
1606 do not allow out-of-range time stamps, do not check the subseconds part,
1607 and always round down. */
1609 lisp_seconds_argument (Lisp_Object specified_time
)
1611 if (NILP (specified_time
))
1615 Lisp_Object high
, low
, usec
, psec
;
1617 if (! (disassemble_lisp_time (specified_time
, &high
, &low
, &usec
, &psec
)
1618 && decode_time_components (high
, low
, make_number (0),
1619 make_number (0), &t
, 0)))
1620 error ("Invalid time specification");
1621 return EMACS_SECS (t
);
1625 DEFUN ("float-time", Ffloat_time
, Sfloat_time
, 0, 1, 0,
1626 doc
: /* Return the current time, as a float number of seconds since the epoch.
1627 If SPECIFIED-TIME is given, it is the time to convert to float
1628 instead of the current time. The argument should have the form
1629 (HIGH LOW) or (HIGH LOW USEC) or (HIGH LOW USEC PSEC). Thus,
1630 you can use times from `current-time' and from `file-attributes'.
1631 SPECIFIED-TIME can also have the form (HIGH . LOW), but this is
1632 considered obsolete.
1634 WARNING: Since the result is floating point, it may not be exact.
1635 If precise time stamps are required, use either `current-time',
1636 or (if you need time as a string) `format-time-string'. */)
1637 (Lisp_Object specified_time
)
1640 if (NILP (specified_time
))
1642 EMACS_TIME now
= current_emacs_time ();
1643 t
= EMACS_SECS (now
) + EMACS_NSECS (now
) / 1e9
;
1647 Lisp_Object high
, low
, usec
, psec
;
1648 if (! (disassemble_lisp_time (specified_time
, &high
, &low
, &usec
, &psec
)
1649 && decode_time_components (high
, low
, usec
, psec
, 0, &t
)))
1650 error ("Invalid time specification");
1652 return make_float (t
);
1655 /* Write information into buffer S of size MAXSIZE, according to the
1656 FORMAT of length FORMAT_LEN, using time information taken from *TP.
1657 Default to Universal Time if UT, local time otherwise.
1658 Use NS as the number of nanoseconds in the %N directive.
1659 Return the number of bytes written, not including the terminating
1660 '\0'. If S is NULL, nothing will be written anywhere; so to
1661 determine how many bytes would be written, use NULL for S and
1662 ((size_t) -1) for MAXSIZE.
1664 This function behaves like nstrftime, except it allows null
1665 bytes in FORMAT and it does not support nanoseconds. */
1667 emacs_nmemftime (char *s
, size_t maxsize
, const char *format
,
1668 size_t format_len
, const struct tm
*tp
, bool ut
, int ns
)
1672 /* Loop through all the null-terminated strings in the format
1673 argument. Normally there's just one null-terminated string, but
1674 there can be arbitrarily many, concatenated together, if the
1675 format contains '\0' bytes. nstrftime stops at the first
1676 '\0' byte so we must invoke it separately for each such string. */
1685 result
= nstrftime (s
, maxsize
, format
, tp
, ut
, ns
);
1689 if (result
== 0 && s
[0] != '\0')
1694 maxsize
-= result
+ 1;
1696 len
= strlen (format
);
1697 if (len
== format_len
)
1701 format_len
-= len
+ 1;
1705 DEFUN ("format-time-string", Fformat_time_string
, Sformat_time_string
, 1, 3, 0,
1706 doc
: /* Use FORMAT-STRING to format the time TIME, or now if omitted.
1707 TIME is specified as (HIGH LOW USEC PSEC), as returned by
1708 `current-time' or `file-attributes'. The obsolete form (HIGH . LOW)
1709 is also still accepted.
1710 The third, optional, argument UNIVERSAL, if non-nil, means describe TIME
1711 as Universal Time; nil means describe TIME in the local time zone.
1712 The value is a copy of FORMAT-STRING, but with certain constructs replaced
1713 by text that describes the specified date and time in TIME:
1715 %Y is the year, %y within the century, %C the century.
1716 %G is the year corresponding to the ISO week, %g within the century.
1717 %m is the numeric month.
1718 %b and %h are the locale's abbreviated month name, %B the full name.
1719 %d is the day of the month, zero-padded, %e is blank-padded.
1720 %u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.
1721 %a is the locale's abbreviated name of the day of week, %A the full name.
1722 %U is the week number starting on Sunday, %W starting on Monday,
1723 %V according to ISO 8601.
1724 %j is the day of the year.
1726 %H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H
1727 only blank-padded, %l is like %I blank-padded.
1728 %p is the locale's equivalent of either AM or PM.
1731 %N is the nanosecond, %6N the microsecond, %3N the millisecond, etc.
1732 %Z is the time zone name, %z is the numeric form.
1733 %s is the number of seconds since 1970-01-01 00:00:00 +0000.
1735 %c is the locale's date and time format.
1736 %x is the locale's "preferred" date format.
1737 %D is like "%m/%d/%y".
1739 %R is like "%H:%M", %T is like "%H:%M:%S", %r is like "%I:%M:%S %p".
1740 %X is the locale's "preferred" time format.
1742 Finally, %n is a newline, %t is a tab, %% is a literal %.
1744 Certain flags and modifiers are available with some format controls.
1745 The flags are `_', `-', `^' and `#'. For certain characters X,
1746 %_X is like %X, but padded with blanks; %-X is like %X,
1747 but without padding. %^X is like %X, but with all textual
1748 characters up-cased; %#X is like %X, but with letter-case of
1749 all textual characters reversed.
1750 %NX (where N stands for an integer) is like %X,
1751 but takes up at least N (a number) positions.
1752 The modifiers are `E' and `O'. For certain characters X,
1753 %EX is a locale's alternative version of %X;
1754 %OX is like %X, but uses the locale's number symbols.
1756 For example, to produce full ISO 8601 format, use "%Y-%m-%dT%T%z".
1758 usage: (format-time-string FORMAT-STRING &optional TIME UNIVERSAL) */)
1759 (Lisp_Object format_string
, Lisp_Object timeval
, Lisp_Object universal
)
1761 EMACS_TIME t
= lisp_time_argument (timeval
);
1764 CHECK_STRING (format_string
);
1765 format_string
= code_convert_string_norecord (format_string
,
1766 Vlocale_coding_system
, 1);
1767 return format_time_string (SSDATA (format_string
), SBYTES (format_string
),
1768 t
, ! NILP (universal
), &tm
);
1772 format_time_string (char const *format
, ptrdiff_t formatlen
,
1773 EMACS_TIME t
, bool ut
, struct tm
*tmp
)
1777 ptrdiff_t size
= sizeof buffer
;
1779 Lisp_Object bufstring
;
1780 int ns
= EMACS_NSECS (t
);
1786 time_t *taddr
= emacs_secs_addr (&t
);
1789 synchronize_system_time_locale ();
1791 tm
= ut
? gmtime (taddr
) : localtime (taddr
);
1800 len
= emacs_nmemftime (buf
, size
, format
, formatlen
, tm
, ut
, ns
);
1801 if ((0 < len
&& len
< size
) || (len
== 0 && buf
[0] == '\0'))
1804 /* Buffer was too small, so make it bigger and try again. */
1805 len
= emacs_nmemftime (NULL
, SIZE_MAX
, format
, formatlen
, tm
, ut
, ns
);
1807 if (STRING_BYTES_BOUND
<= len
)
1810 buf
= SAFE_ALLOCA (size
);
1814 bufstring
= make_unibyte_string (buf
, len
);
1816 return code_convert_string_norecord (bufstring
, Vlocale_coding_system
, 0);
1819 DEFUN ("decode-time", Fdecode_time
, Sdecode_time
, 0, 1, 0,
1820 doc
: /* Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST ZONE).
1821 The optional SPECIFIED-TIME should be a list of (HIGH LOW . IGNORED),
1822 as from `current-time' and `file-attributes', or nil to use the
1823 current time. The obsolete form (HIGH . LOW) is also still accepted.
1824 The list has the following nine members: SEC is an integer between 0
1825 and 60; SEC is 60 for a leap second, which only some operating systems
1826 support. MINUTE is an integer between 0 and 59. HOUR is an integer
1827 between 0 and 23. DAY is an integer between 1 and 31. MONTH is an
1828 integer between 1 and 12. YEAR is an integer indicating the
1829 four-digit year. DOW is the day of week, an integer between 0 and 6,
1830 where 0 is Sunday. DST is t if daylight saving time is in effect,
1831 otherwise nil. ZONE is an integer indicating the number of seconds
1832 east of Greenwich. (Note that Common Lisp has different meanings for
1834 (Lisp_Object specified_time
)
1836 time_t time_spec
= lisp_seconds_argument (specified_time
);
1838 struct tm
*decoded_time
;
1839 Lisp_Object list_args
[9];
1842 decoded_time
= localtime (&time_spec
);
1844 save_tm
= *decoded_time
;
1847 && MOST_NEGATIVE_FIXNUM
- TM_YEAR_BASE
<= save_tm
.tm_year
1848 && save_tm
.tm_year
<= MOST_POSITIVE_FIXNUM
- TM_YEAR_BASE
))
1850 XSETFASTINT (list_args
[0], save_tm
.tm_sec
);
1851 XSETFASTINT (list_args
[1], save_tm
.tm_min
);
1852 XSETFASTINT (list_args
[2], save_tm
.tm_hour
);
1853 XSETFASTINT (list_args
[3], save_tm
.tm_mday
);
1854 XSETFASTINT (list_args
[4], save_tm
.tm_mon
+ 1);
1855 /* On 64-bit machines an int is narrower than EMACS_INT, thus the
1856 cast below avoids overflow in int arithmetics. */
1857 XSETINT (list_args
[5], TM_YEAR_BASE
+ (EMACS_INT
) save_tm
.tm_year
);
1858 XSETFASTINT (list_args
[6], save_tm
.tm_wday
);
1859 list_args
[7] = save_tm
.tm_isdst
? Qt
: Qnil
;
1862 decoded_time
= gmtime (&time_spec
);
1863 if (decoded_time
== 0)
1864 list_args
[8] = Qnil
;
1866 XSETINT (list_args
[8], tm_diff (&save_tm
, decoded_time
));
1868 return Flist (9, list_args
);
1871 /* Return OBJ - OFFSET, checking that OBJ is a valid fixnum and that
1872 the result is representable as an int. Assume OFFSET is small and
1875 check_tm_member (Lisp_Object obj
, int offset
)
1880 if (! (INT_MIN
+ offset
<= n
&& n
- offset
<= INT_MAX
))
1885 DEFUN ("encode-time", Fencode_time
, Sencode_time
, 6, MANY
, 0,
1886 doc
: /* Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.
1887 This is the reverse operation of `decode-time', which see.
1888 ZONE defaults to the current time zone rule. This can
1889 be a string or t (as from `set-time-zone-rule'), or it can be a list
1890 \(as from `current-time-zone') or an integer (as from `decode-time')
1891 applied without consideration for daylight saving time.
1893 You can pass more than 7 arguments; then the first six arguments
1894 are used as SECOND through YEAR, and the *last* argument is used as ZONE.
1895 The intervening arguments are ignored.
1896 This feature lets (apply 'encode-time (decode-time ...)) work.
1898 Out-of-range values for SECOND, MINUTE, HOUR, DAY, or MONTH are allowed;
1899 for example, a DAY of 0 means the day preceding the given month.
1900 Year numbers less than 100 are treated just like other year numbers.
1901 If you want them to stand for years in this century, you must do that yourself.
1903 Years before 1970 are not guaranteed to work. On some systems,
1904 year values as low as 1901 do work.
1906 usage: (encode-time SECOND MINUTE HOUR DAY MONTH YEAR &optional ZONE) */)
1907 (ptrdiff_t nargs
, Lisp_Object
*args
)
1911 Lisp_Object zone
= (nargs
> 6 ? args
[nargs
- 1] : Qnil
);
1913 tm
.tm_sec
= check_tm_member (args
[0], 0);
1914 tm
.tm_min
= check_tm_member (args
[1], 0);
1915 tm
.tm_hour
= check_tm_member (args
[2], 0);
1916 tm
.tm_mday
= check_tm_member (args
[3], 0);
1917 tm
.tm_mon
= check_tm_member (args
[4], 1);
1918 tm
.tm_year
= check_tm_member (args
[5], TM_YEAR_BASE
);
1926 value
= mktime (&tm
);
1931 static char const tzbuf_format
[] = "XXX%s%"pI
"d:%02d:%02d";
1932 char tzbuf
[sizeof tzbuf_format
+ INT_STRLEN_BOUND (EMACS_INT
)];
1934 const char *tzstring
;
1939 else if (STRINGP (zone
))
1940 tzstring
= SSDATA (zone
);
1941 else if (INTEGERP (zone
))
1943 EMACS_INT abszone
= eabs (XINT (zone
));
1944 EMACS_INT zone_hr
= abszone
/ (60*60);
1945 int zone_min
= (abszone
/60) % 60;
1946 int zone_sec
= abszone
% 60;
1947 sprintf (tzbuf
, tzbuf_format
, &"-"[XINT (zone
) < 0],
1948 zone_hr
, zone_min
, zone_sec
);
1952 error ("Invalid time zone specification");
1954 old_tzstring
= getenv ("TZ");
1957 char *buf
= SAFE_ALLOCA (strlen (old_tzstring
) + 1);
1958 old_tzstring
= strcpy (buf
, old_tzstring
);
1963 /* Set TZ before calling mktime; merely adjusting mktime's returned
1964 value doesn't suffice, since that would mishandle leap seconds. */
1965 set_time_zone_rule (tzstring
);
1967 value
= mktime (&tm
);
1969 set_time_zone_rule (old_tzstring
);
1970 #ifdef LOCALTIME_CACHE
1977 if (value
== (time_t) -1)
1980 return make_time (value
);
1983 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
, 0, 1, 0,
1984 doc
: /* Return the current local time, as a human-readable string.
1985 Programs can use this function to decode a time,
1986 since the number of columns in each field is fixed
1987 if the year is in the range 1000-9999.
1988 The format is `Sun Sep 16 01:03:52 1973'.
1989 However, see also the functions `decode-time' and `format-time-string'
1990 which provide a much more powerful and general facility.
1992 If SPECIFIED-TIME is given, it is a time to format instead of the
1993 current time. The argument should have the form (HIGH LOW . IGNORED).
1994 Thus, you can use times obtained from `current-time' and from
1995 `file-attributes'. SPECIFIED-TIME can also have the form (HIGH . LOW),
1996 but this is considered obsolete. */)
1997 (Lisp_Object specified_time
)
1999 time_t value
= lisp_seconds_argument (specified_time
);
2001 char buf
[sizeof "Mon Apr 30 12:49:17 " + INT_STRLEN_BOUND (int) + 1];
2002 int len
IF_LINT (= 0);
2004 /* Convert to a string in ctime format, except without the trailing
2005 newline, and without the 4-digit year limit. Don't use asctime
2006 or ctime, as they might dump core if the year is outside the
2007 range -999 .. 9999. */
2009 tm
= localtime (&value
);
2012 static char const wday_name
[][4] =
2013 { "Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat" };
2014 static char const mon_name
[][4] =
2015 { "Jan", "Feb", "Mar", "Apr", "May", "Jun",
2016 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" };
2017 printmax_t year_base
= TM_YEAR_BASE
;
2019 len
= sprintf (buf
, "%s %s%3d %02d:%02d:%02d %"pMd
,
2020 wday_name
[tm
->tm_wday
], mon_name
[tm
->tm_mon
], tm
->tm_mday
,
2021 tm
->tm_hour
, tm
->tm_min
, tm
->tm_sec
,
2022 tm
->tm_year
+ year_base
);
2028 return make_unibyte_string (buf
, len
);
2031 /* Yield A - B, measured in seconds.
2032 This function is copied from the GNU C Library. */
2034 tm_diff (struct tm
*a
, struct tm
*b
)
2036 /* Compute intervening leap days correctly even if year is negative.
2037 Take care to avoid int overflow in leap day calculations,
2038 but it's OK to assume that A and B are close to each other. */
2039 int a4
= (a
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (a
->tm_year
& 3);
2040 int b4
= (b
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (b
->tm_year
& 3);
2041 int a100
= a4
/ 25 - (a4
% 25 < 0);
2042 int b100
= b4
/ 25 - (b4
% 25 < 0);
2043 int a400
= a100
>> 2;
2044 int b400
= b100
>> 2;
2045 int intervening_leap_days
= (a4
- b4
) - (a100
- b100
) + (a400
- b400
);
2046 int years
= a
->tm_year
- b
->tm_year
;
2047 int days
= (365 * years
+ intervening_leap_days
2048 + (a
->tm_yday
- b
->tm_yday
));
2049 return (60 * (60 * (24 * days
+ (a
->tm_hour
- b
->tm_hour
))
2050 + (a
->tm_min
- b
->tm_min
))
2051 + (a
->tm_sec
- b
->tm_sec
));
2054 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 1, 0,
2055 doc
: /* Return the offset and name for the local time zone.
2056 This returns a list of the form (OFFSET NAME).
2057 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).
2058 A negative value means west of Greenwich.
2059 NAME is a string giving the name of the time zone.
2060 If SPECIFIED-TIME is given, the time zone offset is determined from it
2061 instead of using the current time. The argument should have the form
2062 (HIGH LOW . IGNORED). Thus, you can use times obtained from
2063 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
2064 have the form (HIGH . LOW), but this is considered obsolete.
2066 Some operating systems cannot provide all this information to Emacs;
2067 in this case, `current-time-zone' returns a list containing nil for
2068 the data it can't find. */)
2069 (Lisp_Object specified_time
)
2075 Lisp_Object zone_offset
, zone_name
;
2078 value
= make_emacs_time (lisp_seconds_argument (specified_time
), 0);
2079 zone_name
= format_time_string ("%Z", sizeof "%Z" - 1, value
, 0, &localtm
);
2081 t
= gmtime (emacs_secs_addr (&value
));
2083 offset
= tm_diff (&localtm
, t
);
2088 zone_offset
= make_number (offset
);
2089 if (SCHARS (zone_name
) == 0)
2091 /* No local time zone name is available; use "+-NNNN" instead. */
2092 int m
= offset
/ 60;
2093 int am
= offset
< 0 ? - m
: m
;
2094 char buf
[sizeof "+00" + INT_STRLEN_BOUND (int)];
2095 zone_name
= make_formatted_string (buf
, "%c%02d%02d",
2096 (offset
< 0 ? '-' : '+'),
2101 return list2 (zone_offset
, zone_name
);
2104 DEFUN ("set-time-zone-rule", Fset_time_zone_rule
, Sset_time_zone_rule
, 1, 1, 0,
2105 doc
: /* Set the local time zone using TZ, a string specifying a time zone rule.
2106 If TZ is nil, use implementation-defined default time zone information.
2107 If TZ is t, use Universal Time.
2109 Instead of calling this function, you typically want (setenv "TZ" TZ).
2110 That changes both the environment of the Emacs process and the
2111 variable `process-environment', whereas `set-time-zone-rule' affects
2112 only the former. */)
2115 const char *tzstring
;
2117 if (! (NILP (tz
) || EQ (tz
, Qt
)))
2121 tzstring
= initial_tz
;
2122 else if (EQ (tz
, Qt
))
2125 tzstring
= SSDATA (tz
);
2128 set_time_zone_rule (tzstring
);
2134 /* Set the local time zone rule to TZSTRING.
2136 This function is not thread-safe, partly because putenv, unsetenv
2137 and tzset are not, and partly because of the static storage it
2138 updates. Other threads that invoke localtime etc. may be adversely
2139 affected while this function is executing. */
2142 set_time_zone_rule (const char *tzstring
)
2144 /* A buffer holding a string of the form "TZ=value", intended
2145 to be part of the environment. */
2146 static char *tzvalbuf
;
2147 static ptrdiff_t tzvalbufsize
;
2149 int tzeqlen
= sizeof "TZ=" - 1;
2151 #ifdef LOCALTIME_CACHE
2152 /* These two values are known to load tz files in buggy implementations,
2153 i.e., Solaris 1 executables running under either Solaris 1 or Solaris 2.
2154 Their values shouldn't matter in non-buggy implementations.
2155 We don't use string literals for these strings,
2156 since if a string in the environment is in readonly
2157 storage, it runs afoul of bugs in SVR4 and Solaris 2.3.
2158 See Sun bugs 1113095 and 1114114, ``Timezone routines
2159 improperly modify environment''. */
2161 static char set_time_zone_rule_tz
[][sizeof "TZ=GMT+0"]
2162 = { "TZ=GMT+0", "TZ=GMT+1" };
2164 /* In SunOS 4.1.3_U1 and 4.1.4, if TZ has a value like
2165 "US/Pacific" that loads a tz file, then changes to a value like
2166 "XXX0" that does not load a tz file, and then changes back to
2167 its original value, the last change is (incorrectly) ignored.
2168 Also, if TZ changes twice in succession to values that do
2169 not load a tz file, tzset can dump core (see Sun bug#1225179).
2170 The following code works around these bugs. */
2174 /* Temporarily set TZ to a value that loads a tz file
2175 and that differs from tzstring. */
2176 bool eq0
= strcmp (tzstring
, set_time_zone_rule_tz
[0] + tzeqlen
) == 0;
2177 xputenv (set_time_zone_rule_tz
[eq0
]);
2181 /* The implied tzstring is unknown, so temporarily set TZ to
2182 two different values that each load a tz file. */
2183 xputenv (set_time_zone_rule_tz
[0]);
2185 xputenv (set_time_zone_rule_tz
[1]);
2188 tzvalbuf_in_environ
= 0;
2194 tzvalbuf_in_environ
= 0;
2198 ptrdiff_t tzstringlen
= strlen (tzstring
);
2200 if (tzvalbufsize
<= tzeqlen
+ tzstringlen
)
2203 tzvalbuf_in_environ
= 0;
2204 tzvalbuf
= xpalloc (tzvalbuf
, &tzvalbufsize
,
2205 tzeqlen
+ tzstringlen
- tzvalbufsize
+ 1, -1, 1);
2206 memcpy (tzvalbuf
, "TZ=", tzeqlen
);
2209 strcpy (tzvalbuf
+ tzeqlen
, tzstring
);
2211 if (!tzvalbuf_in_environ
)
2214 tzvalbuf_in_environ
= 1;
2218 #ifdef LOCALTIME_CACHE
2223 /* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC
2224 (if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a
2225 type of object is Lisp_String). INHERIT is passed to
2226 INSERT_FROM_STRING_FUNC as the last argument. */
2229 general_insert_function (void (*insert_func
)
2230 (const char *, ptrdiff_t),
2231 void (*insert_from_string_func
)
2232 (Lisp_Object
, ptrdiff_t, ptrdiff_t,
2233 ptrdiff_t, ptrdiff_t, bool),
2234 bool inherit
, ptrdiff_t nargs
, Lisp_Object
*args
)
2239 for (argnum
= 0; argnum
< nargs
; argnum
++)
2242 if (CHARACTERP (val
))
2244 int c
= XFASTINT (val
);
2245 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2248 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2249 len
= CHAR_STRING (c
, str
);
2252 str
[0] = ASCII_CHAR_P (c
) ? c
: multibyte_char_to_unibyte (c
);
2255 (*insert_func
) ((char *) str
, len
);
2257 else if (STRINGP (val
))
2259 (*insert_from_string_func
) (val
, 0, 0,
2265 wrong_type_argument (Qchar_or_string_p
, val
);
2270 insert1 (Lisp_Object arg
)
2276 /* Callers passing one argument to Finsert need not gcpro the
2277 argument "array", since the only element of the array will
2278 not be used after calling insert or insert_from_string, so
2279 we don't care if it gets trashed. */
2281 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
2282 doc
: /* Insert the arguments, either strings or characters, at point.
2283 Point and before-insertion markers move forward to end up
2284 after the inserted text.
2285 Any other markers at the point of insertion remain before the text.
2287 If the current buffer is multibyte, unibyte strings are converted
2288 to multibyte for insertion (see `string-make-multibyte').
2289 If the current buffer is unibyte, multibyte strings are converted
2290 to unibyte for insertion (see `string-make-unibyte').
2292 When operating on binary data, it may be necessary to preserve the
2293 original bytes of a unibyte string when inserting it into a multibyte
2294 buffer; to accomplish this, apply `string-as-multibyte' to the string
2295 and insert the result.
2297 usage: (insert &rest ARGS) */)
2298 (ptrdiff_t nargs
, Lisp_Object
*args
)
2300 general_insert_function (insert
, insert_from_string
, 0, nargs
, args
);
2304 DEFUN ("insert-and-inherit", Finsert_and_inherit
, Sinsert_and_inherit
,
2306 doc
: /* Insert the arguments at point, inheriting properties from adjoining text.
2307 Point and before-insertion markers move forward to end up
2308 after the inserted text.
2309 Any other markers at the point of insertion remain before the text.
2311 If the current buffer is multibyte, unibyte strings are converted
2312 to multibyte for insertion (see `unibyte-char-to-multibyte').
2313 If the current buffer is unibyte, multibyte strings are converted
2314 to unibyte for insertion.
2316 usage: (insert-and-inherit &rest ARGS) */)
2317 (ptrdiff_t nargs
, Lisp_Object
*args
)
2319 general_insert_function (insert_and_inherit
, insert_from_string
, 1,
2324 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
2325 doc
: /* Insert strings or characters at point, relocating markers after the text.
2326 Point and markers move forward to end up after the inserted text.
2328 If the current buffer is multibyte, unibyte strings are converted
2329 to multibyte for insertion (see `unibyte-char-to-multibyte').
2330 If the current buffer is unibyte, multibyte strings are converted
2331 to unibyte for insertion.
2333 If an overlay begins at the insertion point, the inserted text falls
2334 outside the overlay; if a nonempty overlay ends at the insertion
2335 point, the inserted text falls inside that overlay.
2337 usage: (insert-before-markers &rest ARGS) */)
2338 (ptrdiff_t nargs
, Lisp_Object
*args
)
2340 general_insert_function (insert_before_markers
,
2341 insert_from_string_before_markers
, 0,
2346 DEFUN ("insert-before-markers-and-inherit", Finsert_and_inherit_before_markers
,
2347 Sinsert_and_inherit_before_markers
, 0, MANY
, 0,
2348 doc
: /* Insert text at point, relocating markers and inheriting properties.
2349 Point and markers move forward to end up after the inserted text.
2351 If the current buffer is multibyte, unibyte strings are converted
2352 to multibyte for insertion (see `unibyte-char-to-multibyte').
2353 If the current buffer is unibyte, multibyte strings are converted
2354 to unibyte for insertion.
2356 usage: (insert-before-markers-and-inherit &rest ARGS) */)
2357 (ptrdiff_t nargs
, Lisp_Object
*args
)
2359 general_insert_function (insert_before_markers_and_inherit
,
2360 insert_from_string_before_markers
, 1,
2365 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 1, 3,
2366 "(list (read-char-by-name \"Insert character (Unicode name or hex): \")\
2367 (prefix-numeric-value current-prefix-arg)\
2369 doc
: /* Insert COUNT copies of CHARACTER.
2370 Interactively, prompt for CHARACTER. You can specify CHARACTER in one
2373 - As its Unicode character name, e.g. \"LATIN SMALL LETTER A\".
2374 Completion is available; if you type a substring of the name
2375 preceded by an asterisk `*', Emacs shows all names which include
2376 that substring, not necessarily at the beginning of the name.
2378 - As a hexadecimal code point, e.g. 263A. Note that code points in
2379 Emacs are equivalent to Unicode up to 10FFFF (which is the limit of
2380 the Unicode code space).
2382 - As a code point with a radix specified with #, e.g. #o21430
2383 (octal), #x2318 (hex), or #10r8984 (decimal).
2385 If called interactively, COUNT is given by the prefix argument. If
2386 omitted or nil, it defaults to 1.
2388 Inserting the character(s) relocates point and before-insertion
2389 markers in the same ways as the function `insert'.
2391 The optional third argument INHERIT, if non-nil, says to inherit text
2392 properties from adjoining text, if those properties are sticky. If
2393 called interactively, INHERIT is t. */)
2394 (Lisp_Object character
, Lisp_Object count
, Lisp_Object inherit
)
2397 register ptrdiff_t n
;
2399 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2402 CHECK_CHARACTER (character
);
2404 XSETFASTINT (count
, 1);
2405 CHECK_NUMBER (count
);
2406 c
= XFASTINT (character
);
2408 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2409 len
= CHAR_STRING (c
, str
);
2411 str
[0] = c
, len
= 1;
2412 if (XINT (count
) <= 0)
2414 if (BUF_BYTES_MAX
/ len
< XINT (count
))
2416 n
= XINT (count
) * len
;
2417 stringlen
= min (n
, sizeof string
- sizeof string
% len
);
2418 for (i
= 0; i
< stringlen
; i
++)
2419 string
[i
] = str
[i
% len
];
2420 while (n
> stringlen
)
2423 if (!NILP (inherit
))
2424 insert_and_inherit (string
, stringlen
);
2426 insert (string
, stringlen
);
2429 if (!NILP (inherit
))
2430 insert_and_inherit (string
, n
);
2436 DEFUN ("insert-byte", Finsert_byte
, Sinsert_byte
, 2, 3, 0,
2437 doc
: /* Insert COUNT (second arg) copies of BYTE (first arg).
2438 Both arguments are required.
2439 BYTE is a number of the range 0..255.
2441 If BYTE is 128..255 and the current buffer is multibyte, the
2442 corresponding eight-bit character is inserted.
2444 Point, and before-insertion markers, are relocated as in the function `insert'.
2445 The optional third arg INHERIT, if non-nil, says to inherit text properties
2446 from adjoining text, if those properties are sticky. */)
2447 (Lisp_Object byte
, Lisp_Object count
, Lisp_Object inherit
)
2449 CHECK_NUMBER (byte
);
2450 if (XINT (byte
) < 0 || XINT (byte
) > 255)
2451 args_out_of_range_3 (byte
, make_number (0), make_number (255));
2452 if (XINT (byte
) >= 128
2453 && ! NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2454 XSETFASTINT (byte
, BYTE8_TO_CHAR (XINT (byte
)));
2455 return Finsert_char (byte
, count
, inherit
);
2459 /* Making strings from buffer contents. */
2461 /* Return a Lisp_String containing the text of the current buffer from
2462 START to END. If text properties are in use and the current buffer
2463 has properties in the range specified, the resulting string will also
2464 have them, if PROPS is true.
2466 We don't want to use plain old make_string here, because it calls
2467 make_uninit_string, which can cause the buffer arena to be
2468 compacted. make_string has no way of knowing that the data has
2469 been moved, and thus copies the wrong data into the string. This
2470 doesn't effect most of the other users of make_string, so it should
2471 be left as is. But we should use this function when conjuring
2472 buffer substrings. */
2475 make_buffer_string (ptrdiff_t start
, ptrdiff_t end
, bool props
)
2477 ptrdiff_t start_byte
= CHAR_TO_BYTE (start
);
2478 ptrdiff_t end_byte
= CHAR_TO_BYTE (end
);
2480 return make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
);
2483 /* Return a Lisp_String containing the text of the current buffer from
2484 START / START_BYTE to END / END_BYTE.
2486 If text properties are in use and the current buffer
2487 has properties in the range specified, the resulting string will also
2488 have them, if PROPS is true.
2490 We don't want to use plain old make_string here, because it calls
2491 make_uninit_string, which can cause the buffer arena to be
2492 compacted. make_string has no way of knowing that the data has
2493 been moved, and thus copies the wrong data into the string. This
2494 doesn't effect most of the other users of make_string, so it should
2495 be left as is. But we should use this function when conjuring
2496 buffer substrings. */
2499 make_buffer_string_both (ptrdiff_t start
, ptrdiff_t start_byte
,
2500 ptrdiff_t end
, ptrdiff_t end_byte
, bool props
)
2502 Lisp_Object result
, tem
, tem1
;
2504 if (start
< GPT
&& GPT
< end
)
2505 move_gap_both (start
, start_byte
);
2507 if (! NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2508 result
= make_uninit_multibyte_string (end
- start
, end_byte
- start_byte
);
2510 result
= make_uninit_string (end
- start
);
2511 memcpy (SDATA (result
), BYTE_POS_ADDR (start_byte
), end_byte
- start_byte
);
2513 /* If desired, update and copy the text properties. */
2516 update_buffer_properties (start
, end
);
2518 tem
= Fnext_property_change (make_number (start
), Qnil
, make_number (end
));
2519 tem1
= Ftext_properties_at (make_number (start
), Qnil
);
2521 if (XINT (tem
) != end
|| !NILP (tem1
))
2522 copy_intervals_to_string (result
, current_buffer
, start
,
2529 /* Call Vbuffer_access_fontify_functions for the range START ... END
2530 in the current buffer, if necessary. */
2533 update_buffer_properties (ptrdiff_t start
, ptrdiff_t end
)
2535 /* If this buffer has some access functions,
2536 call them, specifying the range of the buffer being accessed. */
2537 if (!NILP (Vbuffer_access_fontify_functions
))
2539 Lisp_Object args
[3];
2542 args
[0] = Qbuffer_access_fontify_functions
;
2543 XSETINT (args
[1], start
);
2544 XSETINT (args
[2], end
);
2546 /* But don't call them if we can tell that the work
2547 has already been done. */
2548 if (!NILP (Vbuffer_access_fontified_property
))
2550 tem
= Ftext_property_any (args
[1], args
[2],
2551 Vbuffer_access_fontified_property
,
2554 Frun_hook_with_args (3, args
);
2557 Frun_hook_with_args (3, args
);
2561 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
2562 doc
: /* Return the contents of part of the current buffer as a string.
2563 The two arguments START and END are character positions;
2564 they can be in either order.
2565 The string returned is multibyte if the buffer is multibyte.
2567 This function copies the text properties of that part of the buffer
2568 into the result string; if you don't want the text properties,
2569 use `buffer-substring-no-properties' instead. */)
2570 (Lisp_Object start
, Lisp_Object end
)
2572 register ptrdiff_t b
, e
;
2574 validate_region (&start
, &end
);
2578 return make_buffer_string (b
, e
, 1);
2581 DEFUN ("buffer-substring-no-properties", Fbuffer_substring_no_properties
,
2582 Sbuffer_substring_no_properties
, 2, 2, 0,
2583 doc
: /* Return the characters of part of the buffer, without the text properties.
2584 The two arguments START and END are character positions;
2585 they can be in either order. */)
2586 (Lisp_Object start
, Lisp_Object end
)
2588 register ptrdiff_t b
, e
;
2590 validate_region (&start
, &end
);
2594 return make_buffer_string (b
, e
, 0);
2597 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
2598 doc
: /* Return the contents of the current buffer as a string.
2599 If narrowing is in effect, this function returns only the visible part
2603 return make_buffer_string_both (BEGV
, BEGV_BYTE
, ZV
, ZV_BYTE
, 1);
2606 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
2608 doc
: /* Insert before point a substring of the contents of BUFFER.
2609 BUFFER may be a buffer or a buffer name.
2610 Arguments START and END are character positions specifying the substring.
2611 They default to the values of (point-min) and (point-max) in BUFFER. */)
2612 (Lisp_Object buffer
, Lisp_Object start
, Lisp_Object end
)
2614 register EMACS_INT b
, e
, temp
;
2615 register struct buffer
*bp
, *obuf
;
2618 buf
= Fget_buffer (buffer
);
2622 if (!BUFFER_LIVE_P (bp
))
2623 error ("Selecting deleted buffer");
2629 CHECK_NUMBER_COERCE_MARKER (start
);
2636 CHECK_NUMBER_COERCE_MARKER (end
);
2641 temp
= b
, b
= e
, e
= temp
;
2643 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
2644 args_out_of_range (start
, end
);
2646 obuf
= current_buffer
;
2647 set_buffer_internal_1 (bp
);
2648 update_buffer_properties (b
, e
);
2649 set_buffer_internal_1 (obuf
);
2651 insert_from_buffer (bp
, b
, e
- b
, 0);
2655 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
2657 doc
: /* Compare two substrings of two buffers; return result as number.
2658 Return -N if first string is less after N-1 chars, +N if first string is
2659 greater after N-1 chars, or 0 if strings match. Each substring is
2660 represented as three arguments: BUFFER, START and END. That makes six
2661 args in all, three for each substring.
2663 The value of `case-fold-search' in the current buffer
2664 determines whether case is significant or ignored. */)
2665 (Lisp_Object buffer1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object buffer2
, Lisp_Object start2
, Lisp_Object end2
)
2667 register EMACS_INT begp1
, endp1
, begp2
, endp2
, temp
;
2668 register struct buffer
*bp1
, *bp2
;
2669 register Lisp_Object trt
2670 = (!NILP (BVAR (current_buffer
, case_fold_search
))
2671 ? BVAR (current_buffer
, case_canon_table
) : Qnil
);
2672 ptrdiff_t chars
= 0;
2673 ptrdiff_t i1
, i2
, i1_byte
, i2_byte
;
2675 /* Find the first buffer and its substring. */
2678 bp1
= current_buffer
;
2682 buf1
= Fget_buffer (buffer1
);
2685 bp1
= XBUFFER (buf1
);
2686 if (!BUFFER_LIVE_P (bp1
))
2687 error ("Selecting deleted buffer");
2691 begp1
= BUF_BEGV (bp1
);
2694 CHECK_NUMBER_COERCE_MARKER (start1
);
2695 begp1
= XINT (start1
);
2698 endp1
= BUF_ZV (bp1
);
2701 CHECK_NUMBER_COERCE_MARKER (end1
);
2702 endp1
= XINT (end1
);
2706 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
2708 if (!(BUF_BEGV (bp1
) <= begp1
2710 && endp1
<= BUF_ZV (bp1
)))
2711 args_out_of_range (start1
, end1
);
2713 /* Likewise for second substring. */
2716 bp2
= current_buffer
;
2720 buf2
= Fget_buffer (buffer2
);
2723 bp2
= XBUFFER (buf2
);
2724 if (!BUFFER_LIVE_P (bp2
))
2725 error ("Selecting deleted buffer");
2729 begp2
= BUF_BEGV (bp2
);
2732 CHECK_NUMBER_COERCE_MARKER (start2
);
2733 begp2
= XINT (start2
);
2736 endp2
= BUF_ZV (bp2
);
2739 CHECK_NUMBER_COERCE_MARKER (end2
);
2740 endp2
= XINT (end2
);
2744 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
2746 if (!(BUF_BEGV (bp2
) <= begp2
2748 && endp2
<= BUF_ZV (bp2
)))
2749 args_out_of_range (start2
, end2
);
2753 i1_byte
= buf_charpos_to_bytepos (bp1
, i1
);
2754 i2_byte
= buf_charpos_to_bytepos (bp2
, i2
);
2756 while (i1
< endp1
&& i2
< endp2
)
2758 /* When we find a mismatch, we must compare the
2759 characters, not just the bytes. */
2764 if (! NILP (BVAR (bp1
, enable_multibyte_characters
)))
2766 c1
= BUF_FETCH_MULTIBYTE_CHAR (bp1
, i1_byte
);
2767 BUF_INC_POS (bp1
, i1_byte
);
2772 c1
= BUF_FETCH_BYTE (bp1
, i1
);
2773 MAKE_CHAR_MULTIBYTE (c1
);
2777 if (! NILP (BVAR (bp2
, enable_multibyte_characters
)))
2779 c2
= BUF_FETCH_MULTIBYTE_CHAR (bp2
, i2_byte
);
2780 BUF_INC_POS (bp2
, i2_byte
);
2785 c2
= BUF_FETCH_BYTE (bp2
, i2
);
2786 MAKE_CHAR_MULTIBYTE (c2
);
2792 c1
= char_table_translate (trt
, c1
);
2793 c2
= char_table_translate (trt
, c2
);
2796 return make_number (- 1 - chars
);
2798 return make_number (chars
+ 1);
2803 /* The strings match as far as they go.
2804 If one is shorter, that one is less. */
2805 if (chars
< endp1
- begp1
)
2806 return make_number (chars
+ 1);
2807 else if (chars
< endp2
- begp2
)
2808 return make_number (- chars
- 1);
2810 /* Same length too => they are equal. */
2811 return make_number (0);
2815 subst_char_in_region_unwind (Lisp_Object arg
)
2817 bset_undo_list (current_buffer
, arg
);
2821 subst_char_in_region_unwind_1 (Lisp_Object arg
)
2823 bset_filename (current_buffer
, arg
);
2826 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
2827 Ssubst_char_in_region
, 4, 5, 0,
2828 doc
: /* From START to END, replace FROMCHAR with TOCHAR each time it occurs.
2829 If optional arg NOUNDO is non-nil, don't record this change for undo
2830 and don't mark the buffer as really changed.
2831 Both characters must have the same length of multi-byte form. */)
2832 (Lisp_Object start
, Lisp_Object end
, Lisp_Object fromchar
, Lisp_Object tochar
, Lisp_Object noundo
)
2834 register ptrdiff_t pos
, pos_byte
, stop
, i
, len
, end_byte
;
2835 /* Keep track of the first change in the buffer:
2836 if 0 we haven't found it yet.
2837 if < 0 we've found it and we've run the before-change-function.
2838 if > 0 we've actually performed it and the value is its position. */
2839 ptrdiff_t changed
= 0;
2840 unsigned char fromstr
[MAX_MULTIBYTE_LENGTH
], tostr
[MAX_MULTIBYTE_LENGTH
];
2842 ptrdiff_t count
= SPECPDL_INDEX ();
2843 #define COMBINING_NO 0
2844 #define COMBINING_BEFORE 1
2845 #define COMBINING_AFTER 2
2846 #define COMBINING_BOTH (COMBINING_BEFORE | COMBINING_AFTER)
2847 int maybe_byte_combining
= COMBINING_NO
;
2848 ptrdiff_t last_changed
= 0;
2850 = !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
2855 validate_region (&start
, &end
);
2856 CHECK_CHARACTER (fromchar
);
2857 CHECK_CHARACTER (tochar
);
2858 fromc
= XFASTINT (fromchar
);
2859 toc
= XFASTINT (tochar
);
2863 len
= CHAR_STRING (fromc
, fromstr
);
2864 if (CHAR_STRING (toc
, tostr
) != len
)
2865 error ("Characters in `subst-char-in-region' have different byte-lengths");
2866 if (!ASCII_BYTE_P (*tostr
))
2868 /* If *TOSTR is in the range 0x80..0x9F and TOCHAR is not a
2869 complete multibyte character, it may be combined with the
2870 after bytes. If it is in the range 0xA0..0xFF, it may be
2871 combined with the before and after bytes. */
2872 if (!CHAR_HEAD_P (*tostr
))
2873 maybe_byte_combining
= COMBINING_BOTH
;
2874 else if (BYTES_BY_CHAR_HEAD (*tostr
) > len
)
2875 maybe_byte_combining
= COMBINING_AFTER
;
2886 pos_byte
= CHAR_TO_BYTE (pos
);
2887 stop
= CHAR_TO_BYTE (XINT (end
));
2890 /* If we don't want undo, turn off putting stuff on the list.
2891 That's faster than getting rid of things,
2892 and it prevents even the entry for a first change.
2893 Also inhibit locking the file. */
2894 if (!changed
&& !NILP (noundo
))
2896 record_unwind_protect (subst_char_in_region_unwind
,
2897 BVAR (current_buffer
, undo_list
));
2898 bset_undo_list (current_buffer
, Qt
);
2899 /* Don't do file-locking. */
2900 record_unwind_protect (subst_char_in_region_unwind_1
,
2901 BVAR (current_buffer
, filename
));
2902 bset_filename (current_buffer
, Qnil
);
2905 if (pos_byte
< GPT_BYTE
)
2906 stop
= min (stop
, GPT_BYTE
);
2909 ptrdiff_t pos_byte_next
= pos_byte
;
2911 if (pos_byte
>= stop
)
2913 if (pos_byte
>= end_byte
) break;
2916 p
= BYTE_POS_ADDR (pos_byte
);
2918 INC_POS (pos_byte_next
);
2921 if (pos_byte_next
- pos_byte
== len
2922 && p
[0] == fromstr
[0]
2924 || (p
[1] == fromstr
[1]
2925 && (len
== 2 || (p
[2] == fromstr
[2]
2926 && (len
== 3 || p
[3] == fromstr
[3]))))))
2929 /* We've already seen this and run the before-change-function;
2930 this time we only need to record the actual position. */
2935 modify_text (pos
, XINT (end
));
2937 if (! NILP (noundo
))
2939 if (MODIFF
- 1 == SAVE_MODIFF
)
2941 if (MODIFF
- 1 == BUF_AUTOSAVE_MODIFF (current_buffer
))
2942 BUF_AUTOSAVE_MODIFF (current_buffer
)++;
2945 /* The before-change-function may have moved the gap
2946 or even modified the buffer so we should start over. */
2950 /* Take care of the case where the new character
2951 combines with neighboring bytes. */
2952 if (maybe_byte_combining
2953 && (maybe_byte_combining
== COMBINING_AFTER
2954 ? (pos_byte_next
< Z_BYTE
2955 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2956 : ((pos_byte_next
< Z_BYTE
2957 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2958 || (pos_byte
> BEG_BYTE
2959 && ! ASCII_BYTE_P (FETCH_BYTE (pos_byte
- 1))))))
2961 Lisp_Object tem
, string
;
2963 struct gcpro gcpro1
;
2965 tem
= BVAR (current_buffer
, undo_list
);
2968 /* Make a multibyte string containing this single character. */
2969 string
= make_multibyte_string ((char *) tostr
, 1, len
);
2970 /* replace_range is less efficient, because it moves the gap,
2971 but it handles combining correctly. */
2972 replace_range (pos
, pos
+ 1, string
,
2974 pos_byte_next
= CHAR_TO_BYTE (pos
);
2975 if (pos_byte_next
> pos_byte
)
2976 /* Before combining happened. We should not increment
2977 POS. So, to cancel the later increment of POS,
2981 INC_POS (pos_byte_next
);
2983 if (! NILP (noundo
))
2984 bset_undo_list (current_buffer
, tem
);
2991 record_change (pos
, 1);
2992 for (i
= 0; i
< len
; i
++) *p
++ = tostr
[i
];
2994 last_changed
= pos
+ 1;
2996 pos_byte
= pos_byte_next
;
3002 signal_after_change (changed
,
3003 last_changed
- changed
, last_changed
- changed
);
3004 update_compositions (changed
, last_changed
, CHECK_ALL
);
3007 unbind_to (count
, Qnil
);
3012 static Lisp_Object
check_translation (ptrdiff_t, ptrdiff_t, ptrdiff_t,
3015 /* Helper function for Ftranslate_region_internal.
3017 Check if a character sequence at POS (POS_BYTE) matches an element
3018 of VAL. VAL is a list (([FROM-CHAR ...] . TO) ...). If a matching
3019 element is found, return it. Otherwise return Qnil. */
3022 check_translation (ptrdiff_t pos
, ptrdiff_t pos_byte
, ptrdiff_t end
,
3025 int buf_size
= 16, buf_used
= 0;
3026 int *buf
= alloca (sizeof (int) * buf_size
);
3028 for (; CONSP (val
); val
= XCDR (val
))
3037 if (! VECTORP (elt
))
3040 if (len
<= end
- pos
)
3042 for (i
= 0; i
< len
; i
++)
3046 unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
3049 if (buf_used
== buf_size
)
3054 newbuf
= alloca (sizeof (int) * buf_size
);
3055 memcpy (newbuf
, buf
, sizeof (int) * buf_used
);
3058 buf
[buf_used
++] = STRING_CHAR_AND_LENGTH (p
, len1
);
3061 if (XINT (AREF (elt
, i
)) != buf
[i
])
3072 DEFUN ("translate-region-internal", Ftranslate_region_internal
,
3073 Stranslate_region_internal
, 3, 3, 0,
3074 doc
: /* Internal use only.
3075 From START to END, translate characters according to TABLE.
3076 TABLE is a string or a char-table; the Nth character in it is the
3077 mapping for the character with code N.
3078 It returns the number of characters changed. */)
3079 (Lisp_Object start
, Lisp_Object end
, register Lisp_Object table
)
3081 register unsigned char *tt
; /* Trans table. */
3082 register int nc
; /* New character. */
3083 int cnt
; /* Number of changes made. */
3084 ptrdiff_t size
; /* Size of translate table. */
3085 ptrdiff_t pos
, pos_byte
, end_pos
;
3086 bool multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3087 bool string_multibyte
IF_LINT (= 0);
3089 validate_region (&start
, &end
);
3090 if (CHAR_TABLE_P (table
))
3092 if (! EQ (XCHAR_TABLE (table
)->purpose
, Qtranslation_table
))
3093 error ("Not a translation table");
3099 CHECK_STRING (table
);
3101 if (! multibyte
&& (SCHARS (table
) < SBYTES (table
)))
3102 table
= string_make_unibyte (table
);
3103 string_multibyte
= SCHARS (table
) < SBYTES (table
);
3104 size
= SBYTES (table
);
3109 pos_byte
= CHAR_TO_BYTE (pos
);
3110 end_pos
= XINT (end
);
3111 modify_text (pos
, end_pos
);
3114 for (; pos
< end_pos
; )
3116 register unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
3117 unsigned char *str
, buf
[MAX_MULTIBYTE_LENGTH
];
3123 oc
= STRING_CHAR_AND_LENGTH (p
, len
);
3130 /* Reload as signal_after_change in last iteration may GC. */
3132 if (string_multibyte
)
3134 str
= tt
+ string_char_to_byte (table
, oc
);
3135 nc
= STRING_CHAR_AND_LENGTH (str
, str_len
);
3140 if (! ASCII_BYTE_P (nc
) && multibyte
)
3142 str_len
= BYTE8_STRING (nc
, buf
);
3155 val
= CHAR_TABLE_REF (table
, oc
);
3156 if (CHARACTERP (val
))
3158 nc
= XFASTINT (val
);
3159 str_len
= CHAR_STRING (nc
, buf
);
3162 else if (VECTORP (val
) || (CONSP (val
)))
3164 /* VAL is [TO_CHAR ...] or (([FROM-CHAR ...] . TO) ...)
3165 where TO is TO-CHAR or [TO-CHAR ...]. */
3170 if (nc
!= oc
&& nc
>= 0)
3172 /* Simple one char to one char translation. */
3177 /* This is less efficient, because it moves the gap,
3178 but it should handle multibyte characters correctly. */
3179 string
= make_multibyte_string ((char *) str
, 1, str_len
);
3180 replace_range (pos
, pos
+ 1, string
, 1, 0, 1);
3185 record_change (pos
, 1);
3186 while (str_len
-- > 0)
3188 signal_after_change (pos
, 1, 1);
3189 update_compositions (pos
, pos
+ 1, CHECK_BORDER
);
3199 val
= check_translation (pos
, pos_byte
, end_pos
, val
);
3206 /* VAL is ([FROM-CHAR ...] . TO). */
3207 len
= ASIZE (XCAR (val
));
3215 string
= Fconcat (1, &val
);
3219 string
= Fmake_string (make_number (1), val
);
3221 replace_range (pos
, pos
+ len
, string
, 1, 0, 1);
3222 pos_byte
+= SBYTES (string
);
3223 pos
+= SCHARS (string
);
3224 cnt
+= SCHARS (string
);
3225 end_pos
+= SCHARS (string
) - len
;
3233 return make_number (cnt
);
3236 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
3237 doc
: /* Delete the text between START and END.
3238 If called interactively, delete the region between point and mark.
3239 This command deletes buffer text without modifying the kill ring. */)
3240 (Lisp_Object start
, Lisp_Object end
)
3242 validate_region (&start
, &end
);
3243 del_range (XINT (start
), XINT (end
));
3247 DEFUN ("delete-and-extract-region", Fdelete_and_extract_region
,
3248 Sdelete_and_extract_region
, 2, 2, 0,
3249 doc
: /* Delete the text between START and END and return it. */)
3250 (Lisp_Object start
, Lisp_Object end
)
3252 validate_region (&start
, &end
);
3253 if (XINT (start
) == XINT (end
))
3254 return empty_unibyte_string
;
3255 return del_range_1 (XINT (start
), XINT (end
), 1, 1);
3258 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
3259 doc
: /* Remove restrictions (narrowing) from current buffer.
3260 This allows the buffer's full text to be seen and edited. */)
3263 if (BEG
!= BEGV
|| Z
!= ZV
)
3264 current_buffer
->clip_changed
= 1;
3266 BEGV_BYTE
= BEG_BYTE
;
3267 SET_BUF_ZV_BOTH (current_buffer
, Z
, Z_BYTE
);
3268 /* Changing the buffer bounds invalidates any recorded current column. */
3269 invalidate_current_column ();
3273 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
3274 doc
: /* Restrict editing in this buffer to the current region.
3275 The rest of the text becomes temporarily invisible and untouchable
3276 but is not deleted; if you save the buffer in a file, the invisible
3277 text is included in the file. \\[widen] makes all visible again.
3278 See also `save-restriction'.
3280 When calling from a program, pass two arguments; positions (integers
3281 or markers) bounding the text that should remain visible. */)
3282 (register Lisp_Object start
, Lisp_Object end
)
3284 CHECK_NUMBER_COERCE_MARKER (start
);
3285 CHECK_NUMBER_COERCE_MARKER (end
);
3287 if (XINT (start
) > XINT (end
))
3290 tem
= start
; start
= end
; end
= tem
;
3293 if (!(BEG
<= XINT (start
) && XINT (start
) <= XINT (end
) && XINT (end
) <= Z
))
3294 args_out_of_range (start
, end
);
3296 if (BEGV
!= XFASTINT (start
) || ZV
!= XFASTINT (end
))
3297 current_buffer
->clip_changed
= 1;
3299 SET_BUF_BEGV (current_buffer
, XFASTINT (start
));
3300 SET_BUF_ZV (current_buffer
, XFASTINT (end
));
3301 if (PT
< XFASTINT (start
))
3302 SET_PT (XFASTINT (start
));
3303 if (PT
> XFASTINT (end
))
3304 SET_PT (XFASTINT (end
));
3305 /* Changing the buffer bounds invalidates any recorded current column. */
3306 invalidate_current_column ();
3311 save_restriction_save (void)
3313 if (BEGV
== BEG
&& ZV
== Z
)
3314 /* The common case that the buffer isn't narrowed.
3315 We return just the buffer object, which save_restriction_restore
3316 recognizes as meaning `no restriction'. */
3317 return Fcurrent_buffer ();
3319 /* We have to save a restriction, so return a pair of markers, one
3320 for the beginning and one for the end. */
3322 Lisp_Object beg
, end
;
3324 beg
= build_marker (current_buffer
, BEGV
, BEGV_BYTE
);
3325 end
= build_marker (current_buffer
, ZV
, ZV_BYTE
);
3327 /* END must move forward if text is inserted at its exact location. */
3328 XMARKER (end
)->insertion_type
= 1;
3330 return Fcons (beg
, end
);
3335 save_restriction_restore (Lisp_Object data
)
3337 struct buffer
*cur
= NULL
;
3338 struct buffer
*buf
= (CONSP (data
)
3339 ? XMARKER (XCAR (data
))->buffer
3342 if (buf
&& buf
!= current_buffer
&& !NILP (BVAR (buf
, pt_marker
)))
3343 { /* If `buf' uses markers to keep track of PT, BEGV, and ZV (as
3344 is the case if it is or has an indirect buffer), then make
3345 sure it is current before we update BEGV, so
3346 set_buffer_internal takes care of managing those markers. */
3347 cur
= current_buffer
;
3348 set_buffer_internal (buf
);
3352 /* A pair of marks bounding a saved restriction. */
3354 struct Lisp_Marker
*beg
= XMARKER (XCAR (data
));
3355 struct Lisp_Marker
*end
= XMARKER (XCDR (data
));
3356 eassert (buf
== end
->buffer
);
3358 if (buf
/* Verify marker still points to a buffer. */
3359 && (beg
->charpos
!= BUF_BEGV (buf
) || end
->charpos
!= BUF_ZV (buf
)))
3360 /* The restriction has changed from the saved one, so restore
3361 the saved restriction. */
3363 ptrdiff_t pt
= BUF_PT (buf
);
3365 SET_BUF_BEGV_BOTH (buf
, beg
->charpos
, beg
->bytepos
);
3366 SET_BUF_ZV_BOTH (buf
, end
->charpos
, end
->bytepos
);
3368 if (pt
< beg
->charpos
|| pt
> end
->charpos
)
3369 /* The point is outside the new visible range, move it inside. */
3370 SET_BUF_PT_BOTH (buf
,
3371 clip_to_bounds (beg
->charpos
, pt
, end
->charpos
),
3372 clip_to_bounds (beg
->bytepos
, BUF_PT_BYTE (buf
),
3375 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3377 /* These aren't needed anymore, so don't wait for GC. */
3378 free_marker (XCAR (data
));
3379 free_marker (XCDR (data
));
3380 free_cons (XCONS (data
));
3383 /* A buffer, which means that there was no old restriction. */
3385 if (buf
/* Verify marker still points to a buffer. */
3386 && (BUF_BEGV (buf
) != BUF_BEG (buf
) || BUF_ZV (buf
) != BUF_Z (buf
)))
3387 /* The buffer has been narrowed, get rid of the narrowing. */
3389 SET_BUF_BEGV_BOTH (buf
, BUF_BEG (buf
), BUF_BEG_BYTE (buf
));
3390 SET_BUF_ZV_BOTH (buf
, BUF_Z (buf
), BUF_Z_BYTE (buf
));
3392 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3396 /* Changing the buffer bounds invalidates any recorded current column. */
3397 invalidate_current_column ();
3400 set_buffer_internal (cur
);
3403 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
3404 doc
: /* Execute BODY, saving and restoring current buffer's restrictions.
3405 The buffer's restrictions make parts of the beginning and end invisible.
3406 \(They are set up with `narrow-to-region' and eliminated with `widen'.)
3407 This special form, `save-restriction', saves the current buffer's restrictions
3408 when it is entered, and restores them when it is exited.
3409 So any `narrow-to-region' within BODY lasts only until the end of the form.
3410 The old restrictions settings are restored
3411 even in case of abnormal exit (throw or error).
3413 The value returned is the value of the last form in BODY.
3415 Note: if you are using both `save-excursion' and `save-restriction',
3416 use `save-excursion' outermost:
3417 (save-excursion (save-restriction ...))
3419 usage: (save-restriction &rest BODY) */)
3422 register Lisp_Object val
;
3423 ptrdiff_t count
= SPECPDL_INDEX ();
3425 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
3426 val
= Fprogn (body
);
3427 return unbind_to (count
, val
);
3430 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
3431 doc
: /* Display a message at the bottom of the screen.
3432 The message also goes into the `*Messages*' buffer, if `message-log-max'
3433 is non-nil. (In keyboard macros, that's all it does.)
3436 The first argument is a format control string, and the rest are data
3437 to be formatted under control of the string. See `format' for details.
3439 Note: Use (message "%s" VALUE) to print the value of expressions and
3440 variables to avoid accidentally interpreting `%' as format specifiers.
3442 If the first argument is nil or the empty string, the function clears
3443 any existing message; this lets the minibuffer contents show. See
3444 also `current-message'.
3446 usage: (message FORMAT-STRING &rest ARGS) */)
3447 (ptrdiff_t nargs
, Lisp_Object
*args
)
3450 || (STRINGP (args
[0])
3451 && SBYTES (args
[0]) == 0))
3458 register Lisp_Object val
;
3459 val
= Fformat (nargs
, args
);
3465 DEFUN ("message-box", Fmessage_box
, Smessage_box
, 1, MANY
, 0,
3466 doc
: /* Display a message, in a dialog box if possible.
3467 If a dialog box is not available, use the echo area.
3468 The first argument is a format control string, and the rest are data
3469 to be formatted under control of the string. See `format' for details.
3471 If the first argument is nil or the empty string, clear any existing
3472 message; let the minibuffer contents show.
3474 usage: (message-box FORMAT-STRING &rest ARGS) */)
3475 (ptrdiff_t nargs
, Lisp_Object
*args
)
3484 Lisp_Object val
= Fformat (nargs
, args
);
3486 /* The MS-DOS frames support popup menus even though they are
3487 not FRAME_WINDOW_P. */
3488 if (FRAME_WINDOW_P (XFRAME (selected_frame
))
3489 || FRAME_MSDOS_P (XFRAME (selected_frame
)))
3491 Lisp_Object pane
, menu
;
3492 struct gcpro gcpro1
;
3493 pane
= list1 (Fcons (build_string ("OK"), Qt
));
3495 menu
= Fcons (val
, pane
);
3496 Fx_popup_dialog (Qt
, menu
, Qt
);
3500 #endif /* HAVE_MENUS */
3506 DEFUN ("message-or-box", Fmessage_or_box
, Smessage_or_box
, 1, MANY
, 0,
3507 doc
: /* Display a message in a dialog box or in the echo area.
3508 If this command was invoked with the mouse, use a dialog box if
3509 `use-dialog-box' is non-nil.
3510 Otherwise, use the echo area.
3511 The first argument is a format control string, and the rest are data
3512 to be formatted under control of the string. See `format' for details.
3514 If the first argument is nil or the empty string, clear any existing
3515 message; let the minibuffer contents show.
3517 usage: (message-or-box FORMAT-STRING &rest ARGS) */)
3518 (ptrdiff_t nargs
, Lisp_Object
*args
)
3521 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3523 return Fmessage_box (nargs
, args
);
3525 return Fmessage (nargs
, args
);
3528 DEFUN ("current-message", Fcurrent_message
, Scurrent_message
, 0, 0, 0,
3529 doc
: /* Return the string currently displayed in the echo area, or nil if none. */)
3532 return current_message ();
3536 DEFUN ("propertize", Fpropertize
, Spropertize
, 1, MANY
, 0,
3537 doc
: /* Return a copy of STRING with text properties added.
3538 First argument is the string to copy.
3539 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
3540 properties to add to the result.
3541 usage: (propertize STRING &rest PROPERTIES) */)
3542 (ptrdiff_t nargs
, Lisp_Object
*args
)
3544 Lisp_Object properties
, string
;
3545 struct gcpro gcpro1
, gcpro2
;
3548 /* Number of args must be odd. */
3549 if ((nargs
& 1) == 0)
3550 error ("Wrong number of arguments");
3552 properties
= string
= Qnil
;
3553 GCPRO2 (properties
, string
);
3555 /* First argument must be a string. */
3556 CHECK_STRING (args
[0]);
3557 string
= Fcopy_sequence (args
[0]);
3559 for (i
= 1; i
< nargs
; i
+= 2)
3560 properties
= Fcons (args
[i
], Fcons (args
[i
+ 1], properties
));
3562 Fadd_text_properties (make_number (0),
3563 make_number (SCHARS (string
)),
3564 properties
, string
);
3565 RETURN_UNGCPRO (string
);
3568 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
3569 doc
: /* Format a string out of a format-string and arguments.
3570 The first argument is a format control string.
3571 The other arguments are substituted into it to make the result, a string.
3573 The format control string may contain %-sequences meaning to substitute
3574 the next available argument:
3576 %s means print a string argument. Actually, prints any object, with `princ'.
3577 %d means print as number in decimal (%o octal, %x hex).
3578 %X is like %x, but uses upper case.
3579 %e means print a number in exponential notation.
3580 %f means print a number in decimal-point notation.
3581 %g means print a number in exponential notation
3582 or decimal-point notation, whichever uses fewer characters.
3583 %c means print a number as a single character.
3584 %S means print any object as an s-expression (using `prin1').
3586 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.
3587 Use %% to put a single % into the output.
3589 A %-sequence may contain optional flag, width, and precision
3590 specifiers, as follows:
3592 %<flags><width><precision>character
3594 where flags is [+ #-0]+, width is [0-9]+, and precision is .[0-9]+
3596 The + flag character inserts a + before any positive number, while a
3597 space inserts a space before any positive number; these flags only
3598 affect %d, %e, %f, and %g sequences, and the + flag takes precedence.
3599 The - and 0 flags affect the width specifier, as described below.
3601 The # flag means to use an alternate display form for %o, %x, %X, %e,
3602 %f, and %g sequences: for %o, it ensures that the result begins with
3603 \"0\"; for %x and %X, it prefixes the result with \"0x\" or \"0X\";
3604 for %e, %f, and %g, it causes a decimal point to be included even if
3605 the precision is zero.
3607 The width specifier supplies a lower limit for the length of the
3608 printed representation. The padding, if any, normally goes on the
3609 left, but it goes on the right if the - flag is present. The padding
3610 character is normally a space, but it is 0 if the 0 flag is present.
3611 The 0 flag is ignored if the - flag is present, or the format sequence
3612 is something other than %d, %e, %f, and %g.
3614 For %e, %f, and %g sequences, the number after the "." in the
3615 precision specifier says how many decimal places to show; if zero, the
3616 decimal point itself is omitted. For %s and %S, the precision
3617 specifier truncates the string to the given width.
3619 usage: (format STRING &rest OBJECTS) */)
3620 (ptrdiff_t nargs
, Lisp_Object
*args
)
3622 ptrdiff_t n
; /* The number of the next arg to substitute */
3623 char initial_buffer
[4000];
3624 char *buf
= initial_buffer
;
3625 ptrdiff_t bufsize
= sizeof initial_buffer
;
3626 ptrdiff_t max_bufsize
= STRING_BYTES_BOUND
+ 1;
3628 ptrdiff_t buf_save_value_index
IF_LINT (= 0);
3629 char *format
, *end
, *format_start
;
3630 ptrdiff_t formatlen
, nchars
;
3631 /* True if the format is multibyte. */
3632 bool multibyte_format
= 0;
3633 /* True if the output should be a multibyte string,
3634 which is true if any of the inputs is one. */
3636 /* When we make a multibyte string, we must pay attention to the
3637 byte combining problem, i.e., a byte may be combined with a
3638 multibyte character of the previous string. This flag tells if we
3639 must consider such a situation or not. */
3640 bool maybe_combine_byte
;
3642 bool arg_intervals
= 0;
3645 /* discarded[I] is 1 if byte I of the format
3646 string was not copied into the output.
3647 It is 2 if byte I was not the first byte of its character. */
3650 /* Each element records, for one argument,
3651 the start and end bytepos in the output string,
3652 whether the argument has been converted to string (e.g., due to "%S"),
3653 and whether the argument is a string with intervals.
3654 info[0] is unused. Unused elements have -1 for start. */
3657 ptrdiff_t start
, end
;
3658 unsigned converted_to_string
: 1;
3659 unsigned intervals
: 1;
3662 /* It should not be necessary to GCPRO ARGS, because
3663 the caller in the interpreter should take care of that. */
3665 CHECK_STRING (args
[0]);
3666 format_start
= SSDATA (args
[0]);
3667 formatlen
= SBYTES (args
[0]);
3669 /* Allocate the info and discarded tables. */
3672 if ((SIZE_MAX
- formatlen
) / sizeof (struct info
) <= nargs
)
3673 memory_full (SIZE_MAX
);
3674 info
= SAFE_ALLOCA ((nargs
+ 1) * sizeof *info
+ formatlen
);
3675 discarded
= (char *) &info
[nargs
+ 1];
3676 for (i
= 0; i
< nargs
+ 1; i
++)
3679 info
[i
].intervals
= info
[i
].converted_to_string
= 0;
3681 memset (discarded
, 0, formatlen
);
3684 /* Try to determine whether the result should be multibyte.
3685 This is not always right; sometimes the result needs to be multibyte
3686 because of an object that we will pass through prin1,
3687 and in that case, we won't know it here. */
3688 multibyte_format
= STRING_MULTIBYTE (args
[0]);
3689 multibyte
= multibyte_format
;
3690 for (n
= 1; !multibyte
&& n
< nargs
; n
++)
3691 if (STRINGP (args
[n
]) && STRING_MULTIBYTE (args
[n
]))
3694 /* If we start out planning a unibyte result,
3695 then discover it has to be multibyte, we jump back to retry. */
3702 /* Scan the format and store result in BUF. */
3703 format
= format_start
;
3704 end
= format
+ formatlen
;
3705 maybe_combine_byte
= 0;
3707 while (format
!= end
)
3709 /* The values of N and FORMAT when the loop body is entered. */
3711 char *format0
= format
;
3713 /* Bytes needed to represent the output of this conversion. */
3714 ptrdiff_t convbytes
;
3718 /* General format specifications look like
3720 '%' [flags] [field-width] [precision] format
3725 field-width ::= [0-9]+
3726 precision ::= '.' [0-9]*
3728 If a field-width is specified, it specifies to which width
3729 the output should be padded with blanks, if the output
3730 string is shorter than field-width.
3732 If precision is specified, it specifies the number of
3733 digits to print after the '.' for floats, or the max.
3734 number of chars to print from a string. */
3736 bool minus_flag
= 0;
3738 bool space_flag
= 0;
3739 bool sharp_flag
= 0;
3741 ptrdiff_t field_width
;
3742 bool precision_given
;
3743 uintmax_t precision
= UINTMAX_MAX
;
3751 case '-': minus_flag
= 1; continue;
3752 case '+': plus_flag
= 1; continue;
3753 case ' ': space_flag
= 1; continue;
3754 case '#': sharp_flag
= 1; continue;
3755 case '0': zero_flag
= 1; continue;
3760 /* Ignore flags when sprintf ignores them. */
3761 space_flag
&= ~ plus_flag
;
3762 zero_flag
&= ~ minus_flag
;
3765 uintmax_t w
= strtoumax (format
, &num_end
, 10);
3766 if (max_bufsize
<= w
)
3770 precision_given
= *num_end
== '.';
3771 if (precision_given
)
3772 precision
= strtoumax (num_end
+ 1, &num_end
, 10);
3776 error ("Format string ends in middle of format specifier");
3778 memset (&discarded
[format0
- format_start
], 1, format
- format0
);
3779 conversion
= *format
;
3780 if (conversion
== '%')
3782 discarded
[format
- format_start
] = 1;
3787 error ("Not enough arguments for format string");
3789 /* For 'S', prin1 the argument, and then treat like 's'.
3790 For 's', princ any argument that is not a string or
3791 symbol. But don't do this conversion twice, which might
3792 happen after retrying. */
3793 if ((conversion
== 'S'
3794 || (conversion
== 's'
3795 && ! STRINGP (args
[n
]) && ! SYMBOLP (args
[n
]))))
3797 if (! info
[n
].converted_to_string
)
3799 Lisp_Object noescape
= conversion
== 'S' ? Qnil
: Qt
;
3800 args
[n
] = Fprin1_to_string (args
[n
], noescape
);
3801 info
[n
].converted_to_string
= 1;
3802 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
3810 else if (conversion
== 'c')
3812 if (FLOATP (args
[n
]))
3814 double d
= XFLOAT_DATA (args
[n
]);
3815 args
[n
] = make_number (FIXNUM_OVERFLOW_P (d
) ? -1 : d
);
3818 if (INTEGERP (args
[n
]) && ! ASCII_CHAR_P (XINT (args
[n
])))
3825 args
[n
] = Fchar_to_string (args
[n
]);
3826 info
[n
].converted_to_string
= 1;
3829 if (info
[n
].converted_to_string
)
3834 if (SYMBOLP (args
[n
]))
3836 args
[n
] = SYMBOL_NAME (args
[n
]);
3837 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
3844 if (conversion
== 's')
3846 /* handle case (precision[n] >= 0) */
3848 ptrdiff_t width
, padding
, nbytes
;
3849 ptrdiff_t nchars_string
;
3851 ptrdiff_t prec
= -1;
3852 if (precision_given
&& precision
<= TYPE_MAXIMUM (ptrdiff_t))
3855 /* lisp_string_width ignores a precision of 0, but GNU
3856 libc functions print 0 characters when the precision
3857 is 0. Imitate libc behavior here. Changing
3858 lisp_string_width is the right thing, and will be
3859 done, but meanwhile we work with it. */
3862 width
= nchars_string
= nbytes
= 0;
3866 width
= lisp_string_width (args
[n
], prec
, &nch
, &nby
);
3869 nchars_string
= SCHARS (args
[n
]);
3870 nbytes
= SBYTES (args
[n
]);
3874 nchars_string
= nch
;
3880 if (convbytes
&& multibyte
&& ! STRING_MULTIBYTE (args
[n
]))
3881 convbytes
= count_size_as_multibyte (SDATA (args
[n
]), nbytes
);
3883 padding
= width
< field_width
? field_width
- width
: 0;
3885 if (max_bufsize
- padding
<= convbytes
)
3887 convbytes
+= padding
;
3888 if (convbytes
<= buf
+ bufsize
- p
)
3892 memset (p
, ' ', padding
);
3899 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3900 && STRING_MULTIBYTE (args
[n
])
3901 && !CHAR_HEAD_P (SREF (args
[n
], 0)))
3902 maybe_combine_byte
= 1;
3904 p
+= copy_text (SDATA (args
[n
]), (unsigned char *) p
,
3906 STRING_MULTIBYTE (args
[n
]), multibyte
);
3908 info
[n
].start
= nchars
;
3909 nchars
+= nchars_string
;
3910 info
[n
].end
= nchars
;
3914 memset (p
, ' ', padding
);
3919 /* If this argument has text properties, record where
3920 in the result string it appears. */
3921 if (string_intervals (args
[n
]))
3922 info
[n
].intervals
= arg_intervals
= 1;
3927 else if (! (conversion
== 'c' || conversion
== 'd'
3928 || conversion
== 'e' || conversion
== 'f'
3929 || conversion
== 'g' || conversion
== 'i'
3930 || conversion
== 'o' || conversion
== 'x'
3931 || conversion
== 'X'))
3932 error ("Invalid format operation %%%c",
3933 STRING_CHAR ((unsigned char *) format
- 1));
3934 else if (! (INTEGERP (args
[n
]) || FLOATP (args
[n
])))
3935 error ("Format specifier doesn't match argument type");
3940 /* Maximum precision for a %f conversion such that the
3941 trailing output digit might be nonzero. Any precision
3942 larger than this will not yield useful information. */
3943 USEFUL_PRECISION_MAX
=
3945 * (FLT_RADIX
== 2 || FLT_RADIX
== 10 ? 1
3946 : FLT_RADIX
== 16 ? 4
3949 /* Maximum number of bytes generated by any format, if
3950 precision is no more than USEFUL_PRECISION_MAX.
3951 On all practical hosts, %f is the worst case. */
3953 sizeof "-." + (DBL_MAX_10_EXP
+ 1) + USEFUL_PRECISION_MAX
,
3955 /* Length of pM (that is, of pMd without the
3957 pMlen
= sizeof pMd
- 2
3959 verify (USEFUL_PRECISION_MAX
> 0);
3962 ptrdiff_t padding
, sprintf_bytes
;
3963 uintmax_t excess_precision
, numwidth
;
3964 uintmax_t leading_zeros
= 0, trailing_zeros
= 0;
3966 char sprintf_buf
[SPRINTF_BUFSIZE
];
3968 /* Copy of conversion specification, modified somewhat.
3969 At most three flags F can be specified at once. */
3970 char convspec
[sizeof "%FFF.*d" + pMlen
];
3972 /* Avoid undefined behavior in underlying sprintf. */
3973 if (conversion
== 'd' || conversion
== 'i')
3976 /* Create the copy of the conversion specification, with
3977 any width and precision removed, with ".*" inserted,
3978 and with pM inserted for integer formats. */
3982 *f
= '-'; f
+= minus_flag
;
3983 *f
= '+'; f
+= plus_flag
;
3984 *f
= ' '; f
+= space_flag
;
3985 *f
= '#'; f
+= sharp_flag
;
3986 *f
= '0'; f
+= zero_flag
;
3989 if (conversion
== 'd' || conversion
== 'i'
3990 || conversion
== 'o' || conversion
== 'x'
3991 || conversion
== 'X')
3993 memcpy (f
, pMd
, pMlen
);
3995 zero_flag
&= ~ precision_given
;
4002 if (precision_given
)
4003 prec
= min (precision
, USEFUL_PRECISION_MAX
);
4005 /* Use sprintf to format this number into sprintf_buf. Omit
4006 padding and excess precision, though, because sprintf limits
4007 output length to INT_MAX.
4009 There are four types of conversion: double, unsigned
4010 char (passed as int), wide signed int, and wide
4011 unsigned int. Treat them separately because the
4012 sprintf ABI is sensitive to which type is passed. Be
4013 careful about integer overflow, NaNs, infinities, and
4014 conversions; for example, the min and max macros are
4015 not suitable here. */
4016 if (conversion
== 'e' || conversion
== 'f' || conversion
== 'g')
4018 double x
= (INTEGERP (args
[n
])
4020 : XFLOAT_DATA (args
[n
]));
4021 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4023 else if (conversion
== 'c')
4025 /* Don't use sprintf here, as it might mishandle prec. */
4026 sprintf_buf
[0] = XINT (args
[n
]);
4027 sprintf_bytes
= prec
!= 0;
4029 else if (conversion
== 'd')
4031 /* For float, maybe we should use "%1.0f"
4032 instead so it also works for values outside
4033 the integer range. */
4035 if (INTEGERP (args
[n
]))
4039 double d
= XFLOAT_DATA (args
[n
]);
4042 x
= TYPE_MINIMUM (printmax_t
);
4048 x
= TYPE_MAXIMUM (printmax_t
);
4053 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4057 /* Don't sign-extend for octal or hex printing. */
4059 if (INTEGERP (args
[n
]))
4060 x
= XUINT (args
[n
]);
4063 double d
= XFLOAT_DATA (args
[n
]);
4068 x
= TYPE_MAXIMUM (uprintmax_t
);
4073 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4076 /* Now the length of the formatted item is known, except it omits
4077 padding and excess precision. Deal with excess precision
4078 first. This happens only when the format specifies
4079 ridiculously large precision. */
4080 excess_precision
= precision
- prec
;
4081 if (excess_precision
)
4083 if (conversion
== 'e' || conversion
== 'f'
4084 || conversion
== 'g')
4086 if ((conversion
== 'g' && ! sharp_flag
)
4087 || ! ('0' <= sprintf_buf
[sprintf_bytes
- 1]
4088 && sprintf_buf
[sprintf_bytes
- 1] <= '9'))
4089 excess_precision
= 0;
4092 if (conversion
== 'g')
4094 char *dot
= strchr (sprintf_buf
, '.');
4096 excess_precision
= 0;
4099 trailing_zeros
= excess_precision
;
4102 leading_zeros
= excess_precision
;
4105 /* Compute the total bytes needed for this item, including
4106 excess precision and padding. */
4107 numwidth
= sprintf_bytes
+ excess_precision
;
4108 padding
= numwidth
< field_width
? field_width
- numwidth
: 0;
4109 if (max_bufsize
- sprintf_bytes
<= excess_precision
4110 || max_bufsize
- padding
<= numwidth
)
4112 convbytes
= numwidth
+ padding
;
4114 if (convbytes
<= buf
+ bufsize
- p
)
4116 /* Copy the formatted item from sprintf_buf into buf,
4117 inserting padding and excess-precision zeros. */
4119 char *src
= sprintf_buf
;
4121 int exponent_bytes
= 0;
4122 bool signedp
= src0
== '-' || src0
== '+' || src0
== ' ';
4123 int significand_bytes
;
4125 && ((src
[signedp
] >= '0' && src
[signedp
] <= '9')
4126 || (src
[signedp
] >= 'a' && src
[signedp
] <= 'f')
4127 || (src
[signedp
] >= 'A' && src
[signedp
] <= 'F')))
4129 leading_zeros
+= padding
;
4133 if (excess_precision
4134 && (conversion
== 'e' || conversion
== 'g'))
4136 char *e
= strchr (src
, 'e');
4138 exponent_bytes
= src
+ sprintf_bytes
- e
;
4143 memset (p
, ' ', padding
);
4151 memset (p
, '0', leading_zeros
);
4153 significand_bytes
= sprintf_bytes
- signedp
- exponent_bytes
;
4154 memcpy (p
, src
, significand_bytes
);
4155 p
+= significand_bytes
;
4156 src
+= significand_bytes
;
4157 memset (p
, '0', trailing_zeros
);
4158 p
+= trailing_zeros
;
4159 memcpy (p
, src
, exponent_bytes
);
4160 p
+= exponent_bytes
;
4162 info
[n
].start
= nchars
;
4163 nchars
+= leading_zeros
+ sprintf_bytes
+ trailing_zeros
;
4164 info
[n
].end
= nchars
;
4168 memset (p
, ' ', padding
);
4180 /* Copy a single character from format to buf. */
4183 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
4185 if (multibyte_format
)
4187 /* Copy a whole multibyte character. */
4189 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
4190 && !CHAR_HEAD_P (*format
))
4191 maybe_combine_byte
= 1;
4195 while (! CHAR_HEAD_P (*format
));
4197 convbytes
= format
- src
;
4198 memset (&discarded
[src
+ 1 - format_start
], 2, convbytes
- 1);
4202 unsigned char uc
= *format
++;
4203 if (! multibyte
|| ASCII_BYTE_P (uc
))
4207 int c
= BYTE8_TO_CHAR (uc
);
4208 convbytes
= CHAR_STRING (c
, str
);
4213 if (convbytes
<= buf
+ bufsize
- p
)
4215 memcpy (p
, src
, convbytes
);
4222 /* There wasn't enough room to store this conversion or single
4223 character. CONVBYTES says how much room is needed. Allocate
4224 enough room (and then some) and do it again. */
4226 ptrdiff_t used
= p
- buf
;
4228 if (max_bufsize
- used
< convbytes
)
4230 bufsize
= used
+ convbytes
;
4231 bufsize
= bufsize
< max_bufsize
/ 2 ? bufsize
* 2 : max_bufsize
;
4233 if (buf
== initial_buffer
)
4235 buf
= xmalloc (bufsize
);
4237 buf_save_value_index
= SPECPDL_INDEX ();
4238 record_unwind_protect_ptr (xfree
, buf
);
4239 memcpy (buf
, initial_buffer
, used
);
4243 buf
= xrealloc (buf
, bufsize
);
4244 set_unwind_protect_ptr (buf_save_value_index
, xfree
, buf
);
4254 if (bufsize
< p
- buf
)
4257 if (maybe_combine_byte
)
4258 nchars
= multibyte_chars_in_text ((unsigned char *) buf
, p
- buf
);
4259 val
= make_specified_string (buf
, nchars
, p
- buf
, multibyte
);
4261 /* If we allocated BUF with malloc, free it too. */
4264 /* If the format string has text properties, or any of the string
4265 arguments has text properties, set up text properties of the
4268 if (string_intervals (args
[0]) || arg_intervals
)
4270 Lisp_Object len
, new_len
, props
;
4271 struct gcpro gcpro1
;
4273 /* Add text properties from the format string. */
4274 len
= make_number (SCHARS (args
[0]));
4275 props
= text_property_list (args
[0], make_number (0), len
, Qnil
);
4280 ptrdiff_t bytepos
= 0, position
= 0, translated
= 0;
4284 /* Adjust the bounds of each text property
4285 to the proper start and end in the output string. */
4287 /* Put the positions in PROPS in increasing order, so that
4288 we can do (effectively) one scan through the position
4289 space of the format string. */
4290 props
= Fnreverse (props
);
4292 /* BYTEPOS is the byte position in the format string,
4293 POSITION is the untranslated char position in it,
4294 TRANSLATED is the translated char position in BUF,
4295 and ARGN is the number of the next arg we will come to. */
4296 for (list
= props
; CONSP (list
); list
= XCDR (list
))
4303 /* First adjust the property start position. */
4304 pos
= XINT (XCAR (item
));
4306 /* Advance BYTEPOS, POSITION, TRANSLATED and ARGN
4307 up to this position. */
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 (item
, make_number (translated
));
4325 /* Likewise adjust the property end position. */
4326 pos
= XINT (XCAR (XCDR (item
)));
4328 for (; position
< pos
; bytepos
++)
4330 if (! discarded
[bytepos
])
4331 position
++, translated
++;
4332 else if (discarded
[bytepos
] == 1)
4335 if (translated
== info
[argn
].start
)
4337 translated
+= info
[argn
].end
- info
[argn
].start
;
4343 XSETCAR (XCDR (item
), make_number (translated
));
4346 add_text_properties_from_list (val
, props
, make_number (0));
4349 /* Add text properties from arguments. */
4351 for (n
= 1; n
< nargs
; ++n
)
4352 if (info
[n
].intervals
)
4354 len
= make_number (SCHARS (args
[n
]));
4355 new_len
= make_number (info
[n
].end
- info
[n
].start
);
4356 props
= text_property_list (args
[n
], make_number (0), len
, Qnil
);
4357 props
= extend_property_ranges (props
, new_len
);
4358 /* If successive arguments have properties, be sure that
4359 the value of `composition' property be the copy. */
4360 if (n
> 1 && info
[n
- 1].end
)
4361 make_composition_value_copy (props
);
4362 add_text_properties_from_list (val
, props
,
4363 make_number (info
[n
].start
));
4373 format2 (const char *string1
, Lisp_Object arg0
, Lisp_Object arg1
)
4375 Lisp_Object args
[3];
4376 args
[0] = build_string (string1
);
4379 return Fformat (3, args
);
4382 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
4383 doc
: /* Return t if two characters match, optionally ignoring case.
4384 Both arguments must be characters (i.e. integers).
4385 Case is ignored if `case-fold-search' is non-nil in the current buffer. */)
4386 (register Lisp_Object c1
, Lisp_Object c2
)
4389 /* Check they're chars, not just integers, otherwise we could get array
4390 bounds violations in downcase. */
4391 CHECK_CHARACTER (c1
);
4392 CHECK_CHARACTER (c2
);
4394 if (XINT (c1
) == XINT (c2
))
4396 if (NILP (BVAR (current_buffer
, case_fold_search
)))
4400 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
))
4401 && ! ASCII_CHAR_P (i1
))
4403 MAKE_CHAR_MULTIBYTE (i1
);
4406 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
))
4407 && ! ASCII_CHAR_P (i2
))
4409 MAKE_CHAR_MULTIBYTE (i2
);
4411 return (downcase (i1
) == downcase (i2
) ? Qt
: Qnil
);
4414 /* Transpose the markers in two regions of the current buffer, and
4415 adjust the ones between them if necessary (i.e.: if the regions
4418 START1, END1 are the character positions of the first region.
4419 START1_BYTE, END1_BYTE are the byte positions.
4420 START2, END2 are the character positions of the second region.
4421 START2_BYTE, END2_BYTE are the byte positions.
4423 Traverses the entire marker list of the buffer to do so, adding an
4424 appropriate amount to some, subtracting from some, and leaving the
4425 rest untouched. Most of this is copied from adjust_markers in insdel.c.
4427 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
4430 transpose_markers (ptrdiff_t start1
, ptrdiff_t end1
,
4431 ptrdiff_t start2
, ptrdiff_t end2
,
4432 ptrdiff_t start1_byte
, ptrdiff_t end1_byte
,
4433 ptrdiff_t start2_byte
, ptrdiff_t end2_byte
)
4435 register ptrdiff_t amt1
, amt1_byte
, amt2
, amt2_byte
, diff
, diff_byte
, mpos
;
4436 register struct Lisp_Marker
*marker
;
4438 /* Update point as if it were a marker. */
4442 TEMP_SET_PT_BOTH (PT
+ (end2
- end1
),
4443 PT_BYTE
+ (end2_byte
- end1_byte
));
4444 else if (PT
< start2
)
4445 TEMP_SET_PT_BOTH (PT
+ (end2
- start2
) - (end1
- start1
),
4446 (PT_BYTE
+ (end2_byte
- start2_byte
)
4447 - (end1_byte
- start1_byte
)));
4449 TEMP_SET_PT_BOTH (PT
- (start2
- start1
),
4450 PT_BYTE
- (start2_byte
- start1_byte
));
4452 /* We used to adjust the endpoints here to account for the gap, but that
4453 isn't good enough. Even if we assume the caller has tried to move the
4454 gap out of our way, it might still be at start1 exactly, for example;
4455 and that places it `inside' the interval, for our purposes. The amount
4456 of adjustment is nontrivial if there's a `denormalized' marker whose
4457 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
4458 the dirty work to Fmarker_position, below. */
4460 /* The difference between the region's lengths */
4461 diff
= (end2
- start2
) - (end1
- start1
);
4462 diff_byte
= (end2_byte
- start2_byte
) - (end1_byte
- start1_byte
);
4464 /* For shifting each marker in a region by the length of the other
4465 region plus the distance between the regions. */
4466 amt1
= (end2
- start2
) + (start2
- end1
);
4467 amt2
= (end1
- start1
) + (start2
- end1
);
4468 amt1_byte
= (end2_byte
- start2_byte
) + (start2_byte
- end1_byte
);
4469 amt2_byte
= (end1_byte
- start1_byte
) + (start2_byte
- end1_byte
);
4471 for (marker
= BUF_MARKERS (current_buffer
); marker
; marker
= marker
->next
)
4473 mpos
= marker
->bytepos
;
4474 if (mpos
>= start1_byte
&& mpos
< end2_byte
)
4476 if (mpos
< end1_byte
)
4478 else if (mpos
< start2_byte
)
4482 marker
->bytepos
= mpos
;
4484 mpos
= marker
->charpos
;
4485 if (mpos
>= start1
&& mpos
< end2
)
4489 else if (mpos
< start2
)
4494 marker
->charpos
= mpos
;
4498 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
4499 doc
: /* Transpose region STARTR1 to ENDR1 with STARTR2 to ENDR2.
4500 The regions should not be overlapping, because the size of the buffer is
4501 never changed in a transposition.
4503 Optional fifth arg LEAVE-MARKERS, if non-nil, means don't update
4504 any markers that happen to be located in the regions.
4506 Transposing beyond buffer boundaries is an error. */)
4507 (Lisp_Object startr1
, Lisp_Object endr1
, Lisp_Object startr2
, Lisp_Object endr2
, Lisp_Object leave_markers
)
4509 register ptrdiff_t start1
, end1
, start2
, end2
;
4510 ptrdiff_t start1_byte
, start2_byte
, len1_byte
, len2_byte
, end2_byte
;
4511 ptrdiff_t gap
, len1
, len_mid
, len2
;
4512 unsigned char *start1_addr
, *start2_addr
, *temp
;
4514 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
, tmp_interval3
;
4517 XSETBUFFER (buf
, current_buffer
);
4518 cur_intv
= buffer_intervals (current_buffer
);
4520 validate_region (&startr1
, &endr1
);
4521 validate_region (&startr2
, &endr2
);
4523 start1
= XFASTINT (startr1
);
4524 end1
= XFASTINT (endr1
);
4525 start2
= XFASTINT (startr2
);
4526 end2
= XFASTINT (endr2
);
4529 /* Swap the regions if they're reversed. */
4532 register ptrdiff_t glumph
= start1
;
4540 len1
= end1
- start1
;
4541 len2
= end2
- start2
;
4544 error ("Transposed regions overlap");
4545 /* Nothing to change for adjacent regions with one being empty */
4546 else if ((start1
== end1
|| start2
== end2
) && end1
== start2
)
4549 /* The possibilities are:
4550 1. Adjacent (contiguous) regions, or separate but equal regions
4551 (no, really equal, in this case!), or
4552 2. Separate regions of unequal size.
4554 The worst case is usually No. 2. It means that (aside from
4555 potential need for getting the gap out of the way), there also
4556 needs to be a shifting of the text between the two regions. So
4557 if they are spread far apart, we are that much slower... sigh. */
4559 /* It must be pointed out that the really studly thing to do would
4560 be not to move the gap at all, but to leave it in place and work
4561 around it if necessary. This would be extremely efficient,
4562 especially considering that people are likely to do
4563 transpositions near where they are working interactively, which
4564 is exactly where the gap would be found. However, such code
4565 would be much harder to write and to read. So, if you are
4566 reading this comment and are feeling squirrely, by all means have
4567 a go! I just didn't feel like doing it, so I will simply move
4568 the gap the minimum distance to get it out of the way, and then
4569 deal with an unbroken array. */
4571 start1_byte
= CHAR_TO_BYTE (start1
);
4572 end2_byte
= CHAR_TO_BYTE (end2
);
4574 /* Make sure the gap won't interfere, by moving it out of the text
4575 we will operate on. */
4576 if (start1
< gap
&& gap
< end2
)
4578 if (gap
- start1
< end2
- gap
)
4579 move_gap_both (start1
, start1_byte
);
4581 move_gap_both (end2
, end2_byte
);
4584 start2_byte
= CHAR_TO_BYTE (start2
);
4585 len1_byte
= CHAR_TO_BYTE (end1
) - start1_byte
;
4586 len2_byte
= end2_byte
- start2_byte
;
4588 #ifdef BYTE_COMBINING_DEBUG
4591 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4592 len2_byte
, start1
, start1_byte
)
4593 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4594 len1_byte
, end2
, start2_byte
+ len2_byte
)
4595 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4596 len1_byte
, end2
, start2_byte
+ len2_byte
))
4601 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4602 len2_byte
, start1
, start1_byte
)
4603 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4604 len1_byte
, start2
, start2_byte
)
4605 || count_combining_after (BYTE_POS_ADDR (start2_byte
),
4606 len2_byte
, end1
, start1_byte
+ len1_byte
)
4607 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4608 len1_byte
, end2
, start2_byte
+ len2_byte
))
4613 /* Hmmm... how about checking to see if the gap is large
4614 enough to use as the temporary storage? That would avoid an
4615 allocation... interesting. Later, don't fool with it now. */
4617 /* Working without memmove, for portability (sigh), so must be
4618 careful of overlapping subsections of the array... */
4620 if (end1
== start2
) /* adjacent regions */
4622 modify_text (start1
, end2
);
4623 record_change (start1
, len1
+ len2
);
4625 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4626 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4627 /* Don't use Fset_text_properties: that can cause GC, which can
4628 clobber objects stored in the tmp_intervals. */
4629 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4631 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4633 /* First region smaller than second. */
4634 if (len1_byte
< len2_byte
)
4638 temp
= SAFE_ALLOCA (len2_byte
);
4640 /* Don't precompute these addresses. We have to compute them
4641 at the last minute, because the relocating allocator might
4642 have moved the buffer around during the xmalloc. */
4643 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4644 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4646 memcpy (temp
, start2_addr
, len2_byte
);
4647 memcpy (start1_addr
+ len2_byte
, start1_addr
, len1_byte
);
4648 memcpy (start1_addr
, temp
, len2_byte
);
4652 /* First region not smaller than second. */
4656 temp
= SAFE_ALLOCA (len1_byte
);
4657 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4658 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4659 memcpy (temp
, start1_addr
, len1_byte
);
4660 memcpy (start1_addr
, start2_addr
, len2_byte
);
4661 memcpy (start1_addr
+ len2_byte
, temp
, len1_byte
);
4664 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
4665 len1
, current_buffer
, 0);
4666 graft_intervals_into_buffer (tmp_interval2
, start1
,
4667 len2
, current_buffer
, 0);
4668 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4669 update_compositions (start1
+ len2
, end2
, CHECK_TAIL
);
4671 /* Non-adjacent regions, because end1 != start2, bleagh... */
4674 len_mid
= start2_byte
- (start1_byte
+ len1_byte
);
4676 if (len1_byte
== len2_byte
)
4677 /* Regions are same size, though, how nice. */
4681 modify_text (start1
, end1
);
4682 modify_text (start2
, end2
);
4683 record_change (start1
, len1
);
4684 record_change (start2
, len2
);
4685 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4686 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4688 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr1
, 0);
4690 set_text_properties_1 (startr1
, endr1
, Qnil
, buf
, tmp_interval3
);
4692 tmp_interval3
= validate_interval_range (buf
, &startr2
, &endr2
, 0);
4694 set_text_properties_1 (startr2
, endr2
, Qnil
, buf
, tmp_interval3
);
4696 temp
= SAFE_ALLOCA (len1_byte
);
4697 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4698 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4699 memcpy (temp
, start1_addr
, len1_byte
);
4700 memcpy (start1_addr
, start2_addr
, len2_byte
);
4701 memcpy (start2_addr
, temp
, len1_byte
);
4704 graft_intervals_into_buffer (tmp_interval1
, start2
,
4705 len1
, current_buffer
, 0);
4706 graft_intervals_into_buffer (tmp_interval2
, start1
,
4707 len2
, current_buffer
, 0);
4710 else if (len1_byte
< len2_byte
) /* Second region larger than first */
4711 /* Non-adjacent & unequal size, area between must also be shifted. */
4715 modify_text (start1
, end2
);
4716 record_change (start1
, (end2
- start1
));
4717 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4718 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4719 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4721 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4723 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4725 /* holds region 2 */
4726 temp
= SAFE_ALLOCA (len2_byte
);
4727 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4728 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4729 memcpy (temp
, start2_addr
, len2_byte
);
4730 memcpy (start1_addr
+ len_mid
+ len2_byte
, start1_addr
, len1_byte
);
4731 memmove (start1_addr
+ len2_byte
, start1_addr
+ len1_byte
, len_mid
);
4732 memcpy (start1_addr
, temp
, len2_byte
);
4735 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4736 len1
, current_buffer
, 0);
4737 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4738 len_mid
, current_buffer
, 0);
4739 graft_intervals_into_buffer (tmp_interval2
, start1
,
4740 len2
, current_buffer
, 0);
4743 /* Second region smaller than first. */
4747 record_change (start1
, (end2
- start1
));
4748 modify_text (start1
, end2
);
4750 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4751 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4752 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4754 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4756 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4758 /* holds region 1 */
4759 temp
= SAFE_ALLOCA (len1_byte
);
4760 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4761 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4762 memcpy (temp
, start1_addr
, len1_byte
);
4763 memcpy (start1_addr
, start2_addr
, len2_byte
);
4764 memcpy (start1_addr
+ len2_byte
, start1_addr
+ len1_byte
, len_mid
);
4765 memcpy (start1_addr
+ len2_byte
+ len_mid
, temp
, len1_byte
);
4768 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4769 len1
, current_buffer
, 0);
4770 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4771 len_mid
, current_buffer
, 0);
4772 graft_intervals_into_buffer (tmp_interval2
, start1
,
4773 len2
, current_buffer
, 0);
4776 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4777 update_compositions (end2
- len1
, end2
, CHECK_BORDER
);
4780 /* When doing multiple transpositions, it might be nice
4781 to optimize this. Perhaps the markers in any one buffer
4782 should be organized in some sorted data tree. */
4783 if (NILP (leave_markers
))
4785 transpose_markers (start1
, end1
, start2
, end2
,
4786 start1_byte
, start1_byte
+ len1_byte
,
4787 start2_byte
, start2_byte
+ len2_byte
);
4788 fix_start_end_in_overlays (start1
, end2
);
4791 signal_after_change (start1
, end2
- start1
, end2
- start1
);
4797 syms_of_editfns (void)
4799 DEFSYM (Qbuffer_access_fontify_functions
, "buffer-access-fontify-functions");
4801 DEFVAR_LISP ("inhibit-field-text-motion", Vinhibit_field_text_motion
,
4802 doc
: /* Non-nil means text motion commands don't notice fields. */);
4803 Vinhibit_field_text_motion
= Qnil
;
4805 DEFVAR_LISP ("buffer-access-fontify-functions",
4806 Vbuffer_access_fontify_functions
,
4807 doc
: /* List of functions called by `buffer-substring' to fontify if necessary.
4808 Each function is called with two arguments which specify the range
4809 of the buffer being accessed. */);
4810 Vbuffer_access_fontify_functions
= Qnil
;
4814 obuf
= Fcurrent_buffer ();
4815 /* Do this here, because init_buffer_once is too early--it won't work. */
4816 Fset_buffer (Vprin1_to_string_buffer
);
4817 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
4818 Fset (Fmake_local_variable (intern_c_string ("buffer-access-fontify-functions")),
4823 DEFVAR_LISP ("buffer-access-fontified-property",
4824 Vbuffer_access_fontified_property
,
4825 doc
: /* Property which (if non-nil) indicates text has been fontified.
4826 `buffer-substring' need not call the `buffer-access-fontify-functions'
4827 functions if all the text being accessed has this property. */);
4828 Vbuffer_access_fontified_property
= Qnil
;
4830 DEFVAR_LISP ("system-name", Vsystem_name
,
4831 doc
: /* The host name of the machine Emacs is running on. */);
4833 DEFVAR_LISP ("user-full-name", Vuser_full_name
,
4834 doc
: /* The full name of the user logged in. */);
4836 DEFVAR_LISP ("user-login-name", Vuser_login_name
,
4837 doc
: /* The user's name, taken from environment variables if possible. */);
4839 DEFVAR_LISP ("user-real-login-name", Vuser_real_login_name
,
4840 doc
: /* The user's name, based upon the real uid only. */);
4842 DEFVAR_LISP ("operating-system-release", Voperating_system_release
,
4843 doc
: /* The release of the operating system Emacs is running on. */);
4845 defsubr (&Spropertize
);
4846 defsubr (&Schar_equal
);
4847 defsubr (&Sgoto_char
);
4848 defsubr (&Sstring_to_char
);
4849 defsubr (&Schar_to_string
);
4850 defsubr (&Sbyte_to_string
);
4851 defsubr (&Sbuffer_substring
);
4852 defsubr (&Sbuffer_substring_no_properties
);
4853 defsubr (&Sbuffer_string
);
4855 defsubr (&Spoint_marker
);
4856 defsubr (&Smark_marker
);
4858 defsubr (&Sregion_beginning
);
4859 defsubr (&Sregion_end
);
4861 DEFSYM (Qfield
, "field");
4862 DEFSYM (Qboundary
, "boundary");
4863 defsubr (&Sfield_beginning
);
4864 defsubr (&Sfield_end
);
4865 defsubr (&Sfield_string
);
4866 defsubr (&Sfield_string_no_properties
);
4867 defsubr (&Sdelete_field
);
4868 defsubr (&Sconstrain_to_field
);
4870 defsubr (&Sline_beginning_position
);
4871 defsubr (&Sline_end_position
);
4873 defsubr (&Ssave_excursion
);
4874 defsubr (&Ssave_current_buffer
);
4876 defsubr (&Sbuffer_size
);
4877 defsubr (&Spoint_max
);
4878 defsubr (&Spoint_min
);
4879 defsubr (&Spoint_min_marker
);
4880 defsubr (&Spoint_max_marker
);
4881 defsubr (&Sgap_position
);
4882 defsubr (&Sgap_size
);
4883 defsubr (&Sposition_bytes
);
4884 defsubr (&Sbyte_to_position
);
4890 defsubr (&Sfollowing_char
);
4891 defsubr (&Sprevious_char
);
4892 defsubr (&Schar_after
);
4893 defsubr (&Schar_before
);
4895 defsubr (&Sinsert_before_markers
);
4896 defsubr (&Sinsert_and_inherit
);
4897 defsubr (&Sinsert_and_inherit_before_markers
);
4898 defsubr (&Sinsert_char
);
4899 defsubr (&Sinsert_byte
);
4901 defsubr (&Suser_login_name
);
4902 defsubr (&Suser_real_login_name
);
4903 defsubr (&Suser_uid
);
4904 defsubr (&Suser_real_uid
);
4905 defsubr (&Sgroup_gid
);
4906 defsubr (&Sgroup_real_gid
);
4907 defsubr (&Suser_full_name
);
4908 defsubr (&Semacs_pid
);
4909 defsubr (&Scurrent_time
);
4910 defsubr (&Sget_internal_run_time
);
4911 defsubr (&Sformat_time_string
);
4912 defsubr (&Sfloat_time
);
4913 defsubr (&Sdecode_time
);
4914 defsubr (&Sencode_time
);
4915 defsubr (&Scurrent_time_string
);
4916 defsubr (&Scurrent_time_zone
);
4917 defsubr (&Sset_time_zone_rule
);
4918 defsubr (&Ssystem_name
);
4919 defsubr (&Smessage
);
4920 defsubr (&Smessage_box
);
4921 defsubr (&Smessage_or_box
);
4922 defsubr (&Scurrent_message
);
4925 defsubr (&Sinsert_buffer_substring
);
4926 defsubr (&Scompare_buffer_substrings
);
4927 defsubr (&Ssubst_char_in_region
);
4928 defsubr (&Stranslate_region_internal
);
4929 defsubr (&Sdelete_region
);
4930 defsubr (&Sdelete_and_extract_region
);
4932 defsubr (&Snarrow_to_region
);
4933 defsubr (&Ssave_restriction
);
4934 defsubr (&Stranspose_regions
);