1 /* Lisp functions pertaining to editing.
3 Copyright (C) 1985-1987, 1989, 1993-2012 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
)->buffer
;
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
;
390 set_buffer_temp (XBUFFER (object
));
392 /* First try with room for 40 overlays. */
394 overlay_vec
= alloca (noverlays
* sizeof *overlay_vec
);
395 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
397 /* If there are more than 40,
398 make enough space for all, and try again. */
401 overlay_vec
= alloca (noverlays
* sizeof *overlay_vec
);
402 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
404 noverlays
= sort_overlays (overlay_vec
, noverlays
, NULL
);
406 set_buffer_temp (obuf
);
408 /* Now check the overlays in order of decreasing priority. */
409 while (--noverlays
>= 0)
411 Lisp_Object ol
= overlay_vec
[noverlays
];
412 tem
= Foverlay_get (ol
, prop
);
415 /* Check the overlay is indeed active at point. */
416 Lisp_Object start
= OVERLAY_START (ol
), finish
= OVERLAY_END (ol
);
417 if ((OVERLAY_POSITION (start
) == posn
418 && XMARKER (start
)->insertion_type
== 1)
419 || (OVERLAY_POSITION (finish
) == posn
420 && XMARKER (finish
)->insertion_type
== 0))
421 ; /* The overlay will not cover a char inserted at point. */
429 { /* Now check the text properties. */
430 int stickiness
= text_property_stickiness (prop
, position
, object
);
432 return Fget_text_property (position
, prop
, object
);
433 else if (stickiness
< 0
434 && XINT (position
) > BUF_BEGV (XBUFFER (object
)))
435 return Fget_text_property (make_number (XINT (position
) - 1),
443 /* Find the field surrounding POS in *BEG and *END. If POS is nil,
444 the value of point is used instead. If BEG or END is null,
445 means don't store the beginning or end of the field.
447 BEG_LIMIT and END_LIMIT serve to limit the ranged of the returned
448 results; they do not effect boundary behavior.
450 If MERGE_AT_BOUNDARY is non-nil, then if POS is at the very first
451 position of a field, then the beginning of the previous field is
452 returned instead of the beginning of POS's field (since the end of a
453 field is actually also the beginning of the next input field, this
454 behavior is sometimes useful). Additionally in the MERGE_AT_BOUNDARY
455 non-nil case, if two fields are separated by a field with the special
456 value `boundary', and POS lies within it, then the two separated
457 fields are considered to be adjacent, and POS between them, when
458 finding the beginning and ending of the "merged" field.
460 Either BEG or END may be 0, in which case the corresponding value
464 find_field (Lisp_Object pos
, Lisp_Object merge_at_boundary
,
465 Lisp_Object beg_limit
,
466 ptrdiff_t *beg
, Lisp_Object end_limit
, ptrdiff_t *end
)
468 /* Fields right before and after the point. */
469 Lisp_Object before_field
, after_field
;
470 /* True if POS counts as the start of a field. */
471 bool at_field_start
= 0;
472 /* True if POS counts as the end of a field. */
473 bool at_field_end
= 0;
476 XSETFASTINT (pos
, PT
);
478 CHECK_NUMBER_COERCE_MARKER (pos
);
481 = get_char_property_and_overlay (pos
, Qfield
, Qnil
, NULL
);
483 = (XFASTINT (pos
) > BEGV
484 ? get_char_property_and_overlay (make_number (XINT (pos
) - 1),
486 /* Using nil here would be a more obvious choice, but it would
487 fail when the buffer starts with a non-sticky field. */
490 /* See if we need to handle the case where MERGE_AT_BOUNDARY is nil
491 and POS is at beginning of a field, which can also be interpreted
492 as the end of the previous field. Note that the case where if
493 MERGE_AT_BOUNDARY is non-nil (see function comment) is actually the
494 more natural one; then we avoid treating the beginning of a field
496 if (NILP (merge_at_boundary
))
498 Lisp_Object field
= get_pos_property (pos
, Qfield
, Qnil
);
499 if (!EQ (field
, after_field
))
501 if (!EQ (field
, before_field
))
503 if (NILP (field
) && at_field_start
&& at_field_end
)
504 /* If an inserted char would have a nil field while the surrounding
505 text is non-nil, we're probably not looking at a
506 zero-length field, but instead at a non-nil field that's
507 not intended for editing (such as comint's prompts). */
508 at_field_end
= at_field_start
= 0;
511 /* Note about special `boundary' fields:
513 Consider the case where the point (`.') is between the fields `x' and `y':
517 In this situation, if merge_at_boundary is non-nil, consider the
518 `x' and `y' fields as forming one big merged field, and so the end
519 of the field is the end of `y'.
521 However, if `x' and `y' are separated by a special `boundary' field
522 (a field with a `field' char-property of 'boundary), then ignore
523 this special field when merging adjacent fields. Here's the same
524 situation, but with a `boundary' field between the `x' and `y' fields:
528 Here, if point is at the end of `x', the beginning of `y', or
529 anywhere in-between (within the `boundary' field), merge all
530 three fields and consider the beginning as being the beginning of
531 the `x' field, and the end as being the end of the `y' field. */
536 /* POS is at the edge of a field, and we should consider it as
537 the beginning of the following field. */
538 *beg
= XFASTINT (pos
);
540 /* Find the previous field boundary. */
543 if (!NILP (merge_at_boundary
) && EQ (before_field
, Qboundary
))
544 /* Skip a `boundary' field. */
545 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
548 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
550 *beg
= NILP (p
) ? BEGV
: XFASTINT (p
);
557 /* POS is at the edge of a field, and we should consider it as
558 the end of the previous field. */
559 *end
= XFASTINT (pos
);
561 /* Find the next field boundary. */
563 if (!NILP (merge_at_boundary
) && EQ (after_field
, Qboundary
))
564 /* Skip a `boundary' field. */
565 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
568 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
570 *end
= NILP (pos
) ? ZV
: XFASTINT (pos
);
576 DEFUN ("delete-field", Fdelete_field
, Sdelete_field
, 0, 1, 0,
577 doc
: /* Delete the field surrounding POS.
578 A field is a region of text with the same `field' property.
579 If POS is nil, the value of point is used for POS. */)
583 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
585 del_range (beg
, end
);
589 DEFUN ("field-string", Ffield_string
, Sfield_string
, 0, 1, 0,
590 doc
: /* Return the contents of the field surrounding POS as a string.
591 A field is a region of text with the same `field' property.
592 If POS is nil, the value of point is used for POS. */)
596 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
597 return make_buffer_string (beg
, end
, 1);
600 DEFUN ("field-string-no-properties", Ffield_string_no_properties
, Sfield_string_no_properties
, 0, 1, 0,
601 doc
: /* Return the contents of the field around POS, without text properties.
602 A field is a region of text with the same `field' property.
603 If POS is nil, the value of point is used for POS. */)
607 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
608 return make_buffer_string (beg
, end
, 0);
611 DEFUN ("field-beginning", Ffield_beginning
, Sfield_beginning
, 0, 3, 0,
612 doc
: /* Return the beginning of the field surrounding POS.
613 A field is a region of text with the same `field' property.
614 If POS is nil, the value of point is used for POS.
615 If ESCAPE-FROM-EDGE is non-nil and POS is at the beginning of its
616 field, then the beginning of the *previous* field is returned.
617 If LIMIT is non-nil, it is a buffer position; if the beginning of the field
618 is before LIMIT, then LIMIT will be returned instead. */)
619 (Lisp_Object pos
, Lisp_Object escape_from_edge
, Lisp_Object limit
)
622 find_field (pos
, escape_from_edge
, limit
, &beg
, Qnil
, 0);
623 return make_number (beg
);
626 DEFUN ("field-end", Ffield_end
, Sfield_end
, 0, 3, 0,
627 doc
: /* Return the end of the field surrounding POS.
628 A field is a region of text with the same `field' property.
629 If POS is nil, the value of point is used for POS.
630 If ESCAPE-FROM-EDGE is non-nil and POS is at the end of its field,
631 then the end of the *following* field is returned.
632 If LIMIT is non-nil, it is a buffer position; if the end of the field
633 is after LIMIT, then LIMIT will be returned instead. */)
634 (Lisp_Object pos
, Lisp_Object escape_from_edge
, Lisp_Object limit
)
637 find_field (pos
, escape_from_edge
, Qnil
, 0, limit
, &end
);
638 return make_number (end
);
641 DEFUN ("constrain-to-field", Fconstrain_to_field
, Sconstrain_to_field
, 2, 5, 0,
642 doc
: /* Return the position closest to NEW-POS that is in the same field as OLD-POS.
643 A field is a region of text with the same `field' property.
645 If NEW-POS is nil, then use the current point instead, and move point
646 to the resulting constrained position, in addition to returning that
649 If OLD-POS is at the boundary of two fields, then the allowable
650 positions for NEW-POS depends on the value of the optional argument
651 ESCAPE-FROM-EDGE: If ESCAPE-FROM-EDGE is nil, then NEW-POS is
652 constrained to the field that has the same `field' char-property
653 as any new characters inserted at OLD-POS, whereas if ESCAPE-FROM-EDGE
654 is non-nil, NEW-POS is constrained to the union of the two adjacent
655 fields. Additionally, if two fields are separated by another field with
656 the special value `boundary', then any point within this special field is
657 also considered to be `on the boundary'.
659 If the optional argument ONLY-IN-LINE is non-nil and constraining
660 NEW-POS would move it to a different line, NEW-POS is returned
661 unconstrained. This useful for commands that move by line, like
662 \\[next-line] or \\[beginning-of-line], which should generally respect field boundaries
663 only in the case where they can still move to the right line.
665 If the optional argument INHIBIT-CAPTURE-PROPERTY is non-nil, and OLD-POS has
666 a non-nil property of that name, then any field boundaries are ignored.
668 Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */)
669 (Lisp_Object new_pos
, Lisp_Object old_pos
, Lisp_Object escape_from_edge
, Lisp_Object only_in_line
, Lisp_Object inhibit_capture_property
)
671 /* If non-zero, then the original point, before re-positioning. */
672 ptrdiff_t orig_point
= 0;
674 Lisp_Object prev_old
, prev_new
;
677 /* Use the current point, and afterwards, set it. */
680 XSETFASTINT (new_pos
, PT
);
683 CHECK_NUMBER_COERCE_MARKER (new_pos
);
684 CHECK_NUMBER_COERCE_MARKER (old_pos
);
686 fwd
= (XINT (new_pos
) > XINT (old_pos
));
688 prev_old
= make_number (XINT (old_pos
) - 1);
689 prev_new
= make_number (XINT (new_pos
) - 1);
691 if (NILP (Vinhibit_field_text_motion
)
692 && !EQ (new_pos
, old_pos
)
693 && (!NILP (Fget_char_property (new_pos
, Qfield
, Qnil
))
694 || !NILP (Fget_char_property (old_pos
, Qfield
, Qnil
))
695 /* To recognize field boundaries, we must also look at the
696 previous positions; we could use `get_pos_property'
697 instead, but in itself that would fail inside non-sticky
698 fields (like comint prompts). */
699 || (XFASTINT (new_pos
) > BEGV
700 && !NILP (Fget_char_property (prev_new
, Qfield
, Qnil
)))
701 || (XFASTINT (old_pos
) > BEGV
702 && !NILP (Fget_char_property (prev_old
, Qfield
, Qnil
))))
703 && (NILP (inhibit_capture_property
)
704 /* Field boundaries are again a problem; but now we must
705 decide the case exactly, so we need to call
706 `get_pos_property' as well. */
707 || (NILP (get_pos_property (old_pos
, inhibit_capture_property
, Qnil
))
708 && (XFASTINT (old_pos
) <= BEGV
709 || NILP (Fget_char_property (old_pos
, inhibit_capture_property
, Qnil
))
710 || NILP (Fget_char_property (prev_old
, inhibit_capture_property
, Qnil
))))))
711 /* It is possible that NEW_POS is not within the same field as
712 OLD_POS; try to move NEW_POS so that it is. */
715 Lisp_Object field_bound
;
718 field_bound
= Ffield_end (old_pos
, escape_from_edge
, new_pos
);
720 field_bound
= Ffield_beginning (old_pos
, escape_from_edge
, new_pos
);
722 if (/* See if ESCAPE_FROM_EDGE caused FIELD_BOUND to jump to the
723 other side of NEW_POS, which would mean that NEW_POS is
724 already acceptable, and it's not necessary to constrain it
726 ((XFASTINT (field_bound
) < XFASTINT (new_pos
)) ? fwd
: !fwd
)
727 /* NEW_POS should be constrained, but only if either
728 ONLY_IN_LINE is nil (in which case any constraint is OK),
729 or NEW_POS and FIELD_BOUND are on the same line (in which
730 case the constraint is OK even if ONLY_IN_LINE is non-nil). */
731 && (NILP (only_in_line
)
732 /* This is the ONLY_IN_LINE case, check that NEW_POS and
733 FIELD_BOUND are on the same line by seeing whether
734 there's an intervening newline or not. */
735 || (scan_buffer ('\n',
736 XFASTINT (new_pos
), XFASTINT (field_bound
),
737 fwd
? -1 : 1, &shortage
, 1),
739 /* Constrain NEW_POS to FIELD_BOUND. */
740 new_pos
= field_bound
;
742 if (orig_point
&& XFASTINT (new_pos
) != orig_point
)
743 /* The NEW_POS argument was originally nil, so automatically set PT. */
744 SET_PT (XFASTINT (new_pos
));
751 DEFUN ("line-beginning-position",
752 Fline_beginning_position
, Sline_beginning_position
, 0, 1, 0,
753 doc
: /* Return the character position of the first character on the current line.
754 With optional argument N, scan forward N - 1 lines first.
755 If the scan reaches the end of the buffer, return that position.
757 This function ignores text display directionality; it returns the
758 position of the first character in logical order, i.e. the smallest
759 character position on the line.
761 This function constrains the returned position to the current field
762 unless that position would be on a different line than the original,
763 unconstrained result. If N is nil or 1, and a front-sticky field
764 starts at point, the scan stops as soon as it starts. To ignore field
765 boundaries, bind `inhibit-field-text-motion' to t.
767 This function does not move point. */)
770 ptrdiff_t orig
, orig_byte
, end
;
771 ptrdiff_t count
= SPECPDL_INDEX ();
772 specbind (Qinhibit_point_motion_hooks
, Qt
);
781 Fforward_line (make_number (XINT (n
) - 1));
784 SET_PT_BOTH (orig
, orig_byte
);
786 unbind_to (count
, Qnil
);
788 /* Return END constrained to the current input field. */
789 return Fconstrain_to_field (make_number (end
), make_number (orig
),
790 XINT (n
) != 1 ? Qt
: Qnil
,
794 DEFUN ("line-end-position", Fline_end_position
, Sline_end_position
, 0, 1, 0,
795 doc
: /* Return the character position of the last character on the current line.
796 With argument N not nil or 1, move forward N - 1 lines first.
797 If scan reaches end of buffer, return that position.
799 This function ignores text display directionality; it returns the
800 position of the last character in logical order, i.e. the largest
801 character position on the line.
803 This function constrains the returned position to the current field
804 unless that would be on a different line than the original,
805 unconstrained result. If N is nil or 1, and a rear-sticky field ends
806 at point, the scan stops as soon as it starts. To ignore field
807 boundaries bind `inhibit-field-text-motion' to t.
809 This function does not move point. */)
821 clipped_n
= clip_to_bounds (PTRDIFF_MIN
+ 1, XINT (n
), PTRDIFF_MAX
);
822 end_pos
= find_before_next_newline (orig
, 0, clipped_n
- (clipped_n
<= 0));
824 /* Return END_POS constrained to the current input field. */
825 return Fconstrain_to_field (make_number (end_pos
), make_number (orig
),
829 /* Save current buffer state for `save-excursion' special form.
830 We (ab)use Lisp_Misc_Save_Value to allow explicit free and so
831 offload some work from GC. */
834 save_excursion_save (void)
836 Lisp_Object save
, *data
= xmalloc (word_size
* 4);
838 data
[0] = Fpoint_marker ();
839 /* Do not copy the mark if it points to nowhere. */
840 data
[1] = (XMARKER (BVAR (current_buffer
, mark
))->buffer
841 ? Fcopy_marker (BVAR (current_buffer
, mark
), Qnil
)
843 /* Selected window if current buffer is shown in it, nil otherwise. */
844 data
[2] = ((XBUFFER (XWINDOW (selected_window
)->buffer
) == current_buffer
)
845 ? selected_window
: Qnil
);
846 data
[3] = BVAR (current_buffer
, mark_active
);
848 save
= make_save_value (data
, 4);
849 XSAVE_VALUE (save
)->dogc
= 1;
853 /* Restore saved buffer before leaving `save-excursion' special form. */
856 save_excursion_restore (Lisp_Object info
)
858 Lisp_Object tem
, tem1
, omark
, nmark
, *data
= XSAVE_VALUE (info
)->pointer
;
859 struct gcpro gcpro1
, gcpro2
, gcpro3
;
861 tem
= Fmarker_buffer (data
[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
);
875 unchain_marker (XMARKER (tem
));
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
));
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. */
916 && !EQ (tem
, selected_window
)
917 && (tem1
= XWINDOW (tem
)->buffer
,
918 (/* Window is live... */
920 /* ...and it shows the current buffer. */
921 && XBUFFER (tem1
) == current_buffer
)))
922 Fset_window_point (tem
, make_number (PT
));
928 free_save_value (info
);
932 DEFUN ("save-excursion", Fsave_excursion
, Ssave_excursion
, 0, UNEVALLED
, 0,
933 doc
: /* Save point, mark, and current buffer; execute BODY; restore those things.
934 Executes BODY just like `progn'.
935 The values of point, mark and the current buffer are restored
936 even in case of abnormal exit (throw or error).
937 The state of activation of the mark is also restored.
939 This construct does not save `deactivate-mark', and therefore
940 functions that change the buffer will still cause deactivation
941 of the mark at the end of the command. To prevent that, bind
942 `deactivate-mark' with `let'.
944 If you only want to save the current buffer but not point nor mark,
945 then just use `save-current-buffer', or even `with-current-buffer'.
947 usage: (save-excursion &rest BODY) */)
950 register Lisp_Object val
;
951 ptrdiff_t count
= SPECPDL_INDEX ();
953 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
956 return unbind_to (count
, val
);
959 DEFUN ("save-current-buffer", Fsave_current_buffer
, Ssave_current_buffer
, 0, UNEVALLED
, 0,
960 doc
: /* Record which buffer is current; execute BODY; make that buffer current.
961 BODY is executed just like `progn'.
962 usage: (save-current-buffer &rest BODY) */)
965 ptrdiff_t count
= SPECPDL_INDEX ();
967 record_unwind_current_buffer ();
968 return unbind_to (count
, Fprogn (args
));
971 DEFUN ("buffer-size", Fbufsize
, Sbufsize
, 0, 1, 0,
972 doc
: /* Return the number of characters in the current buffer.
973 If BUFFER, return the number of characters in that buffer instead. */)
977 return make_number (Z
- BEG
);
980 CHECK_BUFFER (buffer
);
981 return make_number (BUF_Z (XBUFFER (buffer
))
982 - BUF_BEG (XBUFFER (buffer
)));
986 DEFUN ("point-min", Fpoint_min
, Spoint_min
, 0, 0, 0,
987 doc
: /* Return the minimum permissible value of point in the current buffer.
988 This is 1, unless narrowing (a buffer restriction) is in effect. */)
992 XSETFASTINT (temp
, BEGV
);
996 DEFUN ("point-min-marker", Fpoint_min_marker
, Spoint_min_marker
, 0, 0, 0,
997 doc
: /* Return a marker to the minimum permissible value of point in this buffer.
998 This is the beginning, unless narrowing (a buffer restriction) is in effect. */)
1001 return build_marker (current_buffer
, BEGV
, BEGV_BYTE
);
1004 DEFUN ("point-max", Fpoint_max
, Spoint_max
, 0, 0, 0,
1005 doc
: /* Return the maximum permissible value of point in the current buffer.
1006 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1007 is in effect, in which case it is less. */)
1011 XSETFASTINT (temp
, ZV
);
1015 DEFUN ("point-max-marker", Fpoint_max_marker
, Spoint_max_marker
, 0, 0, 0,
1016 doc
: /* Return a marker to the maximum permissible value of point in this buffer.
1017 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1018 is in effect, in which case it is less. */)
1021 return build_marker (current_buffer
, ZV
, ZV_BYTE
);
1024 DEFUN ("gap-position", Fgap_position
, Sgap_position
, 0, 0, 0,
1025 doc
: /* Return the position of the gap, in the current buffer.
1026 See also `gap-size'. */)
1030 XSETFASTINT (temp
, GPT
);
1034 DEFUN ("gap-size", Fgap_size
, Sgap_size
, 0, 0, 0,
1035 doc
: /* Return the size of the current buffer's gap.
1036 See also `gap-position'. */)
1040 XSETFASTINT (temp
, GAP_SIZE
);
1044 DEFUN ("position-bytes", Fposition_bytes
, Sposition_bytes
, 1, 1, 0,
1045 doc
: /* Return the byte position for character position POSITION.
1046 If POSITION is out of range, the value is nil. */)
1047 (Lisp_Object position
)
1049 CHECK_NUMBER_COERCE_MARKER (position
);
1050 if (XINT (position
) < BEG
|| XINT (position
) > Z
)
1052 return make_number (CHAR_TO_BYTE (XINT (position
)));
1055 DEFUN ("byte-to-position", Fbyte_to_position
, Sbyte_to_position
, 1, 1, 0,
1056 doc
: /* Return the character position for byte position BYTEPOS.
1057 If BYTEPOS is out of range, the value is nil. */)
1058 (Lisp_Object bytepos
)
1060 CHECK_NUMBER (bytepos
);
1061 if (XINT (bytepos
) < BEG_BYTE
|| XINT (bytepos
) > Z_BYTE
)
1063 return make_number (BYTE_TO_CHAR (XINT (bytepos
)));
1066 DEFUN ("following-char", Ffollowing_char
, Sfollowing_char
, 0, 0, 0,
1067 doc
: /* Return the character following point, as a number.
1068 At the end of the buffer or accessible region, return 0. */)
1073 XSETFASTINT (temp
, 0);
1075 XSETFASTINT (temp
, FETCH_CHAR (PT_BYTE
));
1079 DEFUN ("preceding-char", Fprevious_char
, Sprevious_char
, 0, 0, 0,
1080 doc
: /* Return the character preceding point, as a number.
1081 At the beginning of the buffer or accessible region, return 0. */)
1086 XSETFASTINT (temp
, 0);
1087 else if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
1089 ptrdiff_t pos
= PT_BYTE
;
1091 XSETFASTINT (temp
, FETCH_CHAR (pos
));
1094 XSETFASTINT (temp
, FETCH_BYTE (PT_BYTE
- 1));
1098 DEFUN ("bobp", Fbobp
, Sbobp
, 0, 0, 0,
1099 doc
: /* Return t if point is at the beginning of the buffer.
1100 If the buffer is narrowed, this means the beginning of the narrowed part. */)
1108 DEFUN ("eobp", Feobp
, Seobp
, 0, 0, 0,
1109 doc
: /* Return t if point is at the end of the buffer.
1110 If the buffer is narrowed, this means the end of the narrowed part. */)
1118 DEFUN ("bolp", Fbolp
, Sbolp
, 0, 0, 0,
1119 doc
: /* Return t if point is at the beginning of a line. */)
1122 if (PT
== BEGV
|| FETCH_BYTE (PT_BYTE
- 1) == '\n')
1127 DEFUN ("eolp", Feolp
, Seolp
, 0, 0, 0,
1128 doc
: /* Return t if point is at the end of a line.
1129 `End of a line' includes point being at the end of the buffer. */)
1132 if (PT
== ZV
|| FETCH_BYTE (PT_BYTE
) == '\n')
1137 DEFUN ("char-after", Fchar_after
, Schar_after
, 0, 1, 0,
1138 doc
: /* Return character in current buffer at position POS.
1139 POS is an integer or a marker and defaults to point.
1140 If POS is out of range, the value is nil. */)
1143 register ptrdiff_t pos_byte
;
1148 XSETFASTINT (pos
, PT
);
1153 pos_byte
= marker_byte_position (pos
);
1154 if (pos_byte
< BEGV_BYTE
|| pos_byte
>= ZV_BYTE
)
1159 CHECK_NUMBER_COERCE_MARKER (pos
);
1160 if (XINT (pos
) < BEGV
|| XINT (pos
) >= ZV
)
1163 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1166 return make_number (FETCH_CHAR (pos_byte
));
1169 DEFUN ("char-before", Fchar_before
, Schar_before
, 0, 1, 0,
1170 doc
: /* Return character in current buffer preceding position POS.
1171 POS is an integer or a marker and defaults to point.
1172 If POS is out of range, the value is nil. */)
1175 register Lisp_Object val
;
1176 register ptrdiff_t pos_byte
;
1181 XSETFASTINT (pos
, PT
);
1186 pos_byte
= marker_byte_position (pos
);
1188 if (pos_byte
<= BEGV_BYTE
|| pos_byte
> ZV_BYTE
)
1193 CHECK_NUMBER_COERCE_MARKER (pos
);
1195 if (XINT (pos
) <= BEGV
|| XINT (pos
) > ZV
)
1198 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1201 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
1204 XSETFASTINT (val
, FETCH_CHAR (pos_byte
));
1209 XSETFASTINT (val
, FETCH_BYTE (pos_byte
));
1214 DEFUN ("user-login-name", Fuser_login_name
, Suser_login_name
, 0, 1, 0,
1215 doc
: /* Return the name under which the user logged in, as a string.
1216 This is based on the effective uid, not the real uid.
1217 Also, if the environment variables LOGNAME or USER are set,
1218 that determines the value of this function.
1220 If optional argument UID is an integer or a float, return the login name
1221 of the user with that uid, or nil if there is no such user. */)
1227 /* Set up the user name info if we didn't do it before.
1228 (That can happen if Emacs is dumpable
1229 but you decide to run `temacs -l loadup' and not dump. */
1230 if (INTEGERP (Vuser_login_name
))
1234 return Vuser_login_name
;
1236 CONS_TO_INTEGER (uid
, uid_t
, id
);
1240 return (pw
? build_string (pw
->pw_name
) : Qnil
);
1243 DEFUN ("user-real-login-name", Fuser_real_login_name
, Suser_real_login_name
,
1245 doc
: /* Return the name of the user's real uid, as a string.
1246 This ignores the environment variables LOGNAME and USER, so it differs from
1247 `user-login-name' when running under `su'. */)
1250 /* Set up the user name info if we didn't do it before.
1251 (That can happen if Emacs is dumpable
1252 but you decide to run `temacs -l loadup' and not dump. */
1253 if (INTEGERP (Vuser_login_name
))
1255 return Vuser_real_login_name
;
1258 DEFUN ("user-uid", Fuser_uid
, Suser_uid
, 0, 0, 0,
1259 doc
: /* Return the effective uid of Emacs.
1260 Value is an integer or a float, depending on the value. */)
1263 uid_t euid
= geteuid ();
1264 return make_fixnum_or_float (euid
);
1267 DEFUN ("user-real-uid", Fuser_real_uid
, Suser_real_uid
, 0, 0, 0,
1268 doc
: /* Return the real uid of Emacs.
1269 Value is an integer or a float, depending on the value. */)
1272 uid_t uid
= getuid ();
1273 return make_fixnum_or_float (uid
);
1276 DEFUN ("group-gid", Fgroup_gid
, Sgroup_gid
, 0, 0, 0,
1277 doc
: /* Return the effective gid of Emacs.
1278 Value is an integer or a float, depending on the value. */)
1281 gid_t egid
= getegid ();
1282 return make_fixnum_or_float (egid
);
1285 DEFUN ("group-real-gid", Fgroup_real_gid
, Sgroup_real_gid
, 0, 0, 0,
1286 doc
: /* Return the real gid of Emacs.
1287 Value is an integer or a float, depending on the value. */)
1290 gid_t gid
= getgid ();
1291 return make_fixnum_or_float (gid
);
1294 DEFUN ("user-full-name", Fuser_full_name
, Suser_full_name
, 0, 1, 0,
1295 doc
: /* Return the full name of the user logged in, as a string.
1296 If the full name corresponding to Emacs's userid is not known,
1299 If optional argument UID is an integer or float, return the full name
1300 of the user with that uid, or nil if there is no such user.
1301 If UID is a string, return the full name of the user with that login
1302 name, or nil if there is no such user. */)
1306 register char *p
, *q
;
1310 return Vuser_full_name
;
1311 else if (NUMBERP (uid
))
1314 CONS_TO_INTEGER (uid
, uid_t
, u
);
1319 else if (STRINGP (uid
))
1322 pw
= getpwnam (SSDATA (uid
));
1326 error ("Invalid UID specification");
1332 /* Chop off everything after the first comma. */
1333 q
= strchr (p
, ',');
1334 full
= make_string (p
, q
? q
- p
: strlen (p
));
1336 #ifdef AMPERSAND_FULL_NAME
1338 q
= strchr (p
, '&');
1339 /* Substitute the login name for the &, upcasing the first character. */
1345 login
= Fuser_login_name (make_number (pw
->pw_uid
));
1346 r
= alloca (strlen (p
) + SCHARS (login
) + 1);
1347 memcpy (r
, p
, q
- p
);
1349 strcat (r
, SSDATA (login
));
1350 r
[q
- p
] = upcase ((unsigned char) r
[q
- p
]);
1352 full
= build_string (r
);
1354 #endif /* AMPERSAND_FULL_NAME */
1359 DEFUN ("system-name", Fsystem_name
, Ssystem_name
, 0, 0, 0,
1360 doc
: /* Return the host name of the machine you are running on, as a string. */)
1363 return Vsystem_name
;
1366 DEFUN ("emacs-pid", Femacs_pid
, Semacs_pid
, 0, 0, 0,
1367 doc
: /* Return the process ID of Emacs, as a number. */)
1370 pid_t pid
= getpid ();
1371 return make_fixnum_or_float (pid
);
1377 # define TIME_T_MIN TYPE_MINIMUM (time_t)
1380 # define TIME_T_MAX TYPE_MAXIMUM (time_t)
1383 /* Report that a time value is out of range for Emacs. */
1385 time_overflow (void)
1387 error ("Specified time is not representable");
1390 /* Return the upper part of the time T (everything but the bottom 16 bits). */
1394 time_t hi
= t
>> 16;
1396 /* Check for overflow, helping the compiler for common cases where
1397 no runtime check is needed, and taking care not to convert
1398 negative numbers to unsigned before comparing them. */
1399 if (! ((! TYPE_SIGNED (time_t)
1400 || MOST_NEGATIVE_FIXNUM
<= TIME_T_MIN
>> 16
1401 || MOST_NEGATIVE_FIXNUM
<= hi
)
1402 && (TIME_T_MAX
>> 16 <= MOST_POSITIVE_FIXNUM
1403 || hi
<= MOST_POSITIVE_FIXNUM
)))
1409 /* Return the bottom 16 bits of the time T. */
1413 return t
& ((1 << 16) - 1);
1416 DEFUN ("current-time", Fcurrent_time
, Scurrent_time
, 0, 0, 0,
1417 doc
: /* Return the current time, as the number of seconds since 1970-01-01 00:00:00.
1418 The time is returned as a list of integers (HIGH LOW USEC PSEC).
1419 HIGH has the most significant bits of the seconds, while LOW has the
1420 least significant 16 bits. USEC and PSEC are the microsecond and
1421 picosecond counts. */)
1424 return make_lisp_time (current_emacs_time ());
1427 DEFUN ("get-internal-run-time", Fget_internal_run_time
, Sget_internal_run_time
,
1429 doc
: /* Return the current run time used by Emacs.
1430 The time is returned as a list (HIGH LOW USEC PSEC), using the same
1431 style as (current-time).
1433 On systems that can't determine the run time, `get-internal-run-time'
1434 does the same thing as `current-time'. */)
1437 #ifdef HAVE_GETRUSAGE
1438 struct rusage usage
;
1442 if (getrusage (RUSAGE_SELF
, &usage
) < 0)
1443 /* This shouldn't happen. What action is appropriate? */
1446 /* Sum up user time and system time. */
1447 secs
= usage
.ru_utime
.tv_sec
+ usage
.ru_stime
.tv_sec
;
1448 usecs
= usage
.ru_utime
.tv_usec
+ usage
.ru_stime
.tv_usec
;
1449 if (usecs
>= 1000000)
1454 return make_lisp_time (make_emacs_time (secs
, usecs
* 1000));
1455 #else /* ! HAVE_GETRUSAGE */
1457 return w32_get_internal_run_time ();
1458 #else /* ! WINDOWSNT */
1459 return Fcurrent_time ();
1460 #endif /* WINDOWSNT */
1461 #endif /* HAVE_GETRUSAGE */
1465 /* Make a Lisp list that represents the time T with fraction TAIL. */
1467 make_time_tail (time_t t
, Lisp_Object tail
)
1469 return Fcons (make_number (hi_time (t
)),
1470 Fcons (make_number (lo_time (t
)), tail
));
1473 /* Make a Lisp list that represents the system time T. */
1475 make_time (time_t t
)
1477 return make_time_tail (t
, Qnil
);
1480 /* Make a Lisp list that represents the Emacs time T. T may be an
1481 invalid time, with a slightly negative tv_nsec value such as
1482 UNKNOWN_MODTIME_NSECS; in that case, the Lisp list contains a
1483 correspondingly negative picosecond count. */
1485 make_lisp_time (EMACS_TIME t
)
1487 int ns
= EMACS_NSECS (t
);
1488 return make_time_tail (EMACS_SECS (t
),
1489 list2 (make_number (ns
/ 1000),
1490 make_number (ns
% 1000 * 1000)));
1493 /* Decode a Lisp list SPECIFIED_TIME that represents a time.
1494 Set *PHIGH, *PLOW, *PUSEC, *PPSEC to its parts; do not check their values.
1495 Return true if successful. */
1497 disassemble_lisp_time (Lisp_Object specified_time
, Lisp_Object
*phigh
,
1498 Lisp_Object
*plow
, Lisp_Object
*pusec
,
1501 if (CONSP (specified_time
))
1503 Lisp_Object low
= XCDR (specified_time
);
1504 Lisp_Object usec
= make_number (0);
1505 Lisp_Object psec
= make_number (0);
1508 Lisp_Object low_tail
= XCDR (low
);
1510 if (CONSP (low_tail
))
1512 usec
= XCAR (low_tail
);
1513 low_tail
= XCDR (low_tail
);
1514 if (CONSP (low_tail
))
1515 psec
= XCAR (low_tail
);
1517 else if (!NILP (low_tail
))
1521 *phigh
= XCAR (specified_time
);
1531 /* From the time components HIGH, LOW, USEC and PSEC taken from a Lisp
1532 list, generate the corresponding time value.
1534 If RESULT is not null, store into *RESULT the converted time;
1535 this can fail if the converted time does not fit into EMACS_TIME.
1536 If *DRESULT is not null, store into *DRESULT the number of
1537 seconds since the start of the POSIX Epoch.
1539 Return true if successful. */
1541 decode_time_components (Lisp_Object high
, Lisp_Object low
, Lisp_Object usec
,
1543 EMACS_TIME
*result
, double *dresult
)
1545 EMACS_INT hi
, lo
, us
, ps
;
1546 if (! (INTEGERP (high
) && INTEGERP (low
)
1547 && INTEGERP (usec
) && INTEGERP (psec
)))
1554 /* Normalize out-of-range lower-order components by carrying
1555 each overflow into the next higher-order component. */
1556 us
+= ps
/ 1000000 - (ps
% 1000000 < 0);
1557 lo
+= us
/ 1000000 - (us
% 1000000 < 0);
1559 ps
= ps
% 1000000 + 1000000 * (ps
% 1000000 < 0);
1560 us
= us
% 1000000 + 1000000 * (us
% 1000000 < 0);
1561 lo
&= (1 << 16) - 1;
1565 if ((TYPE_SIGNED (time_t) ? TIME_T_MIN
>> 16 <= hi
: 0 <= hi
)
1566 && hi
<= TIME_T_MAX
>> 16)
1568 /* Return the greatest representable time that is not greater
1569 than the requested time. */
1571 *result
= make_emacs_time ((sec
<< 16) + lo
, us
* 1000 + ps
/ 1000);
1575 /* Overflow in the highest-order component. */
1581 *dresult
= (us
* 1e6
+ ps
) / 1e12
+ lo
+ hi
* 65536.0;
1586 /* Decode a Lisp list SPECIFIED_TIME that represents a time.
1587 If SPECIFIED_TIME is nil, use the current time.
1589 Round the time down to the nearest EMACS_TIME value.
1590 Return seconds since the Epoch.
1591 Signal an error if unsuccessful. */
1593 lisp_time_argument (Lisp_Object specified_time
)
1596 if (NILP (specified_time
))
1597 t
= current_emacs_time ();
1600 Lisp_Object high
, low
, usec
, psec
;
1601 if (! (disassemble_lisp_time (specified_time
, &high
, &low
, &usec
, &psec
)
1602 && decode_time_components (high
, low
, usec
, psec
, &t
, 0)))
1603 error ("Invalid time specification");
1608 /* Like lisp_time_argument, except decode only the seconds part,
1609 do not allow out-of-range time stamps, do not check the subseconds part,
1610 and always round down. */
1612 lisp_seconds_argument (Lisp_Object specified_time
)
1614 if (NILP (specified_time
))
1618 Lisp_Object high
, low
, usec
, psec
;
1620 if (! (disassemble_lisp_time (specified_time
, &high
, &low
, &usec
, &psec
)
1621 && decode_time_components (high
, low
, make_number (0),
1622 make_number (0), &t
, 0)))
1623 error ("Invalid time specification");
1624 return EMACS_SECS (t
);
1628 DEFUN ("float-time", Ffloat_time
, Sfloat_time
, 0, 1, 0,
1629 doc
: /* Return the current time, as a float number of seconds since the epoch.
1630 If SPECIFIED-TIME is given, it is the time to convert to float
1631 instead of the current time. The argument should have the form
1632 (HIGH LOW) or (HIGH LOW USEC) or (HIGH LOW USEC PSEC). Thus,
1633 you can use times from `current-time' and from `file-attributes'.
1634 SPECIFIED-TIME can also have the form (HIGH . LOW), but this is
1635 considered obsolete.
1637 WARNING: Since the result is floating point, it may not be exact.
1638 If precise time stamps are required, use either `current-time',
1639 or (if you need time as a string) `format-time-string'. */)
1640 (Lisp_Object specified_time
)
1643 if (NILP (specified_time
))
1645 EMACS_TIME now
= current_emacs_time ();
1646 t
= EMACS_SECS (now
) + EMACS_NSECS (now
) / 1e9
;
1650 Lisp_Object high
, low
, usec
, psec
;
1651 if (! (disassemble_lisp_time (specified_time
, &high
, &low
, &usec
, &psec
)
1652 && decode_time_components (high
, low
, usec
, psec
, 0, &t
)))
1653 error ("Invalid time specification");
1655 return make_float (t
);
1658 /* Write information into buffer S of size MAXSIZE, according to the
1659 FORMAT of length FORMAT_LEN, using time information taken from *TP.
1660 Default to Universal Time if UT, local time otherwise.
1661 Use NS as the number of nanoseconds in the %N directive.
1662 Return the number of bytes written, not including the terminating
1663 '\0'. If S is NULL, nothing will be written anywhere; so to
1664 determine how many bytes would be written, use NULL for S and
1665 ((size_t) -1) for MAXSIZE.
1667 This function behaves like nstrftime, except it allows null
1668 bytes in FORMAT and it does not support nanoseconds. */
1670 emacs_nmemftime (char *s
, size_t maxsize
, const char *format
,
1671 size_t format_len
, const struct tm
*tp
, bool ut
, int ns
)
1675 /* Loop through all the null-terminated strings in the format
1676 argument. Normally there's just one null-terminated string, but
1677 there can be arbitrarily many, concatenated together, if the
1678 format contains '\0' bytes. nstrftime stops at the first
1679 '\0' byte so we must invoke it separately for each such string. */
1688 result
= nstrftime (s
, maxsize
, format
, tp
, ut
, ns
);
1692 if (result
== 0 && s
[0] != '\0')
1697 maxsize
-= result
+ 1;
1699 len
= strlen (format
);
1700 if (len
== format_len
)
1704 format_len
-= len
+ 1;
1708 DEFUN ("format-time-string", Fformat_time_string
, Sformat_time_string
, 1, 3, 0,
1709 doc
: /* Use FORMAT-STRING to format the time TIME, or now if omitted.
1710 TIME is specified as (HIGH LOW USEC PSEC), as returned by
1711 `current-time' or `file-attributes'. The obsolete form (HIGH . LOW)
1712 is also still accepted.
1713 The third, optional, argument UNIVERSAL, if non-nil, means describe TIME
1714 as Universal Time; nil means describe TIME in the local time zone.
1715 The value is a copy of FORMAT-STRING, but with certain constructs replaced
1716 by text that describes the specified date and time in TIME:
1718 %Y is the year, %y within the century, %C the century.
1719 %G is the year corresponding to the ISO week, %g within the century.
1720 %m is the numeric month.
1721 %b and %h are the locale's abbreviated month name, %B the full name.
1722 %d is the day of the month, zero-padded, %e is blank-padded.
1723 %u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.
1724 %a is the locale's abbreviated name of the day of week, %A the full name.
1725 %U is the week number starting on Sunday, %W starting on Monday,
1726 %V according to ISO 8601.
1727 %j is the day of the year.
1729 %H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H
1730 only blank-padded, %l is like %I blank-padded.
1731 %p is the locale's equivalent of either AM or PM.
1734 %N is the nanosecond, %6N the microsecond, %3N the millisecond, etc.
1735 %Z is the time zone name, %z is the numeric form.
1736 %s is the number of seconds since 1970-01-01 00:00:00 +0000.
1738 %c is the locale's date and time format.
1739 %x is the locale's "preferred" date format.
1740 %D is like "%m/%d/%y".
1742 %R is like "%H:%M", %T is like "%H:%M:%S", %r is like "%I:%M:%S %p".
1743 %X is the locale's "preferred" time format.
1745 Finally, %n is a newline, %t is a tab, %% is a literal %.
1747 Certain flags and modifiers are available with some format controls.
1748 The flags are `_', `-', `^' and `#'. For certain characters X,
1749 %_X is like %X, but padded with blanks; %-X is like %X,
1750 but without padding. %^X is like %X, but with all textual
1751 characters up-cased; %#X is like %X, but with letter-case of
1752 all textual characters reversed.
1753 %NX (where N stands for an integer) is like %X,
1754 but takes up at least N (a number) positions.
1755 The modifiers are `E' and `O'. For certain characters X,
1756 %EX is a locale's alternative version of %X;
1757 %OX is like %X, but uses the locale's number symbols.
1759 For example, to produce full ISO 8601 format, use "%Y-%m-%dT%T%z".
1761 usage: (format-time-string FORMAT-STRING &optional TIME UNIVERSAL) */)
1762 (Lisp_Object format_string
, Lisp_Object timeval
, Lisp_Object universal
)
1764 EMACS_TIME t
= lisp_time_argument (timeval
);
1767 CHECK_STRING (format_string
);
1768 format_string
= code_convert_string_norecord (format_string
,
1769 Vlocale_coding_system
, 1);
1770 return format_time_string (SSDATA (format_string
), SBYTES (format_string
),
1771 t
, ! NILP (universal
), &tm
);
1775 format_time_string (char const *format
, ptrdiff_t formatlen
,
1776 EMACS_TIME t
, bool ut
, struct tm
*tmp
)
1780 ptrdiff_t size
= sizeof buffer
;
1782 Lisp_Object bufstring
;
1783 int ns
= EMACS_NSECS (t
);
1789 time_t *taddr
= emacs_secs_addr (&t
);
1792 synchronize_system_time_locale ();
1794 tm
= ut
? gmtime (taddr
) : localtime (taddr
);
1803 len
= emacs_nmemftime (buf
, size
, format
, formatlen
, tm
, ut
, ns
);
1804 if ((0 < len
&& len
< size
) || (len
== 0 && buf
[0] == '\0'))
1807 /* Buffer was too small, so make it bigger and try again. */
1808 len
= emacs_nmemftime (NULL
, SIZE_MAX
, format
, formatlen
, tm
, ut
, ns
);
1810 if (STRING_BYTES_BOUND
<= len
)
1813 buf
= SAFE_ALLOCA (size
);
1817 bufstring
= make_unibyte_string (buf
, len
);
1819 return code_convert_string_norecord (bufstring
, Vlocale_coding_system
, 0);
1822 DEFUN ("decode-time", Fdecode_time
, Sdecode_time
, 0, 1, 0,
1823 doc
: /* Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST ZONE).
1824 The optional SPECIFIED-TIME should be a list of (HIGH LOW . IGNORED),
1825 as from `current-time' and `file-attributes', or nil to use the
1826 current time. The obsolete form (HIGH . LOW) is also still accepted.
1827 The list has the following nine members: SEC is an integer between 0
1828 and 60; SEC is 60 for a leap second, which only some operating systems
1829 support. MINUTE is an integer between 0 and 59. HOUR is an integer
1830 between 0 and 23. DAY is an integer between 1 and 31. MONTH is an
1831 integer between 1 and 12. YEAR is an integer indicating the
1832 four-digit year. DOW is the day of week, an integer between 0 and 6,
1833 where 0 is Sunday. DST is t if daylight saving time is in effect,
1834 otherwise nil. ZONE is an integer indicating the number of seconds
1835 east of Greenwich. (Note that Common Lisp has different meanings for
1837 (Lisp_Object specified_time
)
1839 time_t time_spec
= lisp_seconds_argument (specified_time
);
1841 struct tm
*decoded_time
;
1842 Lisp_Object list_args
[9];
1845 decoded_time
= localtime (&time_spec
);
1847 save_tm
= *decoded_time
;
1850 && MOST_NEGATIVE_FIXNUM
- TM_YEAR_BASE
<= save_tm
.tm_year
1851 && save_tm
.tm_year
<= MOST_POSITIVE_FIXNUM
- TM_YEAR_BASE
))
1853 XSETFASTINT (list_args
[0], save_tm
.tm_sec
);
1854 XSETFASTINT (list_args
[1], save_tm
.tm_min
);
1855 XSETFASTINT (list_args
[2], save_tm
.tm_hour
);
1856 XSETFASTINT (list_args
[3], save_tm
.tm_mday
);
1857 XSETFASTINT (list_args
[4], save_tm
.tm_mon
+ 1);
1858 /* On 64-bit machines an int is narrower than EMACS_INT, thus the
1859 cast below avoids overflow in int arithmetics. */
1860 XSETINT (list_args
[5], TM_YEAR_BASE
+ (EMACS_INT
) save_tm
.tm_year
);
1861 XSETFASTINT (list_args
[6], save_tm
.tm_wday
);
1862 list_args
[7] = save_tm
.tm_isdst
? Qt
: Qnil
;
1865 decoded_time
= gmtime (&time_spec
);
1866 if (decoded_time
== 0)
1867 list_args
[8] = Qnil
;
1869 XSETINT (list_args
[8], tm_diff (&save_tm
, decoded_time
));
1871 return Flist (9, list_args
);
1874 /* Return OBJ - OFFSET, checking that OBJ is a valid fixnum and that
1875 the result is representable as an int. Assume OFFSET is small and
1878 check_tm_member (Lisp_Object obj
, int offset
)
1883 if (! (INT_MIN
+ offset
<= n
&& n
- offset
<= INT_MAX
))
1888 DEFUN ("encode-time", Fencode_time
, Sencode_time
, 6, MANY
, 0,
1889 doc
: /* Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.
1890 This is the reverse operation of `decode-time', which see.
1891 ZONE defaults to the current time zone rule. This can
1892 be a string or t (as from `set-time-zone-rule'), or it can be a list
1893 \(as from `current-time-zone') or an integer (as from `decode-time')
1894 applied without consideration for daylight saving time.
1896 You can pass more than 7 arguments; then the first six arguments
1897 are used as SECOND through YEAR, and the *last* argument is used as ZONE.
1898 The intervening arguments are ignored.
1899 This feature lets (apply 'encode-time (decode-time ...)) work.
1901 Out-of-range values for SECOND, MINUTE, HOUR, DAY, or MONTH are allowed;
1902 for example, a DAY of 0 means the day preceding the given month.
1903 Year numbers less than 100 are treated just like other year numbers.
1904 If you want them to stand for years in this century, you must do that yourself.
1906 Years before 1970 are not guaranteed to work. On some systems,
1907 year values as low as 1901 do work.
1909 usage: (encode-time SECOND MINUTE HOUR DAY MONTH YEAR &optional ZONE) */)
1910 (ptrdiff_t nargs
, Lisp_Object
*args
)
1914 Lisp_Object zone
= (nargs
> 6 ? args
[nargs
- 1] : Qnil
);
1916 tm
.tm_sec
= check_tm_member (args
[0], 0);
1917 tm
.tm_min
= check_tm_member (args
[1], 0);
1918 tm
.tm_hour
= check_tm_member (args
[2], 0);
1919 tm
.tm_mday
= check_tm_member (args
[3], 0);
1920 tm
.tm_mon
= check_tm_member (args
[4], 1);
1921 tm
.tm_year
= check_tm_member (args
[5], TM_YEAR_BASE
);
1929 value
= mktime (&tm
);
1934 static char const tzbuf_format
[] = "XXX%s%"pI
"d:%02d:%02d";
1935 char tzbuf
[sizeof tzbuf_format
+ INT_STRLEN_BOUND (EMACS_INT
)];
1937 const char *tzstring
;
1942 else if (STRINGP (zone
))
1943 tzstring
= SSDATA (zone
);
1944 else if (INTEGERP (zone
))
1946 EMACS_INT abszone
= eabs (XINT (zone
));
1947 EMACS_INT zone_hr
= abszone
/ (60*60);
1948 int zone_min
= (abszone
/60) % 60;
1949 int zone_sec
= abszone
% 60;
1950 sprintf (tzbuf
, tzbuf_format
, "-" + (XINT (zone
) < 0),
1951 zone_hr
, zone_min
, zone_sec
);
1955 error ("Invalid time zone specification");
1957 old_tzstring
= getenv ("TZ");
1960 char *buf
= SAFE_ALLOCA (strlen (old_tzstring
) + 1);
1961 old_tzstring
= strcpy (buf
, old_tzstring
);
1966 /* Set TZ before calling mktime; merely adjusting mktime's returned
1967 value doesn't suffice, since that would mishandle leap seconds. */
1968 set_time_zone_rule (tzstring
);
1970 value
= mktime (&tm
);
1972 set_time_zone_rule (old_tzstring
);
1973 #ifdef LOCALTIME_CACHE
1980 if (value
== (time_t) -1)
1983 return make_time (value
);
1986 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
, 0, 1, 0,
1987 doc
: /* Return the current local time, as a human-readable string.
1988 Programs can use this function to decode a time,
1989 since the number of columns in each field is fixed
1990 if the year is in the range 1000-9999.
1991 The format is `Sun Sep 16 01:03:52 1973'.
1992 However, see also the functions `decode-time' and `format-time-string'
1993 which provide a much more powerful and general facility.
1995 If SPECIFIED-TIME is given, it is a time to format instead of the
1996 current time. The argument should have the form (HIGH LOW . IGNORED).
1997 Thus, you can use times obtained from `current-time' and from
1998 `file-attributes'. SPECIFIED-TIME can also have the form (HIGH . LOW),
1999 but this is considered obsolete. */)
2000 (Lisp_Object specified_time
)
2002 time_t value
= lisp_seconds_argument (specified_time
);
2004 char buf
[sizeof "Mon Apr 30 12:49:17 " + INT_STRLEN_BOUND (int) + 1];
2005 int len
IF_LINT (= 0);
2007 /* Convert to a string in ctime format, except without the trailing
2008 newline, and without the 4-digit year limit. Don't use asctime
2009 or ctime, as they might dump core if the year is outside the
2010 range -999 .. 9999. */
2012 tm
= localtime (&value
);
2015 static char const wday_name
[][4] =
2016 { "Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat" };
2017 static char const mon_name
[][4] =
2018 { "Jan", "Feb", "Mar", "Apr", "May", "Jun",
2019 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" };
2020 printmax_t year_base
= TM_YEAR_BASE
;
2022 len
= sprintf (buf
, "%s %s%3d %02d:%02d:%02d %"pMd
,
2023 wday_name
[tm
->tm_wday
], mon_name
[tm
->tm_mon
], tm
->tm_mday
,
2024 tm
->tm_hour
, tm
->tm_min
, tm
->tm_sec
,
2025 tm
->tm_year
+ year_base
);
2031 return make_unibyte_string (buf
, len
);
2034 /* Yield A - B, measured in seconds.
2035 This function is copied from the GNU C Library. */
2037 tm_diff (struct tm
*a
, struct tm
*b
)
2039 /* Compute intervening leap days correctly even if year is negative.
2040 Take care to avoid int overflow in leap day calculations,
2041 but it's OK to assume that A and B are close to each other. */
2042 int a4
= (a
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (a
->tm_year
& 3);
2043 int b4
= (b
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (b
->tm_year
& 3);
2044 int a100
= a4
/ 25 - (a4
% 25 < 0);
2045 int b100
= b4
/ 25 - (b4
% 25 < 0);
2046 int a400
= a100
>> 2;
2047 int b400
= b100
>> 2;
2048 int intervening_leap_days
= (a4
- b4
) - (a100
- b100
) + (a400
- b400
);
2049 int years
= a
->tm_year
- b
->tm_year
;
2050 int days
= (365 * years
+ intervening_leap_days
2051 + (a
->tm_yday
- b
->tm_yday
));
2052 return (60 * (60 * (24 * days
+ (a
->tm_hour
- b
->tm_hour
))
2053 + (a
->tm_min
- b
->tm_min
))
2054 + (a
->tm_sec
- b
->tm_sec
));
2057 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 1, 0,
2058 doc
: /* Return the offset and name for the local time zone.
2059 This returns a list of the form (OFFSET NAME).
2060 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).
2061 A negative value means west of Greenwich.
2062 NAME is a string giving the name of the time zone.
2063 If SPECIFIED-TIME is given, the time zone offset is determined from it
2064 instead of using the current time. The argument should have the form
2065 (HIGH LOW . IGNORED). Thus, you can use times obtained from
2066 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
2067 have the form (HIGH . LOW), but this is considered obsolete.
2069 Some operating systems cannot provide all this information to Emacs;
2070 in this case, `current-time-zone' returns a list containing nil for
2071 the data it can't find. */)
2072 (Lisp_Object specified_time
)
2078 Lisp_Object zone_offset
, zone_name
;
2081 value
= make_emacs_time (lisp_seconds_argument (specified_time
), 0);
2082 zone_name
= format_time_string ("%Z", sizeof "%Z" - 1, value
, 0, &localtm
);
2084 t
= gmtime (emacs_secs_addr (&value
));
2086 offset
= tm_diff (&localtm
, t
);
2091 zone_offset
= make_number (offset
);
2092 if (SCHARS (zone_name
) == 0)
2094 /* No local time zone name is available; use "+-NNNN" instead. */
2095 int m
= offset
/ 60;
2096 int am
= offset
< 0 ? - m
: m
;
2097 char buf
[sizeof "+00" + INT_STRLEN_BOUND (int)];
2098 zone_name
= make_formatted_string (buf
, "%c%02d%02d",
2099 (offset
< 0 ? '-' : '+'),
2104 return list2 (zone_offset
, zone_name
);
2107 DEFUN ("set-time-zone-rule", Fset_time_zone_rule
, Sset_time_zone_rule
, 1, 1, 0,
2108 doc
: /* Set the local time zone using TZ, a string specifying a time zone rule.
2109 If TZ is nil, use implementation-defined default time zone information.
2110 If TZ is t, use Universal Time.
2112 Instead of calling this function, you typically want (setenv "TZ" TZ).
2113 That changes both the environment of the Emacs process and the
2114 variable `process-environment', whereas `set-time-zone-rule' affects
2115 only the former. */)
2118 const char *tzstring
;
2120 if (! (NILP (tz
) || EQ (tz
, Qt
)))
2124 tzstring
= initial_tz
;
2125 else if (EQ (tz
, Qt
))
2128 tzstring
= SSDATA (tz
);
2131 set_time_zone_rule (tzstring
);
2137 /* Set the local time zone rule to TZSTRING.
2139 This function is not thread-safe, partly because putenv, unsetenv
2140 and tzset are not, and partly because of the static storage it
2141 updates. Other threads that invoke localtime etc. may be adversely
2142 affected while this function is executing. */
2145 set_time_zone_rule (const char *tzstring
)
2147 /* A buffer holding a string of the form "TZ=value", intended
2148 to be part of the environment. */
2149 static char *tzvalbuf
;
2150 static ptrdiff_t tzvalbufsize
;
2152 int tzeqlen
= sizeof "TZ=" - 1;
2154 #ifdef LOCALTIME_CACHE
2155 /* These two values are known to load tz files in buggy implementations,
2156 i.e., Solaris 1 executables running under either Solaris 1 or Solaris 2.
2157 Their values shouldn't matter in non-buggy implementations.
2158 We don't use string literals for these strings,
2159 since if a string in the environment is in readonly
2160 storage, it runs afoul of bugs in SVR4 and Solaris 2.3.
2161 See Sun bugs 1113095 and 1114114, ``Timezone routines
2162 improperly modify environment''. */
2164 static char set_time_zone_rule_tz
[][sizeof "TZ=GMT+0"]
2165 = { "TZ=GMT+0", "TZ=GMT+1" };
2167 /* In SunOS 4.1.3_U1 and 4.1.4, if TZ has a value like
2168 "US/Pacific" that loads a tz file, then changes to a value like
2169 "XXX0" that does not load a tz file, and then changes back to
2170 its original value, the last change is (incorrectly) ignored.
2171 Also, if TZ changes twice in succession to values that do
2172 not load a tz file, tzset can dump core (see Sun bug#1225179).
2173 The following code works around these bugs. */
2177 /* Temporarily set TZ to a value that loads a tz file
2178 and that differs from tzstring. */
2179 bool eq0
= strcmp (tzstring
, set_time_zone_rule_tz
[0] + tzeqlen
) == 0;
2180 xputenv (set_time_zone_rule_tz
[eq0
]);
2184 /* The implied tzstring is unknown, so temporarily set TZ to
2185 two different values that each load a tz file. */
2186 xputenv (set_time_zone_rule_tz
[0]);
2188 xputenv (set_time_zone_rule_tz
[1]);
2196 tzvalbuf_in_environ
= 0;
2200 ptrdiff_t tzstringlen
= strlen (tzstring
);
2202 if (tzvalbufsize
<= tzeqlen
+ tzstringlen
)
2205 tzvalbuf_in_environ
= 0;
2206 tzvalbuf
= xpalloc (tzvalbuf
, &tzvalbufsize
,
2207 tzeqlen
+ tzstringlen
- tzvalbufsize
+ 1, -1, 1);
2208 memcpy (tzvalbuf
, "TZ=", tzeqlen
);
2211 strcpy (tzvalbuf
+ tzeqlen
, tzstring
);
2213 if (!tzvalbuf_in_environ
)
2216 tzvalbuf_in_environ
= 1;
2220 #ifdef LOCALTIME_CACHE
2225 /* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC
2226 (if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a
2227 type of object is Lisp_String). INHERIT is passed to
2228 INSERT_FROM_STRING_FUNC as the last argument. */
2231 general_insert_function (void (*insert_func
)
2232 (const char *, ptrdiff_t),
2233 void (*insert_from_string_func
)
2234 (Lisp_Object
, ptrdiff_t, ptrdiff_t,
2235 ptrdiff_t, ptrdiff_t, bool),
2236 bool inherit
, ptrdiff_t nargs
, Lisp_Object
*args
)
2241 for (argnum
= 0; argnum
< nargs
; argnum
++)
2244 if (CHARACTERP (val
))
2246 int c
= XFASTINT (val
);
2247 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2250 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2251 len
= CHAR_STRING (c
, str
);
2254 str
[0] = ASCII_CHAR_P (c
) ? c
: multibyte_char_to_unibyte (c
);
2257 (*insert_func
) ((char *) str
, len
);
2259 else if (STRINGP (val
))
2261 (*insert_from_string_func
) (val
, 0, 0,
2267 wrong_type_argument (Qchar_or_string_p
, val
);
2272 insert1 (Lisp_Object arg
)
2278 /* Callers passing one argument to Finsert need not gcpro the
2279 argument "array", since the only element of the array will
2280 not be used after calling insert or insert_from_string, so
2281 we don't care if it gets trashed. */
2283 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
2284 doc
: /* Insert the arguments, either strings or characters, at point.
2285 Point and before-insertion markers move forward to end up
2286 after the inserted text.
2287 Any other markers at the point of insertion remain before the text.
2289 If the current buffer is multibyte, unibyte strings are converted
2290 to multibyte for insertion (see `string-make-multibyte').
2291 If the current buffer is unibyte, multibyte strings are converted
2292 to unibyte for insertion (see `string-make-unibyte').
2294 When operating on binary data, it may be necessary to preserve the
2295 original bytes of a unibyte string when inserting it into a multibyte
2296 buffer; to accomplish this, apply `string-as-multibyte' to the string
2297 and insert the result.
2299 usage: (insert &rest ARGS) */)
2300 (ptrdiff_t nargs
, Lisp_Object
*args
)
2302 general_insert_function (insert
, insert_from_string
, 0, nargs
, args
);
2306 DEFUN ("insert-and-inherit", Finsert_and_inherit
, Sinsert_and_inherit
,
2308 doc
: /* Insert the arguments at point, inheriting properties from adjoining text.
2309 Point and before-insertion markers move forward to end up
2310 after the inserted text.
2311 Any other markers at the point of insertion remain before the text.
2313 If the current buffer is multibyte, unibyte strings are converted
2314 to multibyte for insertion (see `unibyte-char-to-multibyte').
2315 If the current buffer is unibyte, multibyte strings are converted
2316 to unibyte for insertion.
2318 usage: (insert-and-inherit &rest ARGS) */)
2319 (ptrdiff_t nargs
, Lisp_Object
*args
)
2321 general_insert_function (insert_and_inherit
, insert_from_string
, 1,
2326 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
2327 doc
: /* Insert strings or characters at point, relocating markers after the text.
2328 Point and markers move forward to end up after the inserted text.
2330 If the current buffer is multibyte, unibyte strings are converted
2331 to multibyte for insertion (see `unibyte-char-to-multibyte').
2332 If the current buffer is unibyte, multibyte strings are converted
2333 to unibyte for insertion.
2335 usage: (insert-before-markers &rest ARGS) */)
2336 (ptrdiff_t nargs
, Lisp_Object
*args
)
2338 general_insert_function (insert_before_markers
,
2339 insert_from_string_before_markers
, 0,
2344 DEFUN ("insert-before-markers-and-inherit", Finsert_and_inherit_before_markers
,
2345 Sinsert_and_inherit_before_markers
, 0, MANY
, 0,
2346 doc
: /* Insert text at point, relocating markers and inheriting properties.
2347 Point and markers move forward to end up after the inserted text.
2349 If the current buffer is multibyte, unibyte strings are converted
2350 to multibyte for insertion (see `unibyte-char-to-multibyte').
2351 If the current buffer is unibyte, multibyte strings are converted
2352 to unibyte for insertion.
2354 usage: (insert-before-markers-and-inherit &rest ARGS) */)
2355 (ptrdiff_t nargs
, Lisp_Object
*args
)
2357 general_insert_function (insert_before_markers_and_inherit
,
2358 insert_from_string_before_markers
, 1,
2363 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 1, 3,
2364 "(list (or (read-char-by-name \"Insert character (Unicode name or hex): \")\
2365 (error \"You did not specify a valid character\"))\
2366 (prefix-numeric-value current-prefix-arg)\
2368 doc
: /* Insert COUNT copies of CHARACTER.
2369 Interactively, prompt for CHARACTER. You can specify CHARACTER in one
2372 - As its Unicode character name, e.g. \"LATIN SMALL LETTER A\".
2373 Completion is available; if you type a substring of the name
2374 preceded by an asterisk `*', Emacs shows all names which include
2375 that substring, not necessarily at the beginning of the name.
2377 - As a hexadecimal code point, e.g. 263A. Note that code points in
2378 Emacs are equivalent to Unicode up to 10FFFF (which is the limit of
2379 the Unicode code space).
2381 - As a code point with a radix specified with #, e.g. #o21430
2382 (octal), #x2318 (hex), or #10r8984 (decimal).
2384 If called interactively, COUNT is given by the prefix argument. If
2385 omitted or nil, it defaults to 1.
2387 Inserting the character(s) relocates point and before-insertion
2388 markers in the same ways as the function `insert'.
2390 The optional third argument INHERIT, if non-nil, says to inherit text
2391 properties from adjoining text, if those properties are sticky. If
2392 called interactively, INHERIT is t. */)
2393 (Lisp_Object character
, Lisp_Object count
, Lisp_Object inherit
)
2396 register ptrdiff_t n
;
2398 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2401 CHECK_CHARACTER (character
);
2403 XSETFASTINT (count
, 1);
2404 CHECK_NUMBER (count
);
2405 c
= XFASTINT (character
);
2407 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2408 len
= CHAR_STRING (c
, str
);
2410 str
[0] = c
, len
= 1;
2411 if (XINT (count
) <= 0)
2413 if (BUF_BYTES_MAX
/ len
< XINT (count
))
2415 n
= XINT (count
) * len
;
2416 stringlen
= min (n
, sizeof string
- sizeof string
% len
);
2417 for (i
= 0; i
< stringlen
; i
++)
2418 string
[i
] = str
[i
% len
];
2419 while (n
> stringlen
)
2422 if (!NILP (inherit
))
2423 insert_and_inherit (string
, stringlen
);
2425 insert (string
, stringlen
);
2428 if (!NILP (inherit
))
2429 insert_and_inherit (string
, n
);
2435 DEFUN ("insert-byte", Finsert_byte
, Sinsert_byte
, 2, 3, 0,
2436 doc
: /* Insert COUNT (second arg) copies of BYTE (first arg).
2437 Both arguments are required.
2438 BYTE is a number of the range 0..255.
2440 If BYTE is 128..255 and the current buffer is multibyte, the
2441 corresponding eight-bit character is inserted.
2443 Point, and before-insertion markers, are relocated as in the function `insert'.
2444 The optional third arg INHERIT, if non-nil, says to inherit text properties
2445 from adjoining text, if those properties are sticky. */)
2446 (Lisp_Object byte
, Lisp_Object count
, Lisp_Object inherit
)
2448 CHECK_NUMBER (byte
);
2449 if (XINT (byte
) < 0 || XINT (byte
) > 255)
2450 args_out_of_range_3 (byte
, make_number (0), make_number (255));
2451 if (XINT (byte
) >= 128
2452 && ! NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2453 XSETFASTINT (byte
, BYTE8_TO_CHAR (XINT (byte
)));
2454 return Finsert_char (byte
, count
, inherit
);
2458 /* Making strings from buffer contents. */
2460 /* Return a Lisp_String containing the text of the current buffer from
2461 START to END. If text properties are in use and the current buffer
2462 has properties in the range specified, the resulting string will also
2463 have them, if PROPS is true.
2465 We don't want to use plain old make_string here, because it calls
2466 make_uninit_string, which can cause the buffer arena to be
2467 compacted. make_string has no way of knowing that the data has
2468 been moved, and thus copies the wrong data into the string. This
2469 doesn't effect most of the other users of make_string, so it should
2470 be left as is. But we should use this function when conjuring
2471 buffer substrings. */
2474 make_buffer_string (ptrdiff_t start
, ptrdiff_t end
, bool props
)
2476 ptrdiff_t start_byte
= CHAR_TO_BYTE (start
);
2477 ptrdiff_t end_byte
= CHAR_TO_BYTE (end
);
2479 return make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
);
2482 /* Return a Lisp_String containing the text of the current buffer from
2483 START / START_BYTE to END / END_BYTE.
2485 If text properties are in use and the current buffer
2486 has properties in the range specified, the resulting string will also
2487 have them, if PROPS is true.
2489 We don't want to use plain old make_string here, because it calls
2490 make_uninit_string, which can cause the buffer arena to be
2491 compacted. make_string has no way of knowing that the data has
2492 been moved, and thus copies the wrong data into the string. This
2493 doesn't effect most of the other users of make_string, so it should
2494 be left as is. But we should use this function when conjuring
2495 buffer substrings. */
2498 make_buffer_string_both (ptrdiff_t start
, ptrdiff_t start_byte
,
2499 ptrdiff_t end
, ptrdiff_t end_byte
, bool props
)
2501 Lisp_Object result
, tem
, tem1
;
2503 if (start
< GPT
&& GPT
< end
)
2506 if (! NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2507 result
= make_uninit_multibyte_string (end
- start
, end_byte
- start_byte
);
2509 result
= make_uninit_string (end
- start
);
2510 memcpy (SDATA (result
), BYTE_POS_ADDR (start_byte
), end_byte
- start_byte
);
2512 /* If desired, update and copy the text properties. */
2515 update_buffer_properties (start
, end
);
2517 tem
= Fnext_property_change (make_number (start
), Qnil
, make_number (end
));
2518 tem1
= Ftext_properties_at (make_number (start
), Qnil
);
2520 if (XINT (tem
) != end
|| !NILP (tem1
))
2521 copy_intervals_to_string (result
, current_buffer
, start
,
2528 /* Call Vbuffer_access_fontify_functions for the range START ... END
2529 in the current buffer, if necessary. */
2532 update_buffer_properties (ptrdiff_t start
, ptrdiff_t end
)
2534 /* If this buffer has some access functions,
2535 call them, specifying the range of the buffer being accessed. */
2536 if (!NILP (Vbuffer_access_fontify_functions
))
2538 Lisp_Object args
[3];
2541 args
[0] = Qbuffer_access_fontify_functions
;
2542 XSETINT (args
[1], start
);
2543 XSETINT (args
[2], end
);
2545 /* But don't call them if we can tell that the work
2546 has already been done. */
2547 if (!NILP (Vbuffer_access_fontified_property
))
2549 tem
= Ftext_property_any (args
[1], args
[2],
2550 Vbuffer_access_fontified_property
,
2553 Frun_hook_with_args (3, args
);
2556 Frun_hook_with_args (3, args
);
2560 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
2561 doc
: /* Return the contents of part of the current buffer as a string.
2562 The two arguments START and END are character positions;
2563 they can be in either order.
2564 The string returned is multibyte if the buffer is multibyte.
2566 This function copies the text properties of that part of the buffer
2567 into the result string; if you don't want the text properties,
2568 use `buffer-substring-no-properties' instead. */)
2569 (Lisp_Object start
, Lisp_Object end
)
2571 register ptrdiff_t b
, e
;
2573 validate_region (&start
, &end
);
2577 return make_buffer_string (b
, e
, 1);
2580 DEFUN ("buffer-substring-no-properties", Fbuffer_substring_no_properties
,
2581 Sbuffer_substring_no_properties
, 2, 2, 0,
2582 doc
: /* Return the characters of part of the buffer, without the text properties.
2583 The two arguments START and END are character positions;
2584 they can be in either order. */)
2585 (Lisp_Object start
, Lisp_Object end
)
2587 register ptrdiff_t b
, e
;
2589 validate_region (&start
, &end
);
2593 return make_buffer_string (b
, e
, 0);
2596 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
2597 doc
: /* Return the contents of the current buffer as a string.
2598 If narrowing is in effect, this function returns only the visible part
2602 return make_buffer_string (BEGV
, ZV
, 1);
2605 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
2607 doc
: /* Insert before point a substring of the contents of BUFFER.
2608 BUFFER may be a buffer or a buffer name.
2609 Arguments START and END are character positions specifying the substring.
2610 They default to the values of (point-min) and (point-max) in BUFFER. */)
2611 (Lisp_Object buffer
, Lisp_Object start
, Lisp_Object end
)
2613 register EMACS_INT b
, e
, temp
;
2614 register struct buffer
*bp
, *obuf
;
2617 buf
= Fget_buffer (buffer
);
2621 if (!BUFFER_LIVE_P (bp
))
2622 error ("Selecting deleted buffer");
2628 CHECK_NUMBER_COERCE_MARKER (start
);
2635 CHECK_NUMBER_COERCE_MARKER (end
);
2640 temp
= b
, b
= e
, e
= temp
;
2642 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
2643 args_out_of_range (start
, end
);
2645 obuf
= current_buffer
;
2646 set_buffer_internal_1 (bp
);
2647 update_buffer_properties (b
, e
);
2648 set_buffer_internal_1 (obuf
);
2650 insert_from_buffer (bp
, b
, e
- b
, 0);
2654 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
2656 doc
: /* Compare two substrings of two buffers; return result as number.
2657 Return -N if first string is less after N-1 chars, +N if first string is
2658 greater after N-1 chars, or 0 if strings match. Each substring is
2659 represented as three arguments: BUFFER, START and END. That makes six
2660 args in all, three for each substring.
2662 The value of `case-fold-search' in the current buffer
2663 determines whether case is significant or ignored. */)
2664 (Lisp_Object buffer1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object buffer2
, Lisp_Object start2
, Lisp_Object end2
)
2666 register EMACS_INT begp1
, endp1
, begp2
, endp2
, temp
;
2667 register struct buffer
*bp1
, *bp2
;
2668 register Lisp_Object trt
2669 = (!NILP (BVAR (current_buffer
, case_fold_search
))
2670 ? BVAR (current_buffer
, case_canon_table
) : Qnil
);
2671 ptrdiff_t chars
= 0;
2672 ptrdiff_t i1
, i2
, i1_byte
, i2_byte
;
2674 /* Find the first buffer and its substring. */
2677 bp1
= current_buffer
;
2681 buf1
= Fget_buffer (buffer1
);
2684 bp1
= XBUFFER (buf1
);
2685 if (!BUFFER_LIVE_P (bp1
))
2686 error ("Selecting deleted buffer");
2690 begp1
= BUF_BEGV (bp1
);
2693 CHECK_NUMBER_COERCE_MARKER (start1
);
2694 begp1
= XINT (start1
);
2697 endp1
= BUF_ZV (bp1
);
2700 CHECK_NUMBER_COERCE_MARKER (end1
);
2701 endp1
= XINT (end1
);
2705 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
2707 if (!(BUF_BEGV (bp1
) <= begp1
2709 && endp1
<= BUF_ZV (bp1
)))
2710 args_out_of_range (start1
, end1
);
2712 /* Likewise for second substring. */
2715 bp2
= current_buffer
;
2719 buf2
= Fget_buffer (buffer2
);
2722 bp2
= XBUFFER (buf2
);
2723 if (!BUFFER_LIVE_P (bp2
))
2724 error ("Selecting deleted buffer");
2728 begp2
= BUF_BEGV (bp2
);
2731 CHECK_NUMBER_COERCE_MARKER (start2
);
2732 begp2
= XINT (start2
);
2735 endp2
= BUF_ZV (bp2
);
2738 CHECK_NUMBER_COERCE_MARKER (end2
);
2739 endp2
= XINT (end2
);
2743 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
2745 if (!(BUF_BEGV (bp2
) <= begp2
2747 && endp2
<= BUF_ZV (bp2
)))
2748 args_out_of_range (start2
, end2
);
2752 i1_byte
= buf_charpos_to_bytepos (bp1
, i1
);
2753 i2_byte
= buf_charpos_to_bytepos (bp2
, i2
);
2755 while (i1
< endp1
&& i2
< endp2
)
2757 /* When we find a mismatch, we must compare the
2758 characters, not just the bytes. */
2763 if (! NILP (BVAR (bp1
, enable_multibyte_characters
)))
2765 c1
= BUF_FETCH_MULTIBYTE_CHAR (bp1
, i1_byte
);
2766 BUF_INC_POS (bp1
, i1_byte
);
2771 c1
= BUF_FETCH_BYTE (bp1
, i1
);
2772 MAKE_CHAR_MULTIBYTE (c1
);
2776 if (! NILP (BVAR (bp2
, enable_multibyte_characters
)))
2778 c2
= BUF_FETCH_MULTIBYTE_CHAR (bp2
, i2_byte
);
2779 BUF_INC_POS (bp2
, i2_byte
);
2784 c2
= BUF_FETCH_BYTE (bp2
, i2
);
2785 MAKE_CHAR_MULTIBYTE (c2
);
2791 c1
= char_table_translate (trt
, c1
);
2792 c2
= char_table_translate (trt
, c2
);
2795 return make_number (- 1 - chars
);
2797 return make_number (chars
+ 1);
2802 /* The strings match as far as they go.
2803 If one is shorter, that one is less. */
2804 if (chars
< endp1
- begp1
)
2805 return make_number (chars
+ 1);
2806 else if (chars
< endp2
- begp2
)
2807 return make_number (- chars
- 1);
2809 /* Same length too => they are equal. */
2810 return make_number (0);
2814 subst_char_in_region_unwind (Lisp_Object arg
)
2816 bset_undo_list (current_buffer
, arg
);
2821 subst_char_in_region_unwind_1 (Lisp_Object arg
)
2823 bset_filename (current_buffer
, arg
);
2827 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
2828 Ssubst_char_in_region
, 4, 5, 0,
2829 doc
: /* From START to END, replace FROMCHAR with TOCHAR each time it occurs.
2830 If optional arg NOUNDO is non-nil, don't record this change for undo
2831 and don't mark the buffer as really changed.
2832 Both characters must have the same length of multi-byte form. */)
2833 (Lisp_Object start
, Lisp_Object end
, Lisp_Object fromchar
, Lisp_Object tochar
, Lisp_Object noundo
)
2835 register ptrdiff_t pos
, pos_byte
, stop
, i
, len
, end_byte
;
2836 /* Keep track of the first change in the buffer:
2837 if 0 we haven't found it yet.
2838 if < 0 we've found it and we've run the before-change-function.
2839 if > 0 we've actually performed it and the value is its position. */
2840 ptrdiff_t changed
= 0;
2841 unsigned char fromstr
[MAX_MULTIBYTE_LENGTH
], tostr
[MAX_MULTIBYTE_LENGTH
];
2843 ptrdiff_t count
= SPECPDL_INDEX ();
2844 #define COMBINING_NO 0
2845 #define COMBINING_BEFORE 1
2846 #define COMBINING_AFTER 2
2847 #define COMBINING_BOTH (COMBINING_BEFORE | COMBINING_AFTER)
2848 int maybe_byte_combining
= COMBINING_NO
;
2849 ptrdiff_t last_changed
= 0;
2851 = !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
2856 validate_region (&start
, &end
);
2857 CHECK_CHARACTER (fromchar
);
2858 CHECK_CHARACTER (tochar
);
2859 fromc
= XFASTINT (fromchar
);
2860 toc
= XFASTINT (tochar
);
2864 len
= CHAR_STRING (fromc
, fromstr
);
2865 if (CHAR_STRING (toc
, tostr
) != len
)
2866 error ("Characters in `subst-char-in-region' have different byte-lengths");
2867 if (!ASCII_BYTE_P (*tostr
))
2869 /* If *TOSTR is in the range 0x80..0x9F and TOCHAR is not a
2870 complete multibyte character, it may be combined with the
2871 after bytes. If it is in the range 0xA0..0xFF, it may be
2872 combined with the before and after bytes. */
2873 if (!CHAR_HEAD_P (*tostr
))
2874 maybe_byte_combining
= COMBINING_BOTH
;
2875 else if (BYTES_BY_CHAR_HEAD (*tostr
) > len
)
2876 maybe_byte_combining
= COMBINING_AFTER
;
2887 pos_byte
= CHAR_TO_BYTE (pos
);
2888 stop
= CHAR_TO_BYTE (XINT (end
));
2891 /* If we don't want undo, turn off putting stuff on the list.
2892 That's faster than getting rid of things,
2893 and it prevents even the entry for a first change.
2894 Also inhibit locking the file. */
2895 if (!changed
&& !NILP (noundo
))
2897 record_unwind_protect (subst_char_in_region_unwind
,
2898 BVAR (current_buffer
, undo_list
));
2899 bset_undo_list (current_buffer
, Qt
);
2900 /* Don't do file-locking. */
2901 record_unwind_protect (subst_char_in_region_unwind_1
,
2902 BVAR (current_buffer
, filename
));
2903 bset_filename (current_buffer
, Qnil
);
2906 if (pos_byte
< GPT_BYTE
)
2907 stop
= min (stop
, GPT_BYTE
);
2910 ptrdiff_t pos_byte_next
= pos_byte
;
2912 if (pos_byte
>= stop
)
2914 if (pos_byte
>= end_byte
) break;
2917 p
= BYTE_POS_ADDR (pos_byte
);
2919 INC_POS (pos_byte_next
);
2922 if (pos_byte_next
- pos_byte
== len
2923 && p
[0] == fromstr
[0]
2925 || (p
[1] == fromstr
[1]
2926 && (len
== 2 || (p
[2] == fromstr
[2]
2927 && (len
== 3 || p
[3] == fromstr
[3]))))))
2930 /* We've already seen this and run the before-change-function;
2931 this time we only need to record the actual position. */
2936 modify_region_1 (pos
, XINT (end
), false);
2938 if (! NILP (noundo
))
2940 if (MODIFF
- 1 == SAVE_MODIFF
)
2942 if (MODIFF
- 1 == BUF_AUTOSAVE_MODIFF (current_buffer
))
2943 BUF_AUTOSAVE_MODIFF (current_buffer
)++;
2946 /* The before-change-function may have moved the gap
2947 or even modified the buffer so we should start over. */
2951 /* Take care of the case where the new character
2952 combines with neighboring bytes. */
2953 if (maybe_byte_combining
2954 && (maybe_byte_combining
== COMBINING_AFTER
2955 ? (pos_byte_next
< Z_BYTE
2956 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2957 : ((pos_byte_next
< Z_BYTE
2958 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2959 || (pos_byte
> BEG_BYTE
2960 && ! ASCII_BYTE_P (FETCH_BYTE (pos_byte
- 1))))))
2962 Lisp_Object tem
, string
;
2964 struct gcpro gcpro1
;
2966 tem
= BVAR (current_buffer
, undo_list
);
2969 /* Make a multibyte string containing this single character. */
2970 string
= make_multibyte_string ((char *) tostr
, 1, len
);
2971 /* replace_range is less efficient, because it moves the gap,
2972 but it handles combining correctly. */
2973 replace_range (pos
, pos
+ 1, string
,
2975 pos_byte_next
= CHAR_TO_BYTE (pos
);
2976 if (pos_byte_next
> pos_byte
)
2977 /* Before combining happened. We should not increment
2978 POS. So, to cancel the later increment of POS,
2982 INC_POS (pos_byte_next
);
2984 if (! NILP (noundo
))
2985 bset_undo_list (current_buffer
, tem
);
2992 record_change (pos
, 1);
2993 for (i
= 0; i
< len
; i
++) *p
++ = tostr
[i
];
2995 last_changed
= pos
+ 1;
2997 pos_byte
= pos_byte_next
;
3003 signal_after_change (changed
,
3004 last_changed
- changed
, last_changed
- changed
);
3005 update_compositions (changed
, last_changed
, CHECK_ALL
);
3008 unbind_to (count
, Qnil
);
3013 static Lisp_Object
check_translation (ptrdiff_t, ptrdiff_t, ptrdiff_t,
3016 /* Helper function for Ftranslate_region_internal.
3018 Check if a character sequence at POS (POS_BYTE) matches an element
3019 of VAL. VAL is a list (([FROM-CHAR ...] . TO) ...). If a matching
3020 element is found, return it. Otherwise return Qnil. */
3023 check_translation (ptrdiff_t pos
, ptrdiff_t pos_byte
, ptrdiff_t end
,
3026 int buf_size
= 16, buf_used
= 0;
3027 int *buf
= alloca (sizeof (int) * buf_size
);
3029 for (; CONSP (val
); val
= XCDR (val
))
3038 if (! VECTORP (elt
))
3041 if (len
<= end
- pos
)
3043 for (i
= 0; i
< len
; i
++)
3047 unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
3050 if (buf_used
== buf_size
)
3055 newbuf
= alloca (sizeof (int) * buf_size
);
3056 memcpy (newbuf
, buf
, sizeof (int) * buf_used
);
3059 buf
[buf_used
++] = STRING_CHAR_AND_LENGTH (p
, len1
);
3062 if (XINT (AREF (elt
, i
)) != buf
[i
])
3073 DEFUN ("translate-region-internal", Ftranslate_region_internal
,
3074 Stranslate_region_internal
, 3, 3, 0,
3075 doc
: /* Internal use only.
3076 From START to END, translate characters according to TABLE.
3077 TABLE is a string or a char-table; the Nth character in it is the
3078 mapping for the character with code N.
3079 It returns the number of characters changed. */)
3080 (Lisp_Object start
, Lisp_Object end
, register Lisp_Object table
)
3082 register unsigned char *tt
; /* Trans table. */
3083 register int nc
; /* New character. */
3084 int cnt
; /* Number of changes made. */
3085 ptrdiff_t size
; /* Size of translate table. */
3086 ptrdiff_t pos
, pos_byte
, end_pos
;
3087 bool multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3088 bool string_multibyte
IF_LINT (= 0);
3090 validate_region (&start
, &end
);
3091 if (CHAR_TABLE_P (table
))
3093 if (! EQ (XCHAR_TABLE (table
)->purpose
, Qtranslation_table
))
3094 error ("Not a translation table");
3100 CHECK_STRING (table
);
3102 if (! multibyte
&& (SCHARS (table
) < SBYTES (table
)))
3103 table
= string_make_unibyte (table
);
3104 string_multibyte
= SCHARS (table
) < SBYTES (table
);
3105 size
= SBYTES (table
);
3110 pos_byte
= CHAR_TO_BYTE (pos
);
3111 end_pos
= XINT (end
);
3112 modify_region_1 (pos
, end_pos
, false);
3115 for (; pos
< end_pos
; )
3117 register unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
3118 unsigned char *str
, buf
[MAX_MULTIBYTE_LENGTH
];
3124 oc
= STRING_CHAR_AND_LENGTH (p
, len
);
3131 /* Reload as signal_after_change in last iteration may GC. */
3133 if (string_multibyte
)
3135 str
= tt
+ string_char_to_byte (table
, oc
);
3136 nc
= STRING_CHAR_AND_LENGTH (str
, str_len
);
3141 if (! ASCII_BYTE_P (nc
) && multibyte
)
3143 str_len
= BYTE8_STRING (nc
, buf
);
3156 val
= CHAR_TABLE_REF (table
, oc
);
3157 if (CHARACTERP (val
))
3159 nc
= XFASTINT (val
);
3160 str_len
= CHAR_STRING (nc
, buf
);
3163 else if (VECTORP (val
) || (CONSP (val
)))
3165 /* VAL is [TO_CHAR ...] or (([FROM-CHAR ...] . TO) ...)
3166 where TO is TO-CHAR or [TO-CHAR ...]. */
3171 if (nc
!= oc
&& nc
>= 0)
3173 /* Simple one char to one char translation. */
3178 /* This is less efficient, because it moves the gap,
3179 but it should handle multibyte characters correctly. */
3180 string
= make_multibyte_string ((char *) str
, 1, str_len
);
3181 replace_range (pos
, pos
+ 1, string
, 1, 0, 1);
3186 record_change (pos
, 1);
3187 while (str_len
-- > 0)
3189 signal_after_change (pos
, 1, 1);
3190 update_compositions (pos
, pos
+ 1, CHECK_BORDER
);
3200 val
= check_translation (pos
, pos_byte
, end_pos
, val
);
3207 /* VAL is ([FROM-CHAR ...] . TO). */
3208 len
= ASIZE (XCAR (val
));
3216 string
= Fconcat (1, &val
);
3220 string
= Fmake_string (make_number (1), val
);
3222 replace_range (pos
, pos
+ len
, string
, 1, 0, 1);
3223 pos_byte
+= SBYTES (string
);
3224 pos
+= SCHARS (string
);
3225 cnt
+= SCHARS (string
);
3226 end_pos
+= SCHARS (string
) - len
;
3234 return make_number (cnt
);
3237 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
3238 doc
: /* Delete the text between START and END.
3239 If called interactively, delete the region between point and mark.
3240 This command deletes buffer text without modifying the kill ring. */)
3241 (Lisp_Object start
, Lisp_Object end
)
3243 validate_region (&start
, &end
);
3244 del_range (XINT (start
), XINT (end
));
3248 DEFUN ("delete-and-extract-region", Fdelete_and_extract_region
,
3249 Sdelete_and_extract_region
, 2, 2, 0,
3250 doc
: /* Delete the text between START and END and return it. */)
3251 (Lisp_Object start
, Lisp_Object end
)
3253 validate_region (&start
, &end
);
3254 if (XINT (start
) == XINT (end
))
3255 return empty_unibyte_string
;
3256 return del_range_1 (XINT (start
), XINT (end
), 1, 1);
3259 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
3260 doc
: /* Remove restrictions (narrowing) from current buffer.
3261 This allows the buffer's full text to be seen and edited. */)
3264 if (BEG
!= BEGV
|| Z
!= ZV
)
3265 current_buffer
->clip_changed
= 1;
3267 BEGV_BYTE
= BEG_BYTE
;
3268 SET_BUF_ZV_BOTH (current_buffer
, Z
, Z_BYTE
);
3269 /* Changing the buffer bounds invalidates any recorded current column. */
3270 invalidate_current_column ();
3274 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
3275 doc
: /* Restrict editing in this buffer to the current region.
3276 The rest of the text becomes temporarily invisible and untouchable
3277 but is not deleted; if you save the buffer in a file, the invisible
3278 text is included in the file. \\[widen] makes all visible again.
3279 See also `save-restriction'.
3281 When calling from a program, pass two arguments; positions (integers
3282 or markers) bounding the text that should remain visible. */)
3283 (register Lisp_Object start
, Lisp_Object end
)
3285 CHECK_NUMBER_COERCE_MARKER (start
);
3286 CHECK_NUMBER_COERCE_MARKER (end
);
3288 if (XINT (start
) > XINT (end
))
3291 tem
= start
; start
= end
; end
= tem
;
3294 if (!(BEG
<= XINT (start
) && XINT (start
) <= XINT (end
) && XINT (end
) <= Z
))
3295 args_out_of_range (start
, end
);
3297 if (BEGV
!= XFASTINT (start
) || ZV
!= XFASTINT (end
))
3298 current_buffer
->clip_changed
= 1;
3300 SET_BUF_BEGV (current_buffer
, XFASTINT (start
));
3301 SET_BUF_ZV (current_buffer
, XFASTINT (end
));
3302 if (PT
< XFASTINT (start
))
3303 SET_PT (XFASTINT (start
));
3304 if (PT
> XFASTINT (end
))
3305 SET_PT (XFASTINT (end
));
3306 /* Changing the buffer bounds invalidates any recorded current column. */
3307 invalidate_current_column ();
3312 save_restriction_save (void)
3314 if (BEGV
== BEG
&& ZV
== Z
)
3315 /* The common case that the buffer isn't narrowed.
3316 We return just the buffer object, which save_restriction_restore
3317 recognizes as meaning `no restriction'. */
3318 return Fcurrent_buffer ();
3320 /* We have to save a restriction, so return a pair of markers, one
3321 for the beginning and one for the end. */
3323 Lisp_Object beg
, end
;
3325 beg
= build_marker (current_buffer
, BEGV
, BEGV_BYTE
);
3326 end
= build_marker (current_buffer
, ZV
, ZV_BYTE
);
3328 /* END must move forward if text is inserted at its exact location. */
3329 XMARKER (end
)->insertion_type
= 1;
3331 return Fcons (beg
, end
);
3336 save_restriction_restore (Lisp_Object data
)
3338 struct buffer
*cur
= NULL
;
3339 struct buffer
*buf
= (CONSP (data
)
3340 ? XMARKER (XCAR (data
))->buffer
3343 if (buf
&& buf
!= current_buffer
&& !NILP (BVAR (buf
, pt_marker
)))
3344 { /* If `buf' uses markers to keep track of PT, BEGV, and ZV (as
3345 is the case if it is or has an indirect buffer), then make
3346 sure it is current before we update BEGV, so
3347 set_buffer_internal takes care of managing those markers. */
3348 cur
= current_buffer
;
3349 set_buffer_internal (buf
);
3353 /* A pair of marks bounding a saved restriction. */
3355 struct Lisp_Marker
*beg
= XMARKER (XCAR (data
));
3356 struct Lisp_Marker
*end
= XMARKER (XCDR (data
));
3357 eassert (buf
== end
->buffer
);
3359 if (buf
/* Verify marker still points to a buffer. */
3360 && (beg
->charpos
!= BUF_BEGV (buf
) || end
->charpos
!= BUF_ZV (buf
)))
3361 /* The restriction has changed from the saved one, so restore
3362 the saved restriction. */
3364 ptrdiff_t pt
= BUF_PT (buf
);
3366 SET_BUF_BEGV_BOTH (buf
, beg
->charpos
, beg
->bytepos
);
3367 SET_BUF_ZV_BOTH (buf
, end
->charpos
, end
->bytepos
);
3369 if (pt
< beg
->charpos
|| pt
> end
->charpos
)
3370 /* The point is outside the new visible range, move it inside. */
3371 SET_BUF_PT_BOTH (buf
,
3372 clip_to_bounds (beg
->charpos
, pt
, end
->charpos
),
3373 clip_to_bounds (beg
->bytepos
, BUF_PT_BYTE (buf
),
3376 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3378 /* These aren't needed anymore, so don't wait for GC. */
3379 free_marker (XCAR (data
));
3380 free_marker (XCDR (data
));
3381 free_cons (XCONS (data
));
3384 /* A buffer, which means that there was no old restriction. */
3386 if (buf
/* Verify marker still points to a buffer. */
3387 && (BUF_BEGV (buf
) != BUF_BEG (buf
) || BUF_ZV (buf
) != BUF_Z (buf
)))
3388 /* The buffer has been narrowed, get rid of the narrowing. */
3390 SET_BUF_BEGV_BOTH (buf
, BUF_BEG (buf
), BUF_BEG_BYTE (buf
));
3391 SET_BUF_ZV_BOTH (buf
, BUF_Z (buf
), BUF_Z_BYTE (buf
));
3393 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3397 /* Changing the buffer bounds invalidates any recorded current column. */
3398 invalidate_current_column ();
3401 set_buffer_internal (cur
);
3406 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
3407 doc
: /* Execute BODY, saving and restoring current buffer's restrictions.
3408 The buffer's restrictions make parts of the beginning and end invisible.
3409 \(They are set up with `narrow-to-region' and eliminated with `widen'.)
3410 This special form, `save-restriction', saves the current buffer's restrictions
3411 when it is entered, and restores them when it is exited.
3412 So any `narrow-to-region' within BODY lasts only until the end of the form.
3413 The old restrictions settings are restored
3414 even in case of abnormal exit (throw or error).
3416 The value returned is the value of the last form in BODY.
3418 Note: if you are using both `save-excursion' and `save-restriction',
3419 use `save-excursion' outermost:
3420 (save-excursion (save-restriction ...))
3422 usage: (save-restriction &rest BODY) */)
3425 register Lisp_Object val
;
3426 ptrdiff_t count
= SPECPDL_INDEX ();
3428 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
3429 val
= Fprogn (body
);
3430 return unbind_to (count
, val
);
3433 /* Buffer for the most recent text displayed by Fmessage_box. */
3434 static char *message_text
;
3436 /* Allocated length of that buffer. */
3437 static ptrdiff_t message_length
;
3439 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
3440 doc
: /* Display a message at the bottom of the screen.
3441 The message also goes into the `*Messages*' buffer, if `message-log-max'
3442 is non-nil. (In keyboard macros, that's all it does.)
3445 The first argument is a format control string, and the rest are data
3446 to be formatted under control of the string. See `format' for details.
3448 Note: Use (message "%s" VALUE) to print the value of expressions and
3449 variables to avoid accidentally interpreting `%' as format specifiers.
3451 If the first argument is nil or the empty string, the function clears
3452 any existing message; this lets the minibuffer contents show. See
3453 also `current-message'.
3455 usage: (message FORMAT-STRING &rest ARGS) */)
3456 (ptrdiff_t nargs
, Lisp_Object
*args
)
3459 || (STRINGP (args
[0])
3460 && SBYTES (args
[0]) == 0))
3467 register Lisp_Object val
;
3468 val
= Fformat (nargs
, args
);
3469 message3 (val
, SBYTES (val
), STRING_MULTIBYTE (val
));
3474 DEFUN ("message-box", Fmessage_box
, Smessage_box
, 1, MANY
, 0,
3475 doc
: /* Display a message, in a dialog box if possible.
3476 If a dialog box is not available, use the echo area.
3477 The first argument is a format control string, and the rest are data
3478 to be formatted under control of the string. See `format' for details.
3480 If the first argument is nil or the empty string, clear any existing
3481 message; let the minibuffer contents show.
3483 usage: (message-box FORMAT-STRING &rest ARGS) */)
3484 (ptrdiff_t nargs
, Lisp_Object
*args
)
3493 register Lisp_Object val
;
3494 val
= Fformat (nargs
, args
);
3496 /* The MS-DOS frames support popup menus even though they are
3497 not FRAME_WINDOW_P. */
3498 if (FRAME_WINDOW_P (XFRAME (selected_frame
))
3499 || FRAME_MSDOS_P (XFRAME (selected_frame
)))
3501 Lisp_Object pane
, menu
;
3502 struct gcpro gcpro1
;
3503 pane
= Fcons (Fcons (build_string ("OK"), Qt
), Qnil
);
3505 menu
= Fcons (val
, pane
);
3506 Fx_popup_dialog (Qt
, menu
, Qt
);
3510 #endif /* HAVE_MENUS */
3511 /* Copy the data so that it won't move when we GC. */
3512 if (SBYTES (val
) > message_length
)
3514 ptrdiff_t new_length
= SBYTES (val
) + 80;
3515 message_text
= xrealloc (message_text
, new_length
);
3516 message_length
= new_length
;
3518 memcpy (message_text
, SDATA (val
), SBYTES (val
));
3519 message2 (message_text
, SBYTES (val
),
3520 STRING_MULTIBYTE (val
));
3525 DEFUN ("message-or-box", Fmessage_or_box
, Smessage_or_box
, 1, MANY
, 0,
3526 doc
: /* Display a message in a dialog box or in the echo area.
3527 If this command was invoked with the mouse, use a dialog box if
3528 `use-dialog-box' is non-nil.
3529 Otherwise, use the echo area.
3530 The first argument is a format control string, and the rest are data
3531 to be formatted under control of the string. See `format' for details.
3533 If the first argument is nil or the empty string, clear any existing
3534 message; let the minibuffer contents show.
3536 usage: (message-or-box FORMAT-STRING &rest ARGS) */)
3537 (ptrdiff_t nargs
, Lisp_Object
*args
)
3540 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3542 return Fmessage_box (nargs
, args
);
3544 return Fmessage (nargs
, args
);
3547 DEFUN ("current-message", Fcurrent_message
, Scurrent_message
, 0, 0, 0,
3548 doc
: /* Return the string currently displayed in the echo area, or nil if none. */)
3551 return current_message ();
3555 DEFUN ("propertize", Fpropertize
, Spropertize
, 1, MANY
, 0,
3556 doc
: /* Return a copy of STRING with text properties added.
3557 First argument is the string to copy.
3558 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
3559 properties to add to the result.
3560 usage: (propertize STRING &rest PROPERTIES) */)
3561 (ptrdiff_t nargs
, Lisp_Object
*args
)
3563 Lisp_Object properties
, string
;
3564 struct gcpro gcpro1
, gcpro2
;
3567 /* Number of args must be odd. */
3568 if ((nargs
& 1) == 0)
3569 error ("Wrong number of arguments");
3571 properties
= string
= Qnil
;
3572 GCPRO2 (properties
, string
);
3574 /* First argument must be a string. */
3575 CHECK_STRING (args
[0]);
3576 string
= Fcopy_sequence (args
[0]);
3578 for (i
= 1; i
< nargs
; i
+= 2)
3579 properties
= Fcons (args
[i
], Fcons (args
[i
+ 1], properties
));
3581 Fadd_text_properties (make_number (0),
3582 make_number (SCHARS (string
)),
3583 properties
, string
);
3584 RETURN_UNGCPRO (string
);
3587 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
3588 doc
: /* Format a string out of a format-string and arguments.
3589 The first argument is a format control string.
3590 The other arguments are substituted into it to make the result, a string.
3592 The format control string may contain %-sequences meaning to substitute
3593 the next available argument:
3595 %s means print a string argument. Actually, prints any object, with `princ'.
3596 %d means print as number in decimal (%o octal, %x hex).
3597 %X is like %x, but uses upper case.
3598 %e means print a number in exponential notation.
3599 %f means print a number in decimal-point notation.
3600 %g means print a number in exponential notation
3601 or decimal-point notation, whichever uses fewer characters.
3602 %c means print a number as a single character.
3603 %S means print any object as an s-expression (using `prin1').
3605 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.
3606 Use %% to put a single % into the output.
3608 A %-sequence may contain optional flag, width, and precision
3609 specifiers, as follows:
3611 %<flags><width><precision>character
3613 where flags is [+ #-0]+, width is [0-9]+, and precision is .[0-9]+
3615 The + flag character inserts a + before any positive number, while a
3616 space inserts a space before any positive number; these flags only
3617 affect %d, %e, %f, and %g sequences, and the + flag takes precedence.
3618 The - and 0 flags affect the width specifier, as described below.
3620 The # flag means to use an alternate display form for %o, %x, %X, %e,
3621 %f, and %g sequences: for %o, it ensures that the result begins with
3622 \"0\"; for %x and %X, it prefixes the result with \"0x\" or \"0X\";
3623 for %e, %f, and %g, it causes a decimal point to be included even if
3624 the precision is zero.
3626 The width specifier supplies a lower limit for the length of the
3627 printed representation. The padding, if any, normally goes on the
3628 left, but it goes on the right if the - flag is present. The padding
3629 character is normally a space, but it is 0 if the 0 flag is present.
3630 The 0 flag is ignored if the - flag is present, or the format sequence
3631 is something other than %d, %e, %f, and %g.
3633 For %e, %f, and %g sequences, the number after the "." in the
3634 precision specifier says how many decimal places to show; if zero, the
3635 decimal point itself is omitted. For %s and %S, the precision
3636 specifier truncates the string to the given width.
3638 usage: (format STRING &rest OBJECTS) */)
3639 (ptrdiff_t nargs
, Lisp_Object
*args
)
3641 ptrdiff_t n
; /* The number of the next arg to substitute */
3642 char initial_buffer
[4000];
3643 char *buf
= initial_buffer
;
3644 ptrdiff_t bufsize
= sizeof initial_buffer
;
3645 ptrdiff_t max_bufsize
= STRING_BYTES_BOUND
+ 1;
3647 Lisp_Object buf_save_value
IF_LINT (= {0});
3648 char *format
, *end
, *format_start
;
3649 ptrdiff_t formatlen
, nchars
;
3650 /* True if the format is multibyte. */
3651 bool multibyte_format
= 0;
3652 /* True if the output should be a multibyte string,
3653 which is true if any of the inputs is one. */
3655 /* When we make a multibyte string, we must pay attention to the
3656 byte combining problem, i.e., a byte may be combined with a
3657 multibyte character of the previous string. This flag tells if we
3658 must consider such a situation or not. */
3659 bool maybe_combine_byte
;
3661 bool arg_intervals
= 0;
3664 /* discarded[I] is 1 if byte I of the format
3665 string was not copied into the output.
3666 It is 2 if byte I was not the first byte of its character. */
3669 /* Each element records, for one argument,
3670 the start and end bytepos in the output string,
3671 whether the argument has been converted to string (e.g., due to "%S"),
3672 and whether the argument is a string with intervals.
3673 info[0] is unused. Unused elements have -1 for start. */
3676 ptrdiff_t start
, end
;
3677 unsigned converted_to_string
: 1;
3678 unsigned intervals
: 1;
3681 /* It should not be necessary to GCPRO ARGS, because
3682 the caller in the interpreter should take care of that. */
3684 CHECK_STRING (args
[0]);
3685 format_start
= SSDATA (args
[0]);
3686 formatlen
= SBYTES (args
[0]);
3688 /* Allocate the info and discarded tables. */
3691 if ((SIZE_MAX
- formatlen
) / sizeof (struct info
) <= nargs
)
3692 memory_full (SIZE_MAX
);
3693 info
= SAFE_ALLOCA ((nargs
+ 1) * sizeof *info
+ formatlen
);
3694 discarded
= (char *) &info
[nargs
+ 1];
3695 for (i
= 0; i
< nargs
+ 1; i
++)
3698 info
[i
].intervals
= info
[i
].converted_to_string
= 0;
3700 memset (discarded
, 0, formatlen
);
3703 /* Try to determine whether the result should be multibyte.
3704 This is not always right; sometimes the result needs to be multibyte
3705 because of an object that we will pass through prin1,
3706 and in that case, we won't know it here. */
3707 multibyte_format
= STRING_MULTIBYTE (args
[0]);
3708 multibyte
= multibyte_format
;
3709 for (n
= 1; !multibyte
&& n
< nargs
; n
++)
3710 if (STRINGP (args
[n
]) && STRING_MULTIBYTE (args
[n
]))
3713 /* If we start out planning a unibyte result,
3714 then discover it has to be multibyte, we jump back to retry. */
3721 /* Scan the format and store result in BUF. */
3722 format
= format_start
;
3723 end
= format
+ formatlen
;
3724 maybe_combine_byte
= 0;
3726 while (format
!= end
)
3728 /* The values of N and FORMAT when the loop body is entered. */
3730 char *format0
= format
;
3732 /* Bytes needed to represent the output of this conversion. */
3733 ptrdiff_t convbytes
;
3737 /* General format specifications look like
3739 '%' [flags] [field-width] [precision] format
3744 field-width ::= [0-9]+
3745 precision ::= '.' [0-9]*
3747 If a field-width is specified, it specifies to which width
3748 the output should be padded with blanks, if the output
3749 string is shorter than field-width.
3751 If precision is specified, it specifies the number of
3752 digits to print after the '.' for floats, or the max.
3753 number of chars to print from a string. */
3755 bool minus_flag
= 0;
3757 bool space_flag
= 0;
3758 bool sharp_flag
= 0;
3760 ptrdiff_t field_width
;
3761 bool precision_given
;
3762 uintmax_t precision
= UINTMAX_MAX
;
3770 case '-': minus_flag
= 1; continue;
3771 case '+': plus_flag
= 1; continue;
3772 case ' ': space_flag
= 1; continue;
3773 case '#': sharp_flag
= 1; continue;
3774 case '0': zero_flag
= 1; continue;
3779 /* Ignore flags when sprintf ignores them. */
3780 space_flag
&= ~ plus_flag
;
3781 zero_flag
&= ~ minus_flag
;
3784 uintmax_t w
= strtoumax (format
, &num_end
, 10);
3785 if (max_bufsize
<= w
)
3789 precision_given
= *num_end
== '.';
3790 if (precision_given
)
3791 precision
= strtoumax (num_end
+ 1, &num_end
, 10);
3795 error ("Format string ends in middle of format specifier");
3797 memset (&discarded
[format0
- format_start
], 1, format
- format0
);
3798 conversion
= *format
;
3799 if (conversion
== '%')
3801 discarded
[format
- format_start
] = 1;
3806 error ("Not enough arguments for format string");
3808 /* For 'S', prin1 the argument, and then treat like 's'.
3809 For 's', princ any argument that is not a string or
3810 symbol. But don't do this conversion twice, which might
3811 happen after retrying. */
3812 if ((conversion
== 'S'
3813 || (conversion
== 's'
3814 && ! STRINGP (args
[n
]) && ! SYMBOLP (args
[n
]))))
3816 if (! info
[n
].converted_to_string
)
3818 Lisp_Object noescape
= conversion
== 'S' ? Qnil
: Qt
;
3819 args
[n
] = Fprin1_to_string (args
[n
], noescape
);
3820 info
[n
].converted_to_string
= 1;
3821 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
3829 else if (conversion
== 'c')
3831 if (FLOATP (args
[n
]))
3833 double d
= XFLOAT_DATA (args
[n
]);
3834 args
[n
] = make_number (FIXNUM_OVERFLOW_P (d
) ? -1 : d
);
3837 if (INTEGERP (args
[n
]) && ! ASCII_CHAR_P (XINT (args
[n
])))
3844 args
[n
] = Fchar_to_string (args
[n
]);
3845 info
[n
].converted_to_string
= 1;
3848 if (info
[n
].converted_to_string
)
3853 if (SYMBOLP (args
[n
]))
3855 args
[n
] = SYMBOL_NAME (args
[n
]);
3856 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
3863 if (conversion
== 's')
3865 /* handle case (precision[n] >= 0) */
3867 ptrdiff_t width
, padding
, nbytes
;
3868 ptrdiff_t nchars_string
;
3870 ptrdiff_t prec
= -1;
3871 if (precision_given
&& precision
<= TYPE_MAXIMUM (ptrdiff_t))
3874 /* lisp_string_width ignores a precision of 0, but GNU
3875 libc functions print 0 characters when the precision
3876 is 0. Imitate libc behavior here. Changing
3877 lisp_string_width is the right thing, and will be
3878 done, but meanwhile we work with it. */
3881 width
= nchars_string
= nbytes
= 0;
3885 width
= lisp_string_width (args
[n
], prec
, &nch
, &nby
);
3888 nchars_string
= SCHARS (args
[n
]);
3889 nbytes
= SBYTES (args
[n
]);
3893 nchars_string
= nch
;
3899 if (convbytes
&& multibyte
&& ! STRING_MULTIBYTE (args
[n
]))
3900 convbytes
= count_size_as_multibyte (SDATA (args
[n
]), nbytes
);
3902 padding
= width
< field_width
? field_width
- width
: 0;
3904 if (max_bufsize
- padding
<= convbytes
)
3906 convbytes
+= padding
;
3907 if (convbytes
<= buf
+ bufsize
- p
)
3911 memset (p
, ' ', padding
);
3918 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3919 && STRING_MULTIBYTE (args
[n
])
3920 && !CHAR_HEAD_P (SREF (args
[n
], 0)))
3921 maybe_combine_byte
= 1;
3923 p
+= copy_text (SDATA (args
[n
]), (unsigned char *) p
,
3925 STRING_MULTIBYTE (args
[n
]), multibyte
);
3927 info
[n
].start
= nchars
;
3928 nchars
+= nchars_string
;
3929 info
[n
].end
= nchars
;
3933 memset (p
, ' ', padding
);
3938 /* If this argument has text properties, record where
3939 in the result string it appears. */
3940 if (string_intervals (args
[n
]))
3941 info
[n
].intervals
= arg_intervals
= 1;
3946 else if (! (conversion
== 'c' || conversion
== 'd'
3947 || conversion
== 'e' || conversion
== 'f'
3948 || conversion
== 'g' || conversion
== 'i'
3949 || conversion
== 'o' || conversion
== 'x'
3950 || conversion
== 'X'))
3951 error ("Invalid format operation %%%c",
3952 STRING_CHAR ((unsigned char *) format
- 1));
3953 else if (! (INTEGERP (args
[n
]) || FLOATP (args
[n
])))
3954 error ("Format specifier doesn't match argument type");
3959 /* Maximum precision for a %f conversion such that the
3960 trailing output digit might be nonzero. Any precision
3961 larger than this will not yield useful information. */
3962 USEFUL_PRECISION_MAX
=
3964 * (FLT_RADIX
== 2 || FLT_RADIX
== 10 ? 1
3965 : FLT_RADIX
== 16 ? 4
3968 /* Maximum number of bytes generated by any format, if
3969 precision is no more than USEFUL_PRECISION_MAX.
3970 On all practical hosts, %f is the worst case. */
3972 sizeof "-." + (DBL_MAX_10_EXP
+ 1) + USEFUL_PRECISION_MAX
,
3974 /* Length of pM (that is, of pMd without the
3976 pMlen
= sizeof pMd
- 2
3978 verify (0 < USEFUL_PRECISION_MAX
);
3981 ptrdiff_t padding
, sprintf_bytes
;
3982 uintmax_t excess_precision
, numwidth
;
3983 uintmax_t leading_zeros
= 0, trailing_zeros
= 0;
3985 char sprintf_buf
[SPRINTF_BUFSIZE
];
3987 /* Copy of conversion specification, modified somewhat.
3988 At most three flags F can be specified at once. */
3989 char convspec
[sizeof "%FFF.*d" + pMlen
];
3991 /* Avoid undefined behavior in underlying sprintf. */
3992 if (conversion
== 'd' || conversion
== 'i')
3995 /* Create the copy of the conversion specification, with
3996 any width and precision removed, with ".*" inserted,
3997 and with pM inserted for integer formats. */
4001 *f
= '-'; f
+= minus_flag
;
4002 *f
= '+'; f
+= plus_flag
;
4003 *f
= ' '; f
+= space_flag
;
4004 *f
= '#'; f
+= sharp_flag
;
4005 *f
= '0'; f
+= zero_flag
;
4008 if (conversion
== 'd' || conversion
== 'i'
4009 || conversion
== 'o' || conversion
== 'x'
4010 || conversion
== 'X')
4012 memcpy (f
, pMd
, pMlen
);
4014 zero_flag
&= ~ precision_given
;
4021 if (precision_given
)
4022 prec
= min (precision
, USEFUL_PRECISION_MAX
);
4024 /* Use sprintf to format this number into sprintf_buf. Omit
4025 padding and excess precision, though, because sprintf limits
4026 output length to INT_MAX.
4028 There are four types of conversion: double, unsigned
4029 char (passed as int), wide signed int, and wide
4030 unsigned int. Treat them separately because the
4031 sprintf ABI is sensitive to which type is passed. Be
4032 careful about integer overflow, NaNs, infinities, and
4033 conversions; for example, the min and max macros are
4034 not suitable here. */
4035 if (conversion
== 'e' || conversion
== 'f' || conversion
== 'g')
4037 double x
= (INTEGERP (args
[n
])
4039 : XFLOAT_DATA (args
[n
]));
4040 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4042 else if (conversion
== 'c')
4044 /* Don't use sprintf here, as it might mishandle prec. */
4045 sprintf_buf
[0] = XINT (args
[n
]);
4046 sprintf_bytes
= prec
!= 0;
4048 else if (conversion
== 'd')
4050 /* For float, maybe we should use "%1.0f"
4051 instead so it also works for values outside
4052 the integer range. */
4054 if (INTEGERP (args
[n
]))
4058 double d
= XFLOAT_DATA (args
[n
]);
4061 x
= TYPE_MINIMUM (printmax_t
);
4067 x
= TYPE_MAXIMUM (printmax_t
);
4072 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4076 /* Don't sign-extend for octal or hex printing. */
4078 if (INTEGERP (args
[n
]))
4079 x
= XUINT (args
[n
]);
4082 double d
= XFLOAT_DATA (args
[n
]);
4087 x
= TYPE_MAXIMUM (uprintmax_t
);
4092 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4095 /* Now the length of the formatted item is known, except it omits
4096 padding and excess precision. Deal with excess precision
4097 first. This happens only when the format specifies
4098 ridiculously large precision. */
4099 excess_precision
= precision
- prec
;
4100 if (excess_precision
)
4102 if (conversion
== 'e' || conversion
== 'f'
4103 || conversion
== 'g')
4105 if ((conversion
== 'g' && ! sharp_flag
)
4106 || ! ('0' <= sprintf_buf
[sprintf_bytes
- 1]
4107 && sprintf_buf
[sprintf_bytes
- 1] <= '9'))
4108 excess_precision
= 0;
4111 if (conversion
== 'g')
4113 char *dot
= strchr (sprintf_buf
, '.');
4115 excess_precision
= 0;
4118 trailing_zeros
= excess_precision
;
4121 leading_zeros
= excess_precision
;
4124 /* Compute the total bytes needed for this item, including
4125 excess precision and padding. */
4126 numwidth
= sprintf_bytes
+ excess_precision
;
4127 padding
= numwidth
< field_width
? field_width
- numwidth
: 0;
4128 if (max_bufsize
- sprintf_bytes
<= excess_precision
4129 || max_bufsize
- padding
<= numwidth
)
4131 convbytes
= numwidth
+ padding
;
4133 if (convbytes
<= buf
+ bufsize
- p
)
4135 /* Copy the formatted item from sprintf_buf into buf,
4136 inserting padding and excess-precision zeros. */
4138 char *src
= sprintf_buf
;
4140 int exponent_bytes
= 0;
4141 bool signedp
= src0
== '-' || src0
== '+' || src0
== ' ';
4142 int significand_bytes
;
4144 && ((src
[signedp
] >= '0' && src
[signedp
] <= '9')
4145 || (src
[signedp
] >= 'a' && src
[signedp
] <= 'f')
4146 || (src
[signedp
] >= 'A' && src
[signedp
] <= 'F')))
4148 leading_zeros
+= padding
;
4152 if (excess_precision
4153 && (conversion
== 'e' || conversion
== 'g'))
4155 char *e
= strchr (src
, 'e');
4157 exponent_bytes
= src
+ sprintf_bytes
- e
;
4162 memset (p
, ' ', padding
);
4170 memset (p
, '0', leading_zeros
);
4172 significand_bytes
= sprintf_bytes
- signedp
- exponent_bytes
;
4173 memcpy (p
, src
, significand_bytes
);
4174 p
+= significand_bytes
;
4175 src
+= significand_bytes
;
4176 memset (p
, '0', trailing_zeros
);
4177 p
+= trailing_zeros
;
4178 memcpy (p
, src
, exponent_bytes
);
4179 p
+= exponent_bytes
;
4181 info
[n
].start
= nchars
;
4182 nchars
+= leading_zeros
+ sprintf_bytes
+ trailing_zeros
;
4183 info
[n
].end
= nchars
;
4187 memset (p
, ' ', padding
);
4199 /* Copy a single character from format to buf. */
4202 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
4204 if (multibyte_format
)
4206 /* Copy a whole multibyte character. */
4208 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
4209 && !CHAR_HEAD_P (*format
))
4210 maybe_combine_byte
= 1;
4214 while (! CHAR_HEAD_P (*format
));
4216 convbytes
= format
- src
;
4217 memset (&discarded
[src
+ 1 - format_start
], 2, convbytes
- 1);
4221 unsigned char uc
= *format
++;
4222 if (! multibyte
|| ASCII_BYTE_P (uc
))
4226 int c
= BYTE8_TO_CHAR (uc
);
4227 convbytes
= CHAR_STRING (c
, str
);
4232 if (convbytes
<= buf
+ bufsize
- p
)
4234 memcpy (p
, src
, convbytes
);
4241 /* There wasn't enough room to store this conversion or single
4242 character. CONVBYTES says how much room is needed. Allocate
4243 enough room (and then some) and do it again. */
4245 ptrdiff_t used
= p
- buf
;
4247 if (max_bufsize
- used
< convbytes
)
4249 bufsize
= used
+ convbytes
;
4250 bufsize
= bufsize
< max_bufsize
/ 2 ? bufsize
* 2 : max_bufsize
;
4252 if (buf
== initial_buffer
)
4254 buf
= xmalloc (bufsize
);
4256 buf_save_value
= make_save_value (buf
, 0);
4257 record_unwind_protect (safe_alloca_unwind
, buf_save_value
);
4258 memcpy (buf
, initial_buffer
, used
);
4261 XSAVE_VALUE (buf_save_value
)->pointer
= buf
= xrealloc (buf
, bufsize
);
4270 if (bufsize
< p
- buf
)
4273 if (maybe_combine_byte
)
4274 nchars
= multibyte_chars_in_text ((unsigned char *) buf
, p
- buf
);
4275 val
= make_specified_string (buf
, nchars
, p
- buf
, multibyte
);
4277 /* If we allocated BUF with malloc, free it too. */
4280 /* If the format string has text properties, or any of the string
4281 arguments has text properties, set up text properties of the
4284 if (string_intervals (args
[0]) || arg_intervals
)
4286 Lisp_Object len
, new_len
, props
;
4287 struct gcpro gcpro1
;
4289 /* Add text properties from the format string. */
4290 len
= make_number (SCHARS (args
[0]));
4291 props
= text_property_list (args
[0], make_number (0), len
, Qnil
);
4296 ptrdiff_t bytepos
= 0, position
= 0, translated
= 0;
4300 /* Adjust the bounds of each text property
4301 to the proper start and end in the output string. */
4303 /* Put the positions in PROPS in increasing order, so that
4304 we can do (effectively) one scan through the position
4305 space of the format string. */
4306 props
= Fnreverse (props
);
4308 /* BYTEPOS is the byte position in the format string,
4309 POSITION is the untranslated char position in it,
4310 TRANSLATED is the translated char position in BUF,
4311 and ARGN is the number of the next arg we will come to. */
4312 for (list
= props
; CONSP (list
); list
= XCDR (list
))
4319 /* First adjust the property start position. */
4320 pos
= XINT (XCAR (item
));
4322 /* Advance BYTEPOS, POSITION, TRANSLATED and ARGN
4323 up to this position. */
4324 for (; position
< pos
; bytepos
++)
4326 if (! discarded
[bytepos
])
4327 position
++, translated
++;
4328 else if (discarded
[bytepos
] == 1)
4331 if (translated
== info
[argn
].start
)
4333 translated
+= info
[argn
].end
- info
[argn
].start
;
4339 XSETCAR (item
, make_number (translated
));
4341 /* Likewise adjust the property end position. */
4342 pos
= XINT (XCAR (XCDR (item
)));
4344 for (; position
< pos
; bytepos
++)
4346 if (! discarded
[bytepos
])
4347 position
++, translated
++;
4348 else if (discarded
[bytepos
] == 1)
4351 if (translated
== info
[argn
].start
)
4353 translated
+= info
[argn
].end
- info
[argn
].start
;
4359 XSETCAR (XCDR (item
), make_number (translated
));
4362 add_text_properties_from_list (val
, props
, make_number (0));
4365 /* Add text properties from arguments. */
4367 for (n
= 1; n
< nargs
; ++n
)
4368 if (info
[n
].intervals
)
4370 len
= make_number (SCHARS (args
[n
]));
4371 new_len
= make_number (info
[n
].end
- info
[n
].start
);
4372 props
= text_property_list (args
[n
], make_number (0), len
, Qnil
);
4373 props
= extend_property_ranges (props
, new_len
);
4374 /* If successive arguments have properties, be sure that
4375 the value of `composition' property be the copy. */
4376 if (n
> 1 && info
[n
- 1].end
)
4377 make_composition_value_copy (props
);
4378 add_text_properties_from_list (val
, props
,
4379 make_number (info
[n
].start
));
4389 format2 (const char *string1
, Lisp_Object arg0
, Lisp_Object arg1
)
4391 Lisp_Object args
[3];
4392 args
[0] = build_string (string1
);
4395 return Fformat (3, args
);
4398 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
4399 doc
: /* Return t if two characters match, optionally ignoring case.
4400 Both arguments must be characters (i.e. integers).
4401 Case is ignored if `case-fold-search' is non-nil in the current buffer. */)
4402 (register Lisp_Object c1
, Lisp_Object c2
)
4405 /* Check they're chars, not just integers, otherwise we could get array
4406 bounds violations in downcase. */
4407 CHECK_CHARACTER (c1
);
4408 CHECK_CHARACTER (c2
);
4410 if (XINT (c1
) == XINT (c2
))
4412 if (NILP (BVAR (current_buffer
, case_fold_search
)))
4416 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
))
4417 && ! ASCII_CHAR_P (i1
))
4419 MAKE_CHAR_MULTIBYTE (i1
);
4422 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
))
4423 && ! ASCII_CHAR_P (i2
))
4425 MAKE_CHAR_MULTIBYTE (i2
);
4427 return (downcase (i1
) == downcase (i2
) ? Qt
: Qnil
);
4430 /* Transpose the markers in two regions of the current buffer, and
4431 adjust the ones between them if necessary (i.e.: if the regions
4434 START1, END1 are the character positions of the first region.
4435 START1_BYTE, END1_BYTE are the byte positions.
4436 START2, END2 are the character positions of the second region.
4437 START2_BYTE, END2_BYTE are the byte positions.
4439 Traverses the entire marker list of the buffer to do so, adding an
4440 appropriate amount to some, subtracting from some, and leaving the
4441 rest untouched. Most of this is copied from adjust_markers in insdel.c.
4443 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
4446 transpose_markers (ptrdiff_t start1
, ptrdiff_t end1
,
4447 ptrdiff_t start2
, ptrdiff_t end2
,
4448 ptrdiff_t start1_byte
, ptrdiff_t end1_byte
,
4449 ptrdiff_t start2_byte
, ptrdiff_t end2_byte
)
4451 register ptrdiff_t amt1
, amt1_byte
, amt2
, amt2_byte
, diff
, diff_byte
, mpos
;
4452 register struct Lisp_Marker
*marker
;
4454 /* Update point as if it were a marker. */
4458 TEMP_SET_PT_BOTH (PT
+ (end2
- end1
),
4459 PT_BYTE
+ (end2_byte
- end1_byte
));
4460 else if (PT
< start2
)
4461 TEMP_SET_PT_BOTH (PT
+ (end2
- start2
) - (end1
- start1
),
4462 (PT_BYTE
+ (end2_byte
- start2_byte
)
4463 - (end1_byte
- start1_byte
)));
4465 TEMP_SET_PT_BOTH (PT
- (start2
- start1
),
4466 PT_BYTE
- (start2_byte
- start1_byte
));
4468 /* We used to adjust the endpoints here to account for the gap, but that
4469 isn't good enough. Even if we assume the caller has tried to move the
4470 gap out of our way, it might still be at start1 exactly, for example;
4471 and that places it `inside' the interval, for our purposes. The amount
4472 of adjustment is nontrivial if there's a `denormalized' marker whose
4473 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
4474 the dirty work to Fmarker_position, below. */
4476 /* The difference between the region's lengths */
4477 diff
= (end2
- start2
) - (end1
- start1
);
4478 diff_byte
= (end2_byte
- start2_byte
) - (end1_byte
- start1_byte
);
4480 /* For shifting each marker in a region by the length of the other
4481 region plus the distance between the regions. */
4482 amt1
= (end2
- start2
) + (start2
- end1
);
4483 amt2
= (end1
- start1
) + (start2
- end1
);
4484 amt1_byte
= (end2_byte
- start2_byte
) + (start2_byte
- end1_byte
);
4485 amt2_byte
= (end1_byte
- start1_byte
) + (start2_byte
- end1_byte
);
4487 for (marker
= BUF_MARKERS (current_buffer
); marker
; marker
= marker
->next
)
4489 mpos
= marker
->bytepos
;
4490 if (mpos
>= start1_byte
&& mpos
< end2_byte
)
4492 if (mpos
< end1_byte
)
4494 else if (mpos
< start2_byte
)
4498 marker
->bytepos
= mpos
;
4500 mpos
= marker
->charpos
;
4501 if (mpos
>= start1
&& mpos
< end2
)
4505 else if (mpos
< start2
)
4510 marker
->charpos
= mpos
;
4514 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
4515 doc
: /* Transpose region STARTR1 to ENDR1 with STARTR2 to ENDR2.
4516 The regions should not be overlapping, because the size of the buffer is
4517 never changed in a transposition.
4519 Optional fifth arg LEAVE-MARKERS, if non-nil, means don't update
4520 any markers that happen to be located in the regions.
4522 Transposing beyond buffer boundaries is an error. */)
4523 (Lisp_Object startr1
, Lisp_Object endr1
, Lisp_Object startr2
, Lisp_Object endr2
, Lisp_Object leave_markers
)
4525 register ptrdiff_t start1
, end1
, start2
, end2
;
4526 ptrdiff_t start1_byte
, start2_byte
, len1_byte
, len2_byte
;
4527 ptrdiff_t gap
, len1
, len_mid
, len2
;
4528 unsigned char *start1_addr
, *start2_addr
, *temp
;
4530 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
, tmp_interval3
;
4533 XSETBUFFER (buf
, current_buffer
);
4534 cur_intv
= buffer_intervals (current_buffer
);
4536 validate_region (&startr1
, &endr1
);
4537 validate_region (&startr2
, &endr2
);
4539 start1
= XFASTINT (startr1
);
4540 end1
= XFASTINT (endr1
);
4541 start2
= XFASTINT (startr2
);
4542 end2
= XFASTINT (endr2
);
4545 /* Swap the regions if they're reversed. */
4548 register ptrdiff_t glumph
= start1
;
4556 len1
= end1
- start1
;
4557 len2
= end2
- start2
;
4560 error ("Transposed regions overlap");
4561 /* Nothing to change for adjacent regions with one being empty */
4562 else if ((start1
== end1
|| start2
== end2
) && end1
== start2
)
4565 /* The possibilities are:
4566 1. Adjacent (contiguous) regions, or separate but equal regions
4567 (no, really equal, in this case!), or
4568 2. Separate regions of unequal size.
4570 The worst case is usually No. 2. It means that (aside from
4571 potential need for getting the gap out of the way), there also
4572 needs to be a shifting of the text between the two regions. So
4573 if they are spread far apart, we are that much slower... sigh. */
4575 /* It must be pointed out that the really studly thing to do would
4576 be not to move the gap at all, but to leave it in place and work
4577 around it if necessary. This would be extremely efficient,
4578 especially considering that people are likely to do
4579 transpositions near where they are working interactively, which
4580 is exactly where the gap would be found. However, such code
4581 would be much harder to write and to read. So, if you are
4582 reading this comment and are feeling squirrely, by all means have
4583 a go! I just didn't feel like doing it, so I will simply move
4584 the gap the minimum distance to get it out of the way, and then
4585 deal with an unbroken array. */
4587 /* Make sure the gap won't interfere, by moving it out of the text
4588 we will operate on. */
4589 if (start1
< gap
&& gap
< end2
)
4591 if (gap
- start1
< end2
- gap
)
4597 start1_byte
= CHAR_TO_BYTE (start1
);
4598 start2_byte
= CHAR_TO_BYTE (start2
);
4599 len1_byte
= CHAR_TO_BYTE (end1
) - start1_byte
;
4600 len2_byte
= CHAR_TO_BYTE (end2
) - start2_byte
;
4602 #ifdef BYTE_COMBINING_DEBUG
4605 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4606 len2_byte
, start1
, start1_byte
)
4607 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4608 len1_byte
, end2
, start2_byte
+ len2_byte
)
4609 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4610 len1_byte
, end2
, start2_byte
+ len2_byte
))
4615 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4616 len2_byte
, start1
, start1_byte
)
4617 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4618 len1_byte
, start2
, start2_byte
)
4619 || count_combining_after (BYTE_POS_ADDR (start2_byte
),
4620 len2_byte
, end1
, start1_byte
+ len1_byte
)
4621 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4622 len1_byte
, end2
, start2_byte
+ len2_byte
))
4627 /* Hmmm... how about checking to see if the gap is large
4628 enough to use as the temporary storage? That would avoid an
4629 allocation... interesting. Later, don't fool with it now. */
4631 /* Working without memmove, for portability (sigh), so must be
4632 careful of overlapping subsections of the array... */
4634 if (end1
== start2
) /* adjacent regions */
4636 modify_region_1 (start1
, end2
, false);
4637 record_change (start1
, len1
+ len2
);
4639 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4640 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4641 /* Don't use Fset_text_properties: that can cause GC, which can
4642 clobber objects stored in the tmp_intervals. */
4643 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4645 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4647 /* First region smaller than second. */
4648 if (len1_byte
< len2_byte
)
4652 temp
= SAFE_ALLOCA (len2_byte
);
4654 /* Don't precompute these addresses. We have to compute them
4655 at the last minute, because the relocating allocator might
4656 have moved the buffer around during the xmalloc. */
4657 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4658 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4660 memcpy (temp
, start2_addr
, len2_byte
);
4661 memcpy (start1_addr
+ len2_byte
, start1_addr
, len1_byte
);
4662 memcpy (start1_addr
, temp
, len2_byte
);
4666 /* First region not smaller than second. */
4670 temp
= SAFE_ALLOCA (len1_byte
);
4671 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4672 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4673 memcpy (temp
, start1_addr
, len1_byte
);
4674 memcpy (start1_addr
, start2_addr
, len2_byte
);
4675 memcpy (start1_addr
+ len2_byte
, temp
, len1_byte
);
4678 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
4679 len1
, current_buffer
, 0);
4680 graft_intervals_into_buffer (tmp_interval2
, start1
,
4681 len2
, current_buffer
, 0);
4682 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4683 update_compositions (start1
+ len2
, end2
, CHECK_TAIL
);
4685 /* Non-adjacent regions, because end1 != start2, bleagh... */
4688 len_mid
= start2_byte
- (start1_byte
+ len1_byte
);
4690 if (len1_byte
== len2_byte
)
4691 /* Regions are same size, though, how nice. */
4695 modify_region_1 (start1
, end1
, false);
4696 modify_region_1 (start2
, end2
, false);
4697 record_change (start1
, len1
);
4698 record_change (start2
, len2
);
4699 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4700 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4702 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr1
, 0);
4704 set_text_properties_1 (startr1
, endr1
, Qnil
, buf
, tmp_interval3
);
4706 tmp_interval3
= validate_interval_range (buf
, &startr2
, &endr2
, 0);
4708 set_text_properties_1 (startr2
, endr2
, Qnil
, buf
, tmp_interval3
);
4710 temp
= SAFE_ALLOCA (len1_byte
);
4711 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4712 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4713 memcpy (temp
, start1_addr
, len1_byte
);
4714 memcpy (start1_addr
, start2_addr
, len2_byte
);
4715 memcpy (start2_addr
, temp
, len1_byte
);
4718 graft_intervals_into_buffer (tmp_interval1
, start2
,
4719 len1
, current_buffer
, 0);
4720 graft_intervals_into_buffer (tmp_interval2
, start1
,
4721 len2
, current_buffer
, 0);
4724 else if (len1_byte
< len2_byte
) /* Second region larger than first */
4725 /* Non-adjacent & unequal size, area between must also be shifted. */
4729 modify_region_1 (start1
, end2
, false);
4730 record_change (start1
, (end2
- start1
));
4731 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4732 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4733 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4735 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4737 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4739 /* holds region 2 */
4740 temp
= SAFE_ALLOCA (len2_byte
);
4741 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4742 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4743 memcpy (temp
, start2_addr
, len2_byte
);
4744 memcpy (start1_addr
+ len_mid
+ len2_byte
, start1_addr
, len1_byte
);
4745 memmove (start1_addr
+ len2_byte
, start1_addr
+ len1_byte
, len_mid
);
4746 memcpy (start1_addr
, temp
, len2_byte
);
4749 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4750 len1
, current_buffer
, 0);
4751 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4752 len_mid
, current_buffer
, 0);
4753 graft_intervals_into_buffer (tmp_interval2
, start1
,
4754 len2
, current_buffer
, 0);
4757 /* Second region smaller than first. */
4761 record_change (start1
, (end2
- start1
));
4762 modify_region_1 (start1
, end2
, false);
4764 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4765 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4766 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4768 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4770 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4772 /* holds region 1 */
4773 temp
= SAFE_ALLOCA (len1_byte
);
4774 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4775 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4776 memcpy (temp
, start1_addr
, len1_byte
);
4777 memcpy (start1_addr
, start2_addr
, len2_byte
);
4778 memcpy (start1_addr
+ len2_byte
, start1_addr
+ len1_byte
, len_mid
);
4779 memcpy (start1_addr
+ len2_byte
+ len_mid
, temp
, len1_byte
);
4782 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4783 len1
, current_buffer
, 0);
4784 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4785 len_mid
, current_buffer
, 0);
4786 graft_intervals_into_buffer (tmp_interval2
, start1
,
4787 len2
, current_buffer
, 0);
4790 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4791 update_compositions (end2
- len1
, end2
, CHECK_BORDER
);
4794 /* When doing multiple transpositions, it might be nice
4795 to optimize this. Perhaps the markers in any one buffer
4796 should be organized in some sorted data tree. */
4797 if (NILP (leave_markers
))
4799 transpose_markers (start1
, end1
, start2
, end2
,
4800 start1_byte
, start1_byte
+ len1_byte
,
4801 start2_byte
, start2_byte
+ len2_byte
);
4802 fix_start_end_in_overlays (start1
, end2
);
4805 signal_after_change (start1
, end2
- start1
, end2
- start1
);
4811 syms_of_editfns (void)
4813 DEFSYM (Qbuffer_access_fontify_functions
, "buffer-access-fontify-functions");
4815 DEFVAR_LISP ("inhibit-field-text-motion", Vinhibit_field_text_motion
,
4816 doc
: /* Non-nil means text motion commands don't notice fields. */);
4817 Vinhibit_field_text_motion
= Qnil
;
4819 DEFVAR_LISP ("buffer-access-fontify-functions",
4820 Vbuffer_access_fontify_functions
,
4821 doc
: /* List of functions called by `buffer-substring' to fontify if necessary.
4822 Each function is called with two arguments which specify the range
4823 of the buffer being accessed. */);
4824 Vbuffer_access_fontify_functions
= Qnil
;
4828 obuf
= Fcurrent_buffer ();
4829 /* Do this here, because init_buffer_once is too early--it won't work. */
4830 Fset_buffer (Vprin1_to_string_buffer
);
4831 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
4832 Fset (Fmake_local_variable (intern_c_string ("buffer-access-fontify-functions")),
4837 DEFVAR_LISP ("buffer-access-fontified-property",
4838 Vbuffer_access_fontified_property
,
4839 doc
: /* Property which (if non-nil) indicates text has been fontified.
4840 `buffer-substring' need not call the `buffer-access-fontify-functions'
4841 functions if all the text being accessed has this property. */);
4842 Vbuffer_access_fontified_property
= Qnil
;
4844 DEFVAR_LISP ("system-name", Vsystem_name
,
4845 doc
: /* The host name of the machine Emacs is running on. */);
4847 DEFVAR_LISP ("user-full-name", Vuser_full_name
,
4848 doc
: /* The full name of the user logged in. */);
4850 DEFVAR_LISP ("user-login-name", Vuser_login_name
,
4851 doc
: /* The user's name, taken from environment variables if possible. */);
4853 DEFVAR_LISP ("user-real-login-name", Vuser_real_login_name
,
4854 doc
: /* The user's name, based upon the real uid only. */);
4856 DEFVAR_LISP ("operating-system-release", Voperating_system_release
,
4857 doc
: /* The release of the operating system Emacs is running on. */);
4859 defsubr (&Spropertize
);
4860 defsubr (&Schar_equal
);
4861 defsubr (&Sgoto_char
);
4862 defsubr (&Sstring_to_char
);
4863 defsubr (&Schar_to_string
);
4864 defsubr (&Sbyte_to_string
);
4865 defsubr (&Sbuffer_substring
);
4866 defsubr (&Sbuffer_substring_no_properties
);
4867 defsubr (&Sbuffer_string
);
4869 defsubr (&Spoint_marker
);
4870 defsubr (&Smark_marker
);
4872 defsubr (&Sregion_beginning
);
4873 defsubr (&Sregion_end
);
4875 DEFSYM (Qfield
, "field");
4876 DEFSYM (Qboundary
, "boundary");
4877 defsubr (&Sfield_beginning
);
4878 defsubr (&Sfield_end
);
4879 defsubr (&Sfield_string
);
4880 defsubr (&Sfield_string_no_properties
);
4881 defsubr (&Sdelete_field
);
4882 defsubr (&Sconstrain_to_field
);
4884 defsubr (&Sline_beginning_position
);
4885 defsubr (&Sline_end_position
);
4887 /* defsubr (&Smark); */
4888 /* defsubr (&Sset_mark); */
4889 defsubr (&Ssave_excursion
);
4890 defsubr (&Ssave_current_buffer
);
4892 defsubr (&Sbufsize
);
4893 defsubr (&Spoint_max
);
4894 defsubr (&Spoint_min
);
4895 defsubr (&Spoint_min_marker
);
4896 defsubr (&Spoint_max_marker
);
4897 defsubr (&Sgap_position
);
4898 defsubr (&Sgap_size
);
4899 defsubr (&Sposition_bytes
);
4900 defsubr (&Sbyte_to_position
);
4906 defsubr (&Sfollowing_char
);
4907 defsubr (&Sprevious_char
);
4908 defsubr (&Schar_after
);
4909 defsubr (&Schar_before
);
4911 defsubr (&Sinsert_before_markers
);
4912 defsubr (&Sinsert_and_inherit
);
4913 defsubr (&Sinsert_and_inherit_before_markers
);
4914 defsubr (&Sinsert_char
);
4915 defsubr (&Sinsert_byte
);
4917 defsubr (&Suser_login_name
);
4918 defsubr (&Suser_real_login_name
);
4919 defsubr (&Suser_uid
);
4920 defsubr (&Suser_real_uid
);
4921 defsubr (&Sgroup_gid
);
4922 defsubr (&Sgroup_real_gid
);
4923 defsubr (&Suser_full_name
);
4924 defsubr (&Semacs_pid
);
4925 defsubr (&Scurrent_time
);
4926 defsubr (&Sget_internal_run_time
);
4927 defsubr (&Sformat_time_string
);
4928 defsubr (&Sfloat_time
);
4929 defsubr (&Sdecode_time
);
4930 defsubr (&Sencode_time
);
4931 defsubr (&Scurrent_time_string
);
4932 defsubr (&Scurrent_time_zone
);
4933 defsubr (&Sset_time_zone_rule
);
4934 defsubr (&Ssystem_name
);
4935 defsubr (&Smessage
);
4936 defsubr (&Smessage_box
);
4937 defsubr (&Smessage_or_box
);
4938 defsubr (&Scurrent_message
);
4941 defsubr (&Sinsert_buffer_substring
);
4942 defsubr (&Scompare_buffer_substrings
);
4943 defsubr (&Ssubst_char_in_region
);
4944 defsubr (&Stranslate_region_internal
);
4945 defsubr (&Sdelete_region
);
4946 defsubr (&Sdelete_and_extract_region
);
4948 defsubr (&Snarrow_to_region
);
4949 defsubr (&Ssave_restriction
);
4950 defsubr (&Stranspose_regions
);