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
;
86 const char *user_name
;
88 struct passwd
*pw
; /* password entry for the current user */
91 /* Set up system_name even when dumping. */
95 /* Don't bother with this on initial start when just dumping out */
98 #endif /* not CANNOT_DUMP */
100 pw
= getpwuid (getuid ());
102 /* We let the real user name default to "root" because that's quite
103 accurate on MSDOG and because it lets Emacs find the init file.
104 (The DVX libraries override the Djgpp libraries here.) */
105 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "root");
107 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "unknown");
110 /* Get the effective user name, by consulting environment variables,
111 or the effective uid if those are unset. */
112 user_name
= getenv ("LOGNAME");
115 user_name
= getenv ("USERNAME"); /* it's USERNAME on NT */
116 #else /* WINDOWSNT */
117 user_name
= getenv ("USER");
118 #endif /* WINDOWSNT */
121 pw
= getpwuid (geteuid ());
122 user_name
= pw
? pw
->pw_name
: "unknown";
124 Vuser_login_name
= build_string (user_name
);
126 /* If the user name claimed in the environment vars differs from
127 the real uid, use the claimed name to find the full name. */
128 tem
= Fstring_equal (Vuser_login_name
, Vuser_real_login_name
);
130 tem
= Vuser_login_name
;
133 uid_t euid
= geteuid ();
134 tem
= make_fixnum_or_float (euid
);
136 Vuser_full_name
= Fuser_full_name (tem
);
140 Vuser_full_name
= build_string (p
);
141 else if (NILP (Vuser_full_name
))
142 Vuser_full_name
= build_string ("unknown");
144 #ifdef HAVE_SYS_UTSNAME_H
148 Voperating_system_release
= build_string (uts
.release
);
151 Voperating_system_release
= Qnil
;
155 DEFUN ("char-to-string", Fchar_to_string
, Schar_to_string
, 1, 1, 0,
156 doc
: /* Convert arg CHAR to a string containing that character.
157 usage: (char-to-string CHAR) */)
158 (Lisp_Object character
)
161 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
163 CHECK_CHARACTER (character
);
164 c
= XFASTINT (character
);
166 len
= CHAR_STRING (c
, str
);
167 return make_string_from_bytes ((char *) str
, 1, len
);
170 DEFUN ("byte-to-string", Fbyte_to_string
, Sbyte_to_string
, 1, 1, 0,
171 doc
: /* Convert arg BYTE to a unibyte string containing that byte. */)
176 if (XINT (byte
) < 0 || XINT (byte
) > 255)
177 error ("Invalid byte");
179 return make_string_from_bytes ((char *) &b
, 1, 1);
182 DEFUN ("string-to-char", Fstring_to_char
, Sstring_to_char
, 1, 1, 0,
183 doc
: /* Return the first character in STRING. */)
184 (register Lisp_Object string
)
186 register Lisp_Object val
;
187 CHECK_STRING (string
);
190 if (STRING_MULTIBYTE (string
))
191 XSETFASTINT (val
, STRING_CHAR (SDATA (string
)));
193 XSETFASTINT (val
, SREF (string
, 0));
196 XSETFASTINT (val
, 0);
200 DEFUN ("point", Fpoint
, Spoint
, 0, 0, 0,
201 doc
: /* Return value of point, as an integer.
202 Beginning of buffer is position (point-min). */)
206 XSETFASTINT (temp
, PT
);
210 DEFUN ("point-marker", Fpoint_marker
, Spoint_marker
, 0, 0, 0,
211 doc
: /* Return value of point, as a marker object. */)
214 return build_marker (current_buffer
, PT
, PT_BYTE
);
217 DEFUN ("goto-char", Fgoto_char
, Sgoto_char
, 1, 1, "NGoto char: ",
218 doc
: /* Set point to POSITION, a number or marker.
219 Beginning of buffer is position (point-min), end is (point-max).
221 The return value is POSITION. */)
222 (register Lisp_Object position
)
226 if (MARKERP (position
)
227 && current_buffer
== XMARKER (position
)->buffer
)
229 pos
= marker_position (position
);
231 SET_PT_BOTH (BEGV
, BEGV_BYTE
);
233 SET_PT_BOTH (ZV
, ZV_BYTE
);
235 SET_PT_BOTH (pos
, marker_byte_position (position
));
240 CHECK_NUMBER_COERCE_MARKER (position
);
242 pos
= clip_to_bounds (BEGV
, XINT (position
), ZV
);
248 /* Return the start or end position of the region.
249 BEGINNINGP non-zero means return the start.
250 If there is no region active, signal an error. */
253 region_limit (int beginningp
)
257 if (!NILP (Vtransient_mark_mode
)
258 && NILP (Vmark_even_if_inactive
)
259 && NILP (BVAR (current_buffer
, mark_active
)))
260 xsignal0 (Qmark_inactive
);
262 m
= Fmarker_position (BVAR (current_buffer
, mark
));
264 error ("The mark is not set now, so there is no region");
266 /* Clip to the current narrowing (bug#11770). */
267 return make_number ((PT
< XFASTINT (m
)) == (beginningp
!= 0)
269 : clip_to_bounds (BEGV
, XFASTINT (m
), ZV
));
272 DEFUN ("region-beginning", Fregion_beginning
, Sregion_beginning
, 0, 0, 0,
273 doc
: /* Return the integer value of point or mark, whichever is smaller. */)
276 return region_limit (1);
279 DEFUN ("region-end", Fregion_end
, Sregion_end
, 0, 0, 0,
280 doc
: /* Return the integer value of point or mark, whichever is larger. */)
283 return region_limit (0);
286 DEFUN ("mark-marker", Fmark_marker
, Smark_marker
, 0, 0, 0,
287 doc
: /* Return this buffer's mark, as a marker object.
288 Watch out! Moving this marker changes the mark position.
289 If you set the marker not to point anywhere, the buffer will have no mark. */)
292 return BVAR (current_buffer
, mark
);
296 /* Find all the overlays in the current buffer that touch position POS.
297 Return the number found, and store them in a vector in VEC
301 overlays_around (EMACS_INT pos
, Lisp_Object
*vec
, ptrdiff_t len
)
303 Lisp_Object overlay
, start
, end
;
304 struct Lisp_Overlay
*tail
;
305 ptrdiff_t startpos
, endpos
;
308 for (tail
= current_buffer
->overlays_before
; tail
; tail
= tail
->next
)
310 XSETMISC (overlay
, tail
);
312 end
= OVERLAY_END (overlay
);
313 endpos
= OVERLAY_POSITION (end
);
316 start
= OVERLAY_START (overlay
);
317 startpos
= OVERLAY_POSITION (start
);
322 /* Keep counting overlays even if we can't return them all. */
327 for (tail
= current_buffer
->overlays_after
; tail
; tail
= tail
->next
)
329 XSETMISC (overlay
, tail
);
331 start
= OVERLAY_START (overlay
);
332 startpos
= OVERLAY_POSITION (start
);
335 end
= OVERLAY_END (overlay
);
336 endpos
= OVERLAY_POSITION (end
);
348 /* Return the value of property PROP, in OBJECT at POSITION.
349 It's the value of PROP that a char inserted at POSITION would get.
350 OBJECT is optional and defaults to the current buffer.
351 If OBJECT is a buffer, then overlay properties are considered as well as
353 If OBJECT is a window, then that window's buffer is used, but
354 window-specific overlays are considered only if they are associated
357 get_pos_property (Lisp_Object position
, register Lisp_Object prop
, Lisp_Object object
)
359 CHECK_NUMBER_COERCE_MARKER (position
);
362 XSETBUFFER (object
, current_buffer
);
363 else if (WINDOWP (object
))
364 object
= XWINDOW (object
)->buffer
;
366 if (!BUFFERP (object
))
367 /* pos-property only makes sense in buffers right now, since strings
368 have no overlays and no notion of insertion for which stickiness
370 return Fget_text_property (position
, prop
, object
);
373 EMACS_INT posn
= XINT (position
);
375 Lisp_Object
*overlay_vec
, tem
;
376 struct buffer
*obuf
= current_buffer
;
378 set_buffer_temp (XBUFFER (object
));
380 /* First try with room for 40 overlays. */
382 overlay_vec
= alloca (noverlays
* sizeof *overlay_vec
);
383 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
385 /* If there are more than 40,
386 make enough space for all, and try again. */
389 overlay_vec
= alloca (noverlays
* sizeof *overlay_vec
);
390 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
392 noverlays
= sort_overlays (overlay_vec
, noverlays
, NULL
);
394 set_buffer_temp (obuf
);
396 /* Now check the overlays in order of decreasing priority. */
397 while (--noverlays
>= 0)
399 Lisp_Object ol
= overlay_vec
[noverlays
];
400 tem
= Foverlay_get (ol
, prop
);
403 /* Check the overlay is indeed active at point. */
404 Lisp_Object start
= OVERLAY_START (ol
), finish
= OVERLAY_END (ol
);
405 if ((OVERLAY_POSITION (start
) == posn
406 && XMARKER (start
)->insertion_type
== 1)
407 || (OVERLAY_POSITION (finish
) == posn
408 && XMARKER (finish
)->insertion_type
== 0))
409 ; /* The overlay will not cover a char inserted at point. */
417 { /* Now check the text properties. */
418 int stickiness
= text_property_stickiness (prop
, position
, object
);
420 return Fget_text_property (position
, prop
, object
);
421 else if (stickiness
< 0
422 && XINT (position
) > BUF_BEGV (XBUFFER (object
)))
423 return Fget_text_property (make_number (XINT (position
) - 1),
431 /* Find the field surrounding POS in *BEG and *END. If POS is nil,
432 the value of point is used instead. If BEG or END is null,
433 means don't store the beginning or end of the field.
435 BEG_LIMIT and END_LIMIT serve to limit the ranged of the returned
436 results; they do not effect boundary behavior.
438 If MERGE_AT_BOUNDARY is nonzero, then if POS is at the very first
439 position of a field, then the beginning of the previous field is
440 returned instead of the beginning of POS's field (since the end of a
441 field is actually also the beginning of the next input field, this
442 behavior is sometimes useful). Additionally in the MERGE_AT_BOUNDARY
443 true case, if two fields are separated by a field with the special
444 value `boundary', and POS lies within it, then the two separated
445 fields are considered to be adjacent, and POS between them, when
446 finding the beginning and ending of the "merged" field.
448 Either BEG or END may be 0, in which case the corresponding value
452 find_field (Lisp_Object pos
, Lisp_Object merge_at_boundary
,
453 Lisp_Object beg_limit
,
454 ptrdiff_t *beg
, Lisp_Object end_limit
, ptrdiff_t *end
)
456 /* Fields right before and after the point. */
457 Lisp_Object before_field
, after_field
;
458 /* 1 if POS counts as the start of a field. */
459 int at_field_start
= 0;
460 /* 1 if POS counts as the end of a field. */
461 int at_field_end
= 0;
464 XSETFASTINT (pos
, PT
);
466 CHECK_NUMBER_COERCE_MARKER (pos
);
469 = get_char_property_and_overlay (pos
, Qfield
, Qnil
, NULL
);
471 = (XFASTINT (pos
) > BEGV
472 ? get_char_property_and_overlay (make_number (XINT (pos
) - 1),
474 /* Using nil here would be a more obvious choice, but it would
475 fail when the buffer starts with a non-sticky field. */
478 /* See if we need to handle the case where MERGE_AT_BOUNDARY is nil
479 and POS is at beginning of a field, which can also be interpreted
480 as the end of the previous field. Note that the case where if
481 MERGE_AT_BOUNDARY is non-nil (see function comment) is actually the
482 more natural one; then we avoid treating the beginning of a field
484 if (NILP (merge_at_boundary
))
486 Lisp_Object field
= get_pos_property (pos
, Qfield
, Qnil
);
487 if (!EQ (field
, after_field
))
489 if (!EQ (field
, before_field
))
491 if (NILP (field
) && at_field_start
&& at_field_end
)
492 /* If an inserted char would have a nil field while the surrounding
493 text is non-nil, we're probably not looking at a
494 zero-length field, but instead at a non-nil field that's
495 not intended for editing (such as comint's prompts). */
496 at_field_end
= at_field_start
= 0;
499 /* Note about special `boundary' fields:
501 Consider the case where the point (`.') is between the fields `x' and `y':
505 In this situation, if merge_at_boundary is true, we consider the
506 `x' and `y' fields as forming one big merged field, and so the end
507 of the field is the end of `y'.
509 However, if `x' and `y' are separated by a special `boundary' field
510 (a field with a `field' char-property of 'boundary), then we ignore
511 this special field when merging adjacent fields. Here's the same
512 situation, but with a `boundary' field between the `x' and `y' fields:
516 Here, if point is at the end of `x', the beginning of `y', or
517 anywhere in-between (within the `boundary' field), we merge all
518 three fields and consider the beginning as being the beginning of
519 the `x' field, and the end as being the end of the `y' field. */
524 /* POS is at the edge of a field, and we should consider it as
525 the beginning of the following field. */
526 *beg
= XFASTINT (pos
);
528 /* Find the previous field boundary. */
531 if (!NILP (merge_at_boundary
) && EQ (before_field
, Qboundary
))
532 /* Skip a `boundary' field. */
533 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
536 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
538 *beg
= NILP (p
) ? BEGV
: XFASTINT (p
);
545 /* POS is at the edge of a field, and we should consider it as
546 the end of the previous field. */
547 *end
= XFASTINT (pos
);
549 /* Find the next field boundary. */
551 if (!NILP (merge_at_boundary
) && EQ (after_field
, Qboundary
))
552 /* Skip a `boundary' field. */
553 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
556 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
558 *end
= NILP (pos
) ? ZV
: XFASTINT (pos
);
564 DEFUN ("delete-field", Fdelete_field
, Sdelete_field
, 0, 1, 0,
565 doc
: /* Delete the field surrounding POS.
566 A field is a region of text with the same `field' property.
567 If POS is nil, the value of point is used for POS. */)
571 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
573 del_range (beg
, end
);
577 DEFUN ("field-string", Ffield_string
, Sfield_string
, 0, 1, 0,
578 doc
: /* Return the contents of the field surrounding POS as a string.
579 A field is a region of text with the same `field' property.
580 If POS is nil, the value of point is used for POS. */)
584 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
585 return make_buffer_string (beg
, end
, 1);
588 DEFUN ("field-string-no-properties", Ffield_string_no_properties
, Sfield_string_no_properties
, 0, 1, 0,
589 doc
: /* Return the contents of the field around POS, without text properties.
590 A field is a region of text with the same `field' property.
591 If POS is nil, the value of point is used for POS. */)
595 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
596 return make_buffer_string (beg
, end
, 0);
599 DEFUN ("field-beginning", Ffield_beginning
, Sfield_beginning
, 0, 3, 0,
600 doc
: /* Return the beginning of the field surrounding POS.
601 A field is a region of text with the same `field' property.
602 If POS is nil, the value of point is used for POS.
603 If ESCAPE-FROM-EDGE is non-nil and POS is at the beginning of its
604 field, then the beginning of the *previous* field is returned.
605 If LIMIT is non-nil, it is a buffer position; if the beginning of the field
606 is before LIMIT, then LIMIT will be returned instead. */)
607 (Lisp_Object pos
, Lisp_Object escape_from_edge
, Lisp_Object limit
)
610 find_field (pos
, escape_from_edge
, limit
, &beg
, Qnil
, 0);
611 return make_number (beg
);
614 DEFUN ("field-end", Ffield_end
, Sfield_end
, 0, 3, 0,
615 doc
: /* Return the end of the field surrounding POS.
616 A field is a region of text with the same `field' property.
617 If POS is nil, the value of point is used for POS.
618 If ESCAPE-FROM-EDGE is non-nil and POS is at the end of its field,
619 then the end of the *following* field is returned.
620 If LIMIT is non-nil, it is a buffer position; if the end of the field
621 is after LIMIT, then LIMIT will be returned instead. */)
622 (Lisp_Object pos
, Lisp_Object escape_from_edge
, Lisp_Object limit
)
625 find_field (pos
, escape_from_edge
, Qnil
, 0, limit
, &end
);
626 return make_number (end
);
629 DEFUN ("constrain-to-field", Fconstrain_to_field
, Sconstrain_to_field
, 2, 5, 0,
630 doc
: /* Return the position closest to NEW-POS that is in the same field as OLD-POS.
631 A field is a region of text with the same `field' property.
633 If NEW-POS is nil, then use the current point instead, and move point
634 to the resulting constrained position, in addition to returning that
637 If OLD-POS is at the boundary of two fields, then the allowable
638 positions for NEW-POS depends on the value of the optional argument
639 ESCAPE-FROM-EDGE: If ESCAPE-FROM-EDGE is nil, then NEW-POS is
640 constrained to the field that has the same `field' char-property
641 as any new characters inserted at OLD-POS, whereas if ESCAPE-FROM-EDGE
642 is non-nil, NEW-POS is constrained to the union of the two adjacent
643 fields. Additionally, if two fields are separated by another field with
644 the special value `boundary', then any point within this special field is
645 also considered to be `on the boundary'.
647 If the optional argument ONLY-IN-LINE is non-nil and constraining
648 NEW-POS would move it to a different line, NEW-POS is returned
649 unconstrained. This useful for commands that move by line, like
650 \\[next-line] or \\[beginning-of-line], which should generally respect field boundaries
651 only in the case where they can still move to the right line.
653 If the optional argument INHIBIT-CAPTURE-PROPERTY is non-nil, and OLD-POS has
654 a non-nil property of that name, then any field boundaries are ignored.
656 Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */)
657 (Lisp_Object new_pos
, Lisp_Object old_pos
, Lisp_Object escape_from_edge
, Lisp_Object only_in_line
, Lisp_Object inhibit_capture_property
)
659 /* If non-zero, then the original point, before re-positioning. */
660 ptrdiff_t orig_point
= 0;
662 Lisp_Object prev_old
, prev_new
;
665 /* Use the current point, and afterwards, set it. */
668 XSETFASTINT (new_pos
, PT
);
671 CHECK_NUMBER_COERCE_MARKER (new_pos
);
672 CHECK_NUMBER_COERCE_MARKER (old_pos
);
674 fwd
= (XINT (new_pos
) > XINT (old_pos
));
676 prev_old
= make_number (XINT (old_pos
) - 1);
677 prev_new
= make_number (XINT (new_pos
) - 1);
679 if (NILP (Vinhibit_field_text_motion
)
680 && !EQ (new_pos
, old_pos
)
681 && (!NILP (Fget_char_property (new_pos
, Qfield
, Qnil
))
682 || !NILP (Fget_char_property (old_pos
, Qfield
, Qnil
))
683 /* To recognize field boundaries, we must also look at the
684 previous positions; we could use `get_pos_property'
685 instead, but in itself that would fail inside non-sticky
686 fields (like comint prompts). */
687 || (XFASTINT (new_pos
) > BEGV
688 && !NILP (Fget_char_property (prev_new
, Qfield
, Qnil
)))
689 || (XFASTINT (old_pos
) > BEGV
690 && !NILP (Fget_char_property (prev_old
, Qfield
, Qnil
))))
691 && (NILP (inhibit_capture_property
)
692 /* Field boundaries are again a problem; but now we must
693 decide the case exactly, so we need to call
694 `get_pos_property' as well. */
695 || (NILP (get_pos_property (old_pos
, inhibit_capture_property
, Qnil
))
696 && (XFASTINT (old_pos
) <= BEGV
697 || NILP (Fget_char_property (old_pos
, inhibit_capture_property
, Qnil
))
698 || NILP (Fget_char_property (prev_old
, inhibit_capture_property
, Qnil
))))))
699 /* It is possible that NEW_POS is not within the same field as
700 OLD_POS; try to move NEW_POS so that it is. */
703 Lisp_Object field_bound
;
706 field_bound
= Ffield_end (old_pos
, escape_from_edge
, new_pos
);
708 field_bound
= Ffield_beginning (old_pos
, escape_from_edge
, new_pos
);
710 if (/* See if ESCAPE_FROM_EDGE caused FIELD_BOUND to jump to the
711 other side of NEW_POS, which would mean that NEW_POS is
712 already acceptable, and it's not necessary to constrain it
714 ((XFASTINT (field_bound
) < XFASTINT (new_pos
)) ? fwd
: !fwd
)
715 /* NEW_POS should be constrained, but only if either
716 ONLY_IN_LINE is nil (in which case any constraint is OK),
717 or NEW_POS and FIELD_BOUND are on the same line (in which
718 case the constraint is OK even if ONLY_IN_LINE is non-nil). */
719 && (NILP (only_in_line
)
720 /* This is the ONLY_IN_LINE case, check that NEW_POS and
721 FIELD_BOUND are on the same line by seeing whether
722 there's an intervening newline or not. */
723 || (scan_buffer ('\n',
724 XFASTINT (new_pos
), XFASTINT (field_bound
),
725 fwd
? -1 : 1, &shortage
, 1),
727 /* Constrain NEW_POS to FIELD_BOUND. */
728 new_pos
= field_bound
;
730 if (orig_point
&& XFASTINT (new_pos
) != orig_point
)
731 /* The NEW_POS argument was originally nil, so automatically set PT. */
732 SET_PT (XFASTINT (new_pos
));
739 DEFUN ("line-beginning-position",
740 Fline_beginning_position
, Sline_beginning_position
, 0, 1, 0,
741 doc
: /* Return the character position of the first character on the current line.
742 With argument N not nil or 1, move forward N - 1 lines first.
743 If scan reaches end of buffer, return that position.
745 The returned position is of the first character in the logical order,
746 i.e. the one that has the smallest character position.
748 This function constrains the returned position to the current field
749 unless that would be on a different line than the original,
750 unconstrained result. If N is nil or 1, and a front-sticky field
751 starts at point, the scan stops as soon as it starts. To ignore field
752 boundaries bind `inhibit-field-text-motion' to t.
754 This function does not move point. */)
757 ptrdiff_t orig
, orig_byte
, end
;
758 ptrdiff_t count
= SPECPDL_INDEX ();
759 specbind (Qinhibit_point_motion_hooks
, Qt
);
768 Fforward_line (make_number (XINT (n
) - 1));
771 SET_PT_BOTH (orig
, orig_byte
);
773 unbind_to (count
, Qnil
);
775 /* Return END constrained to the current input field. */
776 return Fconstrain_to_field (make_number (end
), make_number (orig
),
777 XINT (n
) != 1 ? Qt
: Qnil
,
781 DEFUN ("line-end-position", Fline_end_position
, Sline_end_position
, 0, 1, 0,
782 doc
: /* Return the character position of the last character on the current line.
783 With argument N not nil or 1, move forward N - 1 lines first.
784 If scan reaches end of buffer, return that position.
786 The returned position is of the last character in the logical order,
787 i.e. the character whose buffer position is the largest one.
789 This function constrains the returned position to the current field
790 unless that would be on a different line than the original,
791 unconstrained result. If N is nil or 1, and a rear-sticky field ends
792 at point, the scan stops as soon as it starts. To ignore field
793 boundaries bind `inhibit-field-text-motion' to t.
795 This function does not move point. */)
807 clipped_n
= clip_to_bounds (PTRDIFF_MIN
+ 1, XINT (n
), PTRDIFF_MAX
);
808 end_pos
= find_before_next_newline (orig
, 0, clipped_n
- (clipped_n
<= 0));
810 /* Return END_POS constrained to the current input field. */
811 return Fconstrain_to_field (make_number (end_pos
), make_number (orig
),
817 save_excursion_save (void)
819 int visible
= (XBUFFER (XWINDOW (selected_window
)->buffer
)
822 return Fcons (Fpoint_marker (),
823 Fcons (Fcopy_marker (BVAR (current_buffer
, mark
), Qnil
),
824 Fcons (visible
? Qt
: Qnil
,
825 Fcons (BVAR (current_buffer
, mark_active
),
830 save_excursion_restore (Lisp_Object info
)
832 Lisp_Object tem
, tem1
, omark
, nmark
;
833 struct gcpro gcpro1
, gcpro2
, gcpro3
;
836 tem
= Fmarker_buffer (XCAR (info
));
837 /* If buffer being returned to is now deleted, avoid error */
838 /* Otherwise could get error here while unwinding to top level
840 /* In that case, Fmarker_buffer returns nil now. */
844 omark
= nmark
= Qnil
;
845 GCPRO3 (info
, omark
, nmark
);
852 unchain_marker (XMARKER (tem
));
857 omark
= Fmarker_position (BVAR (current_buffer
, mark
));
858 Fset_marker (BVAR (current_buffer
, mark
), tem
, Fcurrent_buffer ());
859 nmark
= Fmarker_position (tem
);
860 unchain_marker (XMARKER (tem
));
864 visible_p
= !NILP (XCAR (info
));
866 #if 0 /* We used to make the current buffer visible in the selected window
867 if that was true previously. That avoids some anomalies.
868 But it creates others, and it wasn't documented, and it is simpler
869 and cleaner never to alter the window/buffer connections. */
872 && current_buffer
!= XBUFFER (XWINDOW (selected_window
)->buffer
))
873 Fswitch_to_buffer (Fcurrent_buffer (), Qnil
);
879 tem1
= BVAR (current_buffer
, mark_active
);
880 bset_mark_active (current_buffer
, tem
);
882 /* If mark is active now, and either was not active
883 or was at a different place, run the activate hook. */
886 if (! EQ (omark
, nmark
))
888 tem
= intern ("activate-mark-hook");
889 Frun_hooks (1, &tem
);
892 /* If mark has ceased to be active, run deactivate hook. */
893 else if (! NILP (tem1
))
895 tem
= intern ("deactivate-mark-hook");
896 Frun_hooks (1, &tem
);
899 /* If buffer was visible in a window, and a different window was
900 selected, and the old selected window is still showing this
901 buffer, restore point in that window. */
904 && !EQ (tem
, selected_window
)
905 && (tem1
= XWINDOW (tem
)->buffer
,
906 (/* Window is live... */
908 /* ...and it shows the current buffer. */
909 && XBUFFER (tem1
) == current_buffer
)))
910 Fset_window_point (tem
, make_number (PT
));
916 DEFUN ("save-excursion", Fsave_excursion
, Ssave_excursion
, 0, UNEVALLED
, 0,
917 doc
: /* Save point, mark, and current buffer; execute BODY; restore those things.
918 Executes BODY just like `progn'.
919 The values of point, mark and the current buffer are restored
920 even in case of abnormal exit (throw or error).
921 The state of activation of the mark is also restored.
923 This construct does not save `deactivate-mark', and therefore
924 functions that change the buffer will still cause deactivation
925 of the mark at the end of the command. To prevent that, bind
926 `deactivate-mark' with `let'.
928 If you only want to save the current buffer but not point nor mark,
929 then just use `save-current-buffer', or even `with-current-buffer'.
931 usage: (save-excursion &rest BODY) */)
934 register Lisp_Object val
;
935 ptrdiff_t count
= SPECPDL_INDEX ();
937 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
940 return unbind_to (count
, val
);
943 DEFUN ("save-current-buffer", Fsave_current_buffer
, Ssave_current_buffer
, 0, UNEVALLED
, 0,
944 doc
: /* Record which buffer is current; execute BODY; make that buffer current.
945 BODY is executed just like `progn'.
946 usage: (save-current-buffer &rest BODY) */)
949 ptrdiff_t count
= SPECPDL_INDEX ();
951 record_unwind_current_buffer ();
952 return unbind_to (count
, Fprogn (args
));
955 DEFUN ("buffer-size", Fbufsize
, Sbufsize
, 0, 1, 0,
956 doc
: /* Return the number of characters in the current buffer.
957 If BUFFER, return the number of characters in that buffer instead. */)
961 return make_number (Z
- BEG
);
964 CHECK_BUFFER (buffer
);
965 return make_number (BUF_Z (XBUFFER (buffer
))
966 - BUF_BEG (XBUFFER (buffer
)));
970 DEFUN ("point-min", Fpoint_min
, Spoint_min
, 0, 0, 0,
971 doc
: /* Return the minimum permissible value of point in the current buffer.
972 This is 1, unless narrowing (a buffer restriction) is in effect. */)
976 XSETFASTINT (temp
, BEGV
);
980 DEFUN ("point-min-marker", Fpoint_min_marker
, Spoint_min_marker
, 0, 0, 0,
981 doc
: /* Return a marker to the minimum permissible value of point in this buffer.
982 This is the beginning, unless narrowing (a buffer restriction) is in effect. */)
985 return build_marker (current_buffer
, BEGV
, BEGV_BYTE
);
988 DEFUN ("point-max", Fpoint_max
, Spoint_max
, 0, 0, 0,
989 doc
: /* Return the maximum permissible value of point in the current buffer.
990 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
991 is in effect, in which case it is less. */)
995 XSETFASTINT (temp
, ZV
);
999 DEFUN ("point-max-marker", Fpoint_max_marker
, Spoint_max_marker
, 0, 0, 0,
1000 doc
: /* Return a marker to the maximum permissible value of point in this buffer.
1001 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1002 is in effect, in which case it is less. */)
1005 return build_marker (current_buffer
, ZV
, ZV_BYTE
);
1008 DEFUN ("gap-position", Fgap_position
, Sgap_position
, 0, 0, 0,
1009 doc
: /* Return the position of the gap, in the current buffer.
1010 See also `gap-size'. */)
1014 XSETFASTINT (temp
, GPT
);
1018 DEFUN ("gap-size", Fgap_size
, Sgap_size
, 0, 0, 0,
1019 doc
: /* Return the size of the current buffer's gap.
1020 See also `gap-position'. */)
1024 XSETFASTINT (temp
, GAP_SIZE
);
1028 DEFUN ("position-bytes", Fposition_bytes
, Sposition_bytes
, 1, 1, 0,
1029 doc
: /* Return the byte position for character position POSITION.
1030 If POSITION is out of range, the value is nil. */)
1031 (Lisp_Object position
)
1033 CHECK_NUMBER_COERCE_MARKER (position
);
1034 if (XINT (position
) < BEG
|| XINT (position
) > Z
)
1036 return make_number (CHAR_TO_BYTE (XINT (position
)));
1039 DEFUN ("byte-to-position", Fbyte_to_position
, Sbyte_to_position
, 1, 1, 0,
1040 doc
: /* Return the character position for byte position BYTEPOS.
1041 If BYTEPOS is out of range, the value is nil. */)
1042 (Lisp_Object bytepos
)
1044 CHECK_NUMBER (bytepos
);
1045 if (XINT (bytepos
) < BEG_BYTE
|| XINT (bytepos
) > Z_BYTE
)
1047 return make_number (BYTE_TO_CHAR (XINT (bytepos
)));
1050 DEFUN ("following-char", Ffollowing_char
, Sfollowing_char
, 0, 0, 0,
1051 doc
: /* Return the character following point, as a number.
1052 At the end of the buffer or accessible region, return 0. */)
1057 XSETFASTINT (temp
, 0);
1059 XSETFASTINT (temp
, FETCH_CHAR (PT_BYTE
));
1063 DEFUN ("preceding-char", Fprevious_char
, Sprevious_char
, 0, 0, 0,
1064 doc
: /* Return the character preceding point, as a number.
1065 At the beginning of the buffer or accessible region, return 0. */)
1070 XSETFASTINT (temp
, 0);
1071 else if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
1073 ptrdiff_t pos
= PT_BYTE
;
1075 XSETFASTINT (temp
, FETCH_CHAR (pos
));
1078 XSETFASTINT (temp
, FETCH_BYTE (PT_BYTE
- 1));
1082 DEFUN ("bobp", Fbobp
, Sbobp
, 0, 0, 0,
1083 doc
: /* Return t if point is at the beginning of the buffer.
1084 If the buffer is narrowed, this means the beginning of the narrowed part. */)
1092 DEFUN ("eobp", Feobp
, Seobp
, 0, 0, 0,
1093 doc
: /* Return t if point is at the end of the buffer.
1094 If the buffer is narrowed, this means the end of the narrowed part. */)
1102 DEFUN ("bolp", Fbolp
, Sbolp
, 0, 0, 0,
1103 doc
: /* Return t if point is at the beginning of a line. */)
1106 if (PT
== BEGV
|| FETCH_BYTE (PT_BYTE
- 1) == '\n')
1111 DEFUN ("eolp", Feolp
, Seolp
, 0, 0, 0,
1112 doc
: /* Return t if point is at the end of a line.
1113 `End of a line' includes point being at the end of the buffer. */)
1116 if (PT
== ZV
|| FETCH_BYTE (PT_BYTE
) == '\n')
1121 DEFUN ("char-after", Fchar_after
, Schar_after
, 0, 1, 0,
1122 doc
: /* Return character in current buffer at position POS.
1123 POS is an integer or a marker and defaults to point.
1124 If POS is out of range, the value is nil. */)
1127 register ptrdiff_t pos_byte
;
1132 XSETFASTINT (pos
, PT
);
1137 pos_byte
= marker_byte_position (pos
);
1138 if (pos_byte
< BEGV_BYTE
|| pos_byte
>= ZV_BYTE
)
1143 CHECK_NUMBER_COERCE_MARKER (pos
);
1144 if (XINT (pos
) < BEGV
|| XINT (pos
) >= ZV
)
1147 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1150 return make_number (FETCH_CHAR (pos_byte
));
1153 DEFUN ("char-before", Fchar_before
, Schar_before
, 0, 1, 0,
1154 doc
: /* Return character in current buffer preceding position POS.
1155 POS is an integer or a marker and defaults to point.
1156 If POS is out of range, the value is nil. */)
1159 register Lisp_Object val
;
1160 register ptrdiff_t pos_byte
;
1165 XSETFASTINT (pos
, PT
);
1170 pos_byte
= marker_byte_position (pos
);
1172 if (pos_byte
<= BEGV_BYTE
|| pos_byte
> ZV_BYTE
)
1177 CHECK_NUMBER_COERCE_MARKER (pos
);
1179 if (XINT (pos
) <= BEGV
|| XINT (pos
) > ZV
)
1182 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1185 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
1188 XSETFASTINT (val
, FETCH_CHAR (pos_byte
));
1193 XSETFASTINT (val
, FETCH_BYTE (pos_byte
));
1198 DEFUN ("user-login-name", Fuser_login_name
, Suser_login_name
, 0, 1, 0,
1199 doc
: /* Return the name under which the user logged in, as a string.
1200 This is based on the effective uid, not the real uid.
1201 Also, if the environment variables LOGNAME or USER are set,
1202 that determines the value of this function.
1204 If optional argument UID is an integer or a float, return the login name
1205 of the user with that uid, or nil if there is no such user. */)
1211 /* Set up the user name info if we didn't do it before.
1212 (That can happen if Emacs is dumpable
1213 but you decide to run `temacs -l loadup' and not dump. */
1214 if (INTEGERP (Vuser_login_name
))
1218 return Vuser_login_name
;
1220 CONS_TO_INTEGER (uid
, uid_t
, id
);
1224 return (pw
? build_string (pw
->pw_name
) : Qnil
);
1227 DEFUN ("user-real-login-name", Fuser_real_login_name
, Suser_real_login_name
,
1229 doc
: /* Return the name of the user's real uid, as a string.
1230 This ignores the environment variables LOGNAME and USER, so it differs from
1231 `user-login-name' when running under `su'. */)
1234 /* Set up the user name info if we didn't do it before.
1235 (That can happen if Emacs is dumpable
1236 but you decide to run `temacs -l loadup' and not dump. */
1237 if (INTEGERP (Vuser_login_name
))
1239 return Vuser_real_login_name
;
1242 DEFUN ("user-uid", Fuser_uid
, Suser_uid
, 0, 0, 0,
1243 doc
: /* Return the effective uid of Emacs.
1244 Value is an integer or a float, depending on the value. */)
1247 uid_t euid
= geteuid ();
1248 return make_fixnum_or_float (euid
);
1251 DEFUN ("user-real-uid", Fuser_real_uid
, Suser_real_uid
, 0, 0, 0,
1252 doc
: /* Return the real uid of Emacs.
1253 Value is an integer or a float, depending on the value. */)
1256 uid_t uid
= getuid ();
1257 return make_fixnum_or_float (uid
);
1260 DEFUN ("user-full-name", Fuser_full_name
, Suser_full_name
, 0, 1, 0,
1261 doc
: /* Return the full name of the user logged in, as a string.
1262 If the full name corresponding to Emacs's userid is not known,
1265 If optional argument UID is an integer or float, return the full name
1266 of the user with that uid, or nil if there is no such user.
1267 If UID is a string, return the full name of the user with that login
1268 name, or nil if there is no such user. */)
1272 register char *p
, *q
;
1276 return Vuser_full_name
;
1277 else if (NUMBERP (uid
))
1280 CONS_TO_INTEGER (uid
, uid_t
, u
);
1285 else if (STRINGP (uid
))
1288 pw
= getpwnam (SSDATA (uid
));
1292 error ("Invalid UID specification");
1298 /* Chop off everything after the first comma. */
1299 q
= strchr (p
, ',');
1300 full
= make_string (p
, q
? q
- p
: strlen (p
));
1302 #ifdef AMPERSAND_FULL_NAME
1304 q
= strchr (p
, '&');
1305 /* Substitute the login name for the &, upcasing the first character. */
1311 login
= Fuser_login_name (make_number (pw
->pw_uid
));
1312 r
= alloca (strlen (p
) + SCHARS (login
) + 1);
1313 memcpy (r
, p
, q
- p
);
1315 strcat (r
, SSDATA (login
));
1316 r
[q
- p
] = upcase ((unsigned char) r
[q
- p
]);
1318 full
= build_string (r
);
1320 #endif /* AMPERSAND_FULL_NAME */
1325 DEFUN ("system-name", Fsystem_name
, Ssystem_name
, 0, 0, 0,
1326 doc
: /* Return the host name of the machine you are running on, as a string. */)
1329 return Vsystem_name
;
1333 get_system_name (void)
1335 if (STRINGP (Vsystem_name
))
1336 return SSDATA (Vsystem_name
);
1341 DEFUN ("emacs-pid", Femacs_pid
, Semacs_pid
, 0, 0, 0,
1342 doc
: /* Return the process ID of Emacs, as a number. */)
1345 pid_t pid
= getpid ();
1346 return make_fixnum_or_float (pid
);
1352 # define TIME_T_MIN TYPE_MINIMUM (time_t)
1355 # define TIME_T_MAX TYPE_MAXIMUM (time_t)
1358 /* Report that a time value is out of range for Emacs. */
1360 time_overflow (void)
1362 error ("Specified time is not representable");
1365 /* Return the upper part of the time T (everything but the bottom 16 bits). */
1369 time_t hi
= t
>> 16;
1371 /* Check for overflow, helping the compiler for common cases where
1372 no runtime check is needed, and taking care not to convert
1373 negative numbers to unsigned before comparing them. */
1374 if (! ((! TYPE_SIGNED (time_t)
1375 || MOST_NEGATIVE_FIXNUM
<= TIME_T_MIN
>> 16
1376 || MOST_NEGATIVE_FIXNUM
<= hi
)
1377 && (TIME_T_MAX
>> 16 <= MOST_POSITIVE_FIXNUM
1378 || hi
<= MOST_POSITIVE_FIXNUM
)))
1384 /* Return the bottom 16 bits of the time T. */
1388 return t
& ((1 << 16) - 1);
1391 DEFUN ("current-time", Fcurrent_time
, Scurrent_time
, 0, 0, 0,
1392 doc
: /* Return the current time, as the number of seconds since 1970-01-01 00:00:00.
1393 The time is returned as a list of integers (HIGH LOW USEC PSEC).
1394 HIGH has the most significant bits of the seconds, while LOW has the
1395 least significant 16 bits. USEC and PSEC are the microsecond and
1396 picosecond counts. */)
1399 return make_lisp_time (current_emacs_time ());
1402 DEFUN ("get-internal-run-time", Fget_internal_run_time
, Sget_internal_run_time
,
1404 doc
: /* Return the current run time used by Emacs.
1405 The time is returned as a list (HIGH LOW USEC PSEC), using the same
1406 style as (current-time).
1408 On systems that can't determine the run time, `get-internal-run-time'
1409 does the same thing as `current-time'. */)
1412 #ifdef HAVE_GETRUSAGE
1413 struct rusage usage
;
1417 if (getrusage (RUSAGE_SELF
, &usage
) < 0)
1418 /* This shouldn't happen. What action is appropriate? */
1421 /* Sum up user time and system time. */
1422 secs
= usage
.ru_utime
.tv_sec
+ usage
.ru_stime
.tv_sec
;
1423 usecs
= usage
.ru_utime
.tv_usec
+ usage
.ru_stime
.tv_usec
;
1424 if (usecs
>= 1000000)
1429 return make_lisp_time (make_emacs_time (secs
, usecs
* 1000));
1430 #else /* ! HAVE_GETRUSAGE */
1432 return w32_get_internal_run_time ();
1433 #else /* ! WINDOWSNT */
1434 return Fcurrent_time ();
1435 #endif /* WINDOWSNT */
1436 #endif /* HAVE_GETRUSAGE */
1440 /* Make a Lisp list that represents the time T with fraction TAIL. */
1442 make_time_tail (time_t t
, Lisp_Object tail
)
1444 return Fcons (make_number (hi_time (t
)),
1445 Fcons (make_number (lo_time (t
)), tail
));
1448 /* Make a Lisp list that represents the system time T. */
1450 make_time (time_t t
)
1452 return make_time_tail (t
, Qnil
);
1455 /* Make a Lisp list that represents the Emacs time T. T may be an
1456 invalid time, with a slightly negative tv_nsec value such as
1457 UNKNOWN_MODTIME_NSECS; in that case, the Lisp list contains a
1458 correspondingly negative picosecond count. */
1460 make_lisp_time (EMACS_TIME t
)
1462 int ns
= EMACS_NSECS (t
);
1463 return make_time_tail (EMACS_SECS (t
),
1464 list2 (make_number (ns
/ 1000),
1465 make_number (ns
% 1000 * 1000)));
1468 /* Decode a Lisp list SPECIFIED_TIME that represents a time.
1469 Set *PHIGH, *PLOW, *PUSEC, *PPSEC to its parts; do not check their values.
1470 Return nonzero if successful. */
1472 disassemble_lisp_time (Lisp_Object specified_time
, Lisp_Object
*phigh
,
1473 Lisp_Object
*plow
, Lisp_Object
*pusec
,
1476 if (CONSP (specified_time
))
1478 Lisp_Object low
= XCDR (specified_time
);
1479 Lisp_Object usec
= make_number (0);
1480 Lisp_Object psec
= make_number (0);
1483 Lisp_Object low_tail
= XCDR (low
);
1485 if (CONSP (low_tail
))
1487 usec
= XCAR (low_tail
);
1488 low_tail
= XCDR (low_tail
);
1489 if (CONSP (low_tail
))
1490 psec
= XCAR (low_tail
);
1492 else if (!NILP (low_tail
))
1496 *phigh
= XCAR (specified_time
);
1506 /* From the time components HIGH, LOW, USEC and PSEC taken from a Lisp
1507 list, generate the corresponding time value.
1509 If RESULT is not null, store into *RESULT the converted time;
1510 this can fail if the converted time does not fit into EMACS_TIME.
1511 If *DRESULT is not null, store into *DRESULT the number of
1512 seconds since the start of the POSIX Epoch.
1514 Return nonzero if successful. */
1516 decode_time_components (Lisp_Object high
, Lisp_Object low
, Lisp_Object usec
,
1518 EMACS_TIME
*result
, double *dresult
)
1520 EMACS_INT hi
, lo
, us
, ps
;
1521 if (! (INTEGERP (high
) && INTEGERP (low
)
1522 && INTEGERP (usec
) && INTEGERP (psec
)))
1529 /* Normalize out-of-range lower-order components by carrying
1530 each overflow into the next higher-order component. */
1531 us
+= ps
/ 1000000 - (ps
% 1000000 < 0);
1532 lo
+= us
/ 1000000 - (us
% 1000000 < 0);
1534 ps
= ps
% 1000000 + 1000000 * (ps
% 1000000 < 0);
1535 us
= us
% 1000000 + 1000000 * (us
% 1000000 < 0);
1536 lo
&= (1 << 16) - 1;
1540 if ((TYPE_SIGNED (time_t) ? TIME_T_MIN
>> 16 <= hi
: 0 <= hi
)
1541 && hi
<= TIME_T_MAX
>> 16)
1543 /* Return the greatest representable time that is not greater
1544 than the requested time. */
1546 *result
= make_emacs_time ((sec
<< 16) + lo
, us
* 1000 + ps
/ 1000);
1550 /* Overflow in the highest-order component. */
1556 *dresult
= (us
* 1e6
+ ps
) / 1e12
+ lo
+ hi
* 65536.0;
1561 /* Decode a Lisp list SPECIFIED_TIME that represents a time.
1562 If SPECIFIED_TIME is nil, use the current time.
1564 Round the time down to the nearest EMACS_TIME value.
1565 Return seconds since the Epoch.
1566 Signal an error if unsuccessful. */
1568 lisp_time_argument (Lisp_Object specified_time
)
1571 if (NILP (specified_time
))
1572 t
= current_emacs_time ();
1575 Lisp_Object high
, low
, usec
, psec
;
1576 if (! (disassemble_lisp_time (specified_time
, &high
, &low
, &usec
, &psec
)
1577 && decode_time_components (high
, low
, usec
, psec
, &t
, 0)))
1578 error ("Invalid time specification");
1583 /* Like lisp_time_argument, except decode only the seconds part,
1584 do not allow out-of-range time stamps, do not check the subseconds part,
1585 and always round down. */
1587 lisp_seconds_argument (Lisp_Object specified_time
)
1589 if (NILP (specified_time
))
1593 Lisp_Object high
, low
, usec
, psec
;
1595 if (! (disassemble_lisp_time (specified_time
, &high
, &low
, &usec
, &psec
)
1596 && decode_time_components (high
, low
, make_number (0),
1597 make_number (0), &t
, 0)))
1598 error ("Invalid time specification");
1599 return EMACS_SECS (t
);
1603 DEFUN ("float-time", Ffloat_time
, Sfloat_time
, 0, 1, 0,
1604 doc
: /* Return the current time, as a float number of seconds since the epoch.
1605 If SPECIFIED-TIME is given, it is the time to convert to float
1606 instead of the current time. The argument should have the form
1607 (HIGH LOW) or (HIGH LOW USEC) or (HIGH LOW USEC PSEC). Thus,
1608 you can use times from `current-time' and from `file-attributes'.
1609 SPECIFIED-TIME can also have the form (HIGH . LOW), but this is
1610 considered obsolete.
1612 WARNING: Since the result is floating point, it may not be exact.
1613 If precise time stamps are required, use either `current-time',
1614 or (if you need time as a string) `format-time-string'. */)
1615 (Lisp_Object specified_time
)
1618 if (NILP (specified_time
))
1620 EMACS_TIME now
= current_emacs_time ();
1621 t
= EMACS_SECS (now
) + EMACS_NSECS (now
) / 1e9
;
1625 Lisp_Object high
, low
, usec
, psec
;
1626 if (! (disassemble_lisp_time (specified_time
, &high
, &low
, &usec
, &psec
)
1627 && decode_time_components (high
, low
, usec
, psec
, 0, &t
)))
1628 error ("Invalid time specification");
1630 return make_float (t
);
1633 /* Write information into buffer S of size MAXSIZE, according to the
1634 FORMAT of length FORMAT_LEN, using time information taken from *TP.
1635 Default to Universal Time if UT is nonzero, local time otherwise.
1636 Use NS as the number of nanoseconds in the %N directive.
1637 Return the number of bytes written, not including the terminating
1638 '\0'. If S is NULL, nothing will be written anywhere; so to
1639 determine how many bytes would be written, use NULL for S and
1640 ((size_t) -1) for MAXSIZE.
1642 This function behaves like nstrftime, except it allows null
1643 bytes in FORMAT and it does not support nanoseconds. */
1645 emacs_nmemftime (char *s
, size_t maxsize
, const char *format
,
1646 size_t format_len
, const struct tm
*tp
, int ut
, int ns
)
1650 /* Loop through all the null-terminated strings in the format
1651 argument. Normally there's just one null-terminated string, but
1652 there can be arbitrarily many, concatenated together, if the
1653 format contains '\0' bytes. nstrftime stops at the first
1654 '\0' byte so we must invoke it separately for each such string. */
1663 result
= nstrftime (s
, maxsize
, format
, tp
, ut
, ns
);
1667 if (result
== 0 && s
[0] != '\0')
1672 maxsize
-= result
+ 1;
1674 len
= strlen (format
);
1675 if (len
== format_len
)
1679 format_len
-= len
+ 1;
1683 DEFUN ("format-time-string", Fformat_time_string
, Sformat_time_string
, 1, 3, 0,
1684 doc
: /* Use FORMAT-STRING to format the time TIME, or now if omitted.
1685 TIME is specified as (HIGH LOW USEC PSEC), as returned by
1686 `current-time' or `file-attributes'. The obsolete form (HIGH . LOW)
1687 is also still accepted.
1688 The third, optional, argument UNIVERSAL, if non-nil, means describe TIME
1689 as Universal Time; nil means describe TIME in the local time zone.
1690 The value is a copy of FORMAT-STRING, but with certain constructs replaced
1691 by text that describes the specified date and time in TIME:
1693 %Y is the year, %y within the century, %C the century.
1694 %G is the year corresponding to the ISO week, %g within the century.
1695 %m is the numeric month.
1696 %b and %h are the locale's abbreviated month name, %B the full name.
1697 %d is the day of the month, zero-padded, %e is blank-padded.
1698 %u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.
1699 %a is the locale's abbreviated name of the day of week, %A the full name.
1700 %U is the week number starting on Sunday, %W starting on Monday,
1701 %V according to ISO 8601.
1702 %j is the day of the year.
1704 %H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H
1705 only blank-padded, %l is like %I blank-padded.
1706 %p is the locale's equivalent of either AM or PM.
1709 %N is the nanosecond, %6N the microsecond, %3N the millisecond, etc.
1710 %Z is the time zone name, %z is the numeric form.
1711 %s is the number of seconds since 1970-01-01 00:00:00 +0000.
1713 %c is the locale's date and time format.
1714 %x is the locale's "preferred" date format.
1715 %D is like "%m/%d/%y".
1717 %R is like "%H:%M", %T is like "%H:%M:%S", %r is like "%I:%M:%S %p".
1718 %X is the locale's "preferred" time format.
1720 Finally, %n is a newline, %t is a tab, %% is a literal %.
1722 Certain flags and modifiers are available with some format controls.
1723 The flags are `_', `-', `^' and `#'. For certain characters X,
1724 %_X is like %X, but padded with blanks; %-X is like %X,
1725 but without padding. %^X is like %X, but with all textual
1726 characters up-cased; %#X is like %X, but with letter-case of
1727 all textual characters reversed.
1728 %NX (where N stands for an integer) is like %X,
1729 but takes up at least N (a number) positions.
1730 The modifiers are `E' and `O'. For certain characters X,
1731 %EX is a locale's alternative version of %X;
1732 %OX is like %X, but uses the locale's number symbols.
1734 For example, to produce full ISO 8601 format, use "%Y-%m-%dT%T%z".
1736 usage: (format-time-string FORMAT-STRING &optional TIME UNIVERSAL) */)
1737 (Lisp_Object format_string
, Lisp_Object timeval
, Lisp_Object universal
)
1739 EMACS_TIME t
= lisp_time_argument (timeval
);
1742 CHECK_STRING (format_string
);
1743 format_string
= code_convert_string_norecord (format_string
,
1744 Vlocale_coding_system
, 1);
1745 return format_time_string (SSDATA (format_string
), SBYTES (format_string
),
1746 t
, ! NILP (universal
), &tm
);
1750 format_time_string (char const *format
, ptrdiff_t formatlen
,
1751 EMACS_TIME t
, int ut
, struct tm
*tmp
)
1755 ptrdiff_t size
= sizeof buffer
;
1757 Lisp_Object bufstring
;
1758 int ns
= EMACS_NSECS (t
);
1764 time_t *taddr
= emacs_secs_addr (&t
);
1767 synchronize_system_time_locale ();
1769 tm
= ut
? gmtime (taddr
) : localtime (taddr
);
1778 len
= emacs_nmemftime (buf
, size
, format
, formatlen
, tm
, ut
, ns
);
1779 if ((0 < len
&& len
< size
) || (len
== 0 && buf
[0] == '\0'))
1782 /* Buffer was too small, so make it bigger and try again. */
1783 len
= emacs_nmemftime (NULL
, SIZE_MAX
, format
, formatlen
, tm
, ut
, ns
);
1785 if (STRING_BYTES_BOUND
<= len
)
1788 buf
= SAFE_ALLOCA (size
);
1792 bufstring
= make_unibyte_string (buf
, len
);
1794 return code_convert_string_norecord (bufstring
, Vlocale_coding_system
, 0);
1797 DEFUN ("decode-time", Fdecode_time
, Sdecode_time
, 0, 1, 0,
1798 doc
: /* Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST ZONE).
1799 The optional SPECIFIED-TIME should be a list of (HIGH LOW . IGNORED),
1800 as from `current-time' and `file-attributes', or nil to use the
1801 current time. The obsolete form (HIGH . LOW) is also still accepted.
1802 The list has the following nine members: SEC is an integer between 0
1803 and 60; SEC is 60 for a leap second, which only some operating systems
1804 support. MINUTE is an integer between 0 and 59. HOUR is an integer
1805 between 0 and 23. DAY is an integer between 1 and 31. MONTH is an
1806 integer between 1 and 12. YEAR is an integer indicating the
1807 four-digit year. DOW is the day of week, an integer between 0 and 6,
1808 where 0 is Sunday. DST is t if daylight saving time is in effect,
1809 otherwise nil. ZONE is an integer indicating the number of seconds
1810 east of Greenwich. (Note that Common Lisp has different meanings for
1812 (Lisp_Object specified_time
)
1814 time_t time_spec
= lisp_seconds_argument (specified_time
);
1816 struct tm
*decoded_time
;
1817 Lisp_Object list_args
[9];
1820 decoded_time
= localtime (&time_spec
);
1822 save_tm
= *decoded_time
;
1825 && MOST_NEGATIVE_FIXNUM
- TM_YEAR_BASE
<= save_tm
.tm_year
1826 && save_tm
.tm_year
<= MOST_POSITIVE_FIXNUM
- TM_YEAR_BASE
))
1828 XSETFASTINT (list_args
[0], save_tm
.tm_sec
);
1829 XSETFASTINT (list_args
[1], save_tm
.tm_min
);
1830 XSETFASTINT (list_args
[2], save_tm
.tm_hour
);
1831 XSETFASTINT (list_args
[3], save_tm
.tm_mday
);
1832 XSETFASTINT (list_args
[4], save_tm
.tm_mon
+ 1);
1833 /* On 64-bit machines an int is narrower than EMACS_INT, thus the
1834 cast below avoids overflow in int arithmetics. */
1835 XSETINT (list_args
[5], TM_YEAR_BASE
+ (EMACS_INT
) save_tm
.tm_year
);
1836 XSETFASTINT (list_args
[6], save_tm
.tm_wday
);
1837 list_args
[7] = save_tm
.tm_isdst
? Qt
: Qnil
;
1840 decoded_time
= gmtime (&time_spec
);
1841 if (decoded_time
== 0)
1842 list_args
[8] = Qnil
;
1844 XSETINT (list_args
[8], tm_diff (&save_tm
, decoded_time
));
1846 return Flist (9, list_args
);
1849 /* Return OBJ - OFFSET, checking that OBJ is a valid fixnum and that
1850 the result is representable as an int. Assume OFFSET is small and
1853 check_tm_member (Lisp_Object obj
, int offset
)
1858 if (! (INT_MIN
+ offset
<= n
&& n
- offset
<= INT_MAX
))
1863 DEFUN ("encode-time", Fencode_time
, Sencode_time
, 6, MANY
, 0,
1864 doc
: /* Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.
1865 This is the reverse operation of `decode-time', which see.
1866 ZONE defaults to the current time zone rule. This can
1867 be a string or t (as from `set-time-zone-rule'), or it can be a list
1868 \(as from `current-time-zone') or an integer (as from `decode-time')
1869 applied without consideration for daylight saving time.
1871 You can pass more than 7 arguments; then the first six arguments
1872 are used as SECOND through YEAR, and the *last* argument is used as ZONE.
1873 The intervening arguments are ignored.
1874 This feature lets (apply 'encode-time (decode-time ...)) work.
1876 Out-of-range values for SECOND, MINUTE, HOUR, DAY, or MONTH are allowed;
1877 for example, a DAY of 0 means the day preceding the given month.
1878 Year numbers less than 100 are treated just like other year numbers.
1879 If you want them to stand for years in this century, you must do that yourself.
1881 Years before 1970 are not guaranteed to work. On some systems,
1882 year values as low as 1901 do work.
1884 usage: (encode-time SECOND MINUTE HOUR DAY MONTH YEAR &optional ZONE) */)
1885 (ptrdiff_t nargs
, Lisp_Object
*args
)
1889 Lisp_Object zone
= (nargs
> 6 ? args
[nargs
- 1] : Qnil
);
1891 tm
.tm_sec
= check_tm_member (args
[0], 0);
1892 tm
.tm_min
= check_tm_member (args
[1], 0);
1893 tm
.tm_hour
= check_tm_member (args
[2], 0);
1894 tm
.tm_mday
= check_tm_member (args
[3], 0);
1895 tm
.tm_mon
= check_tm_member (args
[4], 1);
1896 tm
.tm_year
= check_tm_member (args
[5], TM_YEAR_BASE
);
1904 value
= mktime (&tm
);
1910 const char *tzstring
;
1911 char **oldenv
= environ
, **newenv
;
1915 else if (STRINGP (zone
))
1916 tzstring
= SSDATA (zone
);
1917 else if (INTEGERP (zone
))
1919 EMACS_INT abszone
= eabs (XINT (zone
));
1920 EMACS_INT zone_hr
= abszone
/ (60*60);
1921 int zone_min
= (abszone
/60) % 60;
1922 int zone_sec
= abszone
% 60;
1923 sprintf (tzbuf
, "XXX%s%"pI
"d:%02d:%02d", "-" + (XINT (zone
) < 0),
1924 zone_hr
, zone_min
, zone_sec
);
1928 error ("Invalid time zone specification");
1932 /* Set TZ before calling mktime; merely adjusting mktime's returned
1933 value doesn't suffice, since that would mishandle leap seconds. */
1934 set_time_zone_rule (tzstring
);
1936 value
= mktime (&tm
);
1938 /* Restore TZ to previous value. */
1941 #ifdef LOCALTIME_CACHE
1949 if (value
== (time_t) -1)
1952 return make_time (value
);
1955 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
, 0, 1, 0,
1956 doc
: /* Return the current local time, as a human-readable string.
1957 Programs can use this function to decode a time,
1958 since the number of columns in each field is fixed
1959 if the year is in the range 1000-9999.
1960 The format is `Sun Sep 16 01:03:52 1973'.
1961 However, see also the functions `decode-time' and `format-time-string'
1962 which provide a much more powerful and general facility.
1964 If SPECIFIED-TIME is given, it is a time to format instead of the
1965 current time. The argument should have the form (HIGH LOW . IGNORED).
1966 Thus, you can use times obtained from `current-time' and from
1967 `file-attributes'. SPECIFIED-TIME can also have the form (HIGH . LOW),
1968 but this is considered obsolete. */)
1969 (Lisp_Object specified_time
)
1971 time_t value
= lisp_seconds_argument (specified_time
);
1973 char buf
[sizeof "Mon Apr 30 12:49:17 " + INT_STRLEN_BOUND (int) + 1];
1974 int len
IF_LINT (= 0);
1976 /* Convert to a string in ctime format, except without the trailing
1977 newline, and without the 4-digit year limit. Don't use asctime
1978 or ctime, as they might dump core if the year is outside the
1979 range -999 .. 9999. */
1981 tm
= localtime (&value
);
1984 static char const wday_name
[][4] =
1985 { "Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat" };
1986 static char const mon_name
[][4] =
1987 { "Jan", "Feb", "Mar", "Apr", "May", "Jun",
1988 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" };
1989 printmax_t year_base
= TM_YEAR_BASE
;
1991 len
= sprintf (buf
, "%s %s%3d %02d:%02d:%02d %"pMd
,
1992 wday_name
[tm
->tm_wday
], mon_name
[tm
->tm_mon
], tm
->tm_mday
,
1993 tm
->tm_hour
, tm
->tm_min
, tm
->tm_sec
,
1994 tm
->tm_year
+ year_base
);
2000 return make_unibyte_string (buf
, len
);
2003 /* Yield A - B, measured in seconds.
2004 This function is copied from the GNU C Library. */
2006 tm_diff (struct tm
*a
, struct tm
*b
)
2008 /* Compute intervening leap days correctly even if year is negative.
2009 Take care to avoid int overflow in leap day calculations,
2010 but it's OK to assume that A and B are close to each other. */
2011 int a4
= (a
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (a
->tm_year
& 3);
2012 int b4
= (b
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (b
->tm_year
& 3);
2013 int a100
= a4
/ 25 - (a4
% 25 < 0);
2014 int b100
= b4
/ 25 - (b4
% 25 < 0);
2015 int a400
= a100
>> 2;
2016 int b400
= b100
>> 2;
2017 int intervening_leap_days
= (a4
- b4
) - (a100
- b100
) + (a400
- b400
);
2018 int years
= a
->tm_year
- b
->tm_year
;
2019 int days
= (365 * years
+ intervening_leap_days
2020 + (a
->tm_yday
- b
->tm_yday
));
2021 return (60 * (60 * (24 * days
+ (a
->tm_hour
- b
->tm_hour
))
2022 + (a
->tm_min
- b
->tm_min
))
2023 + (a
->tm_sec
- b
->tm_sec
));
2026 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 1, 0,
2027 doc
: /* Return the offset and name for the local time zone.
2028 This returns a list of the form (OFFSET NAME).
2029 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).
2030 A negative value means west of Greenwich.
2031 NAME is a string giving the name of the time zone.
2032 If SPECIFIED-TIME is given, the time zone offset is determined from it
2033 instead of using the current time. The argument should have the form
2034 (HIGH LOW . IGNORED). Thus, you can use times obtained from
2035 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
2036 have the form (HIGH . LOW), but this is considered obsolete.
2038 Some operating systems cannot provide all this information to Emacs;
2039 in this case, `current-time-zone' returns a list containing nil for
2040 the data it can't find. */)
2041 (Lisp_Object specified_time
)
2047 Lisp_Object zone_offset
, zone_name
;
2050 value
= make_emacs_time (lisp_seconds_argument (specified_time
), 0);
2051 zone_name
= format_time_string ("%Z", sizeof "%Z" - 1, value
, 0, &localtm
);
2053 t
= gmtime (emacs_secs_addr (&value
));
2055 offset
= tm_diff (&localtm
, t
);
2060 zone_offset
= make_number (offset
);
2061 if (SCHARS (zone_name
) == 0)
2063 /* No local time zone name is available; use "+-NNNN" instead. */
2064 int m
= offset
/ 60;
2065 int am
= offset
< 0 ? - m
: m
;
2066 char buf
[sizeof "+00" + INT_STRLEN_BOUND (int)];
2067 zone_name
= make_formatted_string (buf
, "%c%02d%02d",
2068 (offset
< 0 ? '-' : '+'),
2073 return list2 (zone_offset
, zone_name
);
2076 /* This holds the value of `environ' produced by the previous
2077 call to Fset_time_zone_rule, or 0 if Fset_time_zone_rule
2078 has never been called. */
2079 static char **environbuf
;
2081 /* This holds the startup value of the TZ environment variable so it
2082 can be restored if the user calls set-time-zone-rule with a nil
2084 static char *initial_tz
;
2086 DEFUN ("set-time-zone-rule", Fset_time_zone_rule
, Sset_time_zone_rule
, 1, 1, 0,
2087 doc
: /* Set the local time zone using TZ, a string specifying a time zone rule.
2088 If TZ is nil, use implementation-defined default time zone information.
2089 If TZ is t, use Universal Time.
2091 Instead of calling this function, you typically want (setenv "TZ" TZ).
2092 That changes both the environment of the Emacs process and the
2093 variable `process-environment', whereas `set-time-zone-rule' affects
2094 only the former. */)
2097 const char *tzstring
;
2098 char **old_environbuf
;
2100 if (! (NILP (tz
) || EQ (tz
, Qt
)))
2105 /* When called for the first time, save the original TZ. */
2106 old_environbuf
= environbuf
;
2107 if (!old_environbuf
)
2108 initial_tz
= (char *) getenv ("TZ");
2111 tzstring
= initial_tz
;
2112 else if (EQ (tz
, Qt
))
2115 tzstring
= SSDATA (tz
);
2117 set_time_zone_rule (tzstring
);
2118 environbuf
= environ
;
2122 xfree (old_environbuf
);
2126 #ifdef LOCALTIME_CACHE
2128 /* These two values are known to load tz files in buggy implementations,
2129 i.e. Solaris 1 executables running under either Solaris 1 or Solaris 2.
2130 Their values shouldn't matter in non-buggy implementations.
2131 We don't use string literals for these strings,
2132 since if a string in the environment is in readonly
2133 storage, it runs afoul of bugs in SVR4 and Solaris 2.3.
2134 See Sun bugs 1113095 and 1114114, ``Timezone routines
2135 improperly modify environment''. */
2137 static char set_time_zone_rule_tz1
[] = "TZ=GMT+0";
2138 static char set_time_zone_rule_tz2
[] = "TZ=GMT+1";
2142 /* Set the local time zone rule to TZSTRING.
2143 This allocates memory into `environ', which it is the caller's
2144 responsibility to free. */
2147 set_time_zone_rule (const char *tzstring
)
2150 char **from
, **to
, **newenv
;
2152 /* Make the ENVIRON vector longer with room for TZSTRING. */
2153 for (from
= environ
; *from
; from
++)
2155 envptrs
= from
- environ
+ 2;
2156 newenv
= to
= xmalloc (envptrs
* sizeof *newenv
2157 + (tzstring
? strlen (tzstring
) + 4 : 0));
2159 /* Add TZSTRING to the end of environ, as a value for TZ. */
2162 char *t
= (char *) (to
+ envptrs
);
2164 strcat (t
, tzstring
);
2168 /* Copy the old environ vector elements into NEWENV,
2169 but don't copy the TZ variable.
2170 So we have only one definition of TZ, which came from TZSTRING. */
2171 for (from
= environ
; *from
; from
++)
2172 if (strncmp (*from
, "TZ=", 3) != 0)
2178 /* If we do have a TZSTRING, NEWENV points to the vector slot where
2179 the TZ variable is stored. If we do not have a TZSTRING,
2180 TO points to the vector slot which has the terminating null. */
2182 #ifdef LOCALTIME_CACHE
2184 /* In SunOS 4.1.3_U1 and 4.1.4, if TZ has a value like
2185 "US/Pacific" that loads a tz file, then changes to a value like
2186 "XXX0" that does not load a tz file, and then changes back to
2187 its original value, the last change is (incorrectly) ignored.
2188 Also, if TZ changes twice in succession to values that do
2189 not load a tz file, tzset can dump core (see Sun bug#1225179).
2190 The following code works around these bugs. */
2194 /* Temporarily set TZ to a value that loads a tz file
2195 and that differs from tzstring. */
2197 *newenv
= (strcmp (tzstring
, set_time_zone_rule_tz1
+ 3) == 0
2198 ? set_time_zone_rule_tz2
: set_time_zone_rule_tz1
);
2204 /* The implied tzstring is unknown, so temporarily set TZ to
2205 two different values that each load a tz file. */
2206 *to
= set_time_zone_rule_tz1
;
2209 *to
= set_time_zone_rule_tz2
;
2214 /* Now TZ has the desired value, and tzset can be invoked safely. */
2221 /* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC
2222 (if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a
2223 type of object is Lisp_String). INHERIT is passed to
2224 INSERT_FROM_STRING_FUNC as the last argument. */
2227 general_insert_function (void (*insert_func
)
2228 (const char *, ptrdiff_t),
2229 void (*insert_from_string_func
)
2230 (Lisp_Object
, ptrdiff_t, ptrdiff_t,
2231 ptrdiff_t, ptrdiff_t, int),
2232 int inherit
, ptrdiff_t nargs
, Lisp_Object
*args
)
2235 register Lisp_Object val
;
2237 for (argnum
= 0; argnum
< nargs
; argnum
++)
2240 if (CHARACTERP (val
))
2242 int c
= XFASTINT (val
);
2243 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2246 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2247 len
= CHAR_STRING (c
, str
);
2250 str
[0] = ASCII_CHAR_P (c
) ? c
: multibyte_char_to_unibyte (c
);
2253 (*insert_func
) ((char *) str
, len
);
2255 else if (STRINGP (val
))
2257 (*insert_from_string_func
) (val
, 0, 0,
2263 wrong_type_argument (Qchar_or_string_p
, val
);
2268 insert1 (Lisp_Object arg
)
2274 /* Callers passing one argument to Finsert need not gcpro the
2275 argument "array", since the only element of the array will
2276 not be used after calling insert or insert_from_string, so
2277 we don't care if it gets trashed. */
2279 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
2280 doc
: /* Insert the arguments, either strings or characters, at point.
2281 Point and before-insertion markers move forward to end up
2282 after the inserted text.
2283 Any other markers at the point of insertion remain before the text.
2285 If the current buffer is multibyte, unibyte strings are converted
2286 to multibyte for insertion (see `string-make-multibyte').
2287 If the current buffer is unibyte, multibyte strings are converted
2288 to unibyte for insertion (see `string-make-unibyte').
2290 When operating on binary data, it may be necessary to preserve the
2291 original bytes of a unibyte string when inserting it into a multibyte
2292 buffer; to accomplish this, apply `string-as-multibyte' to the string
2293 and insert the result.
2295 usage: (insert &rest ARGS) */)
2296 (ptrdiff_t nargs
, Lisp_Object
*args
)
2298 general_insert_function (insert
, insert_from_string
, 0, nargs
, args
);
2302 DEFUN ("insert-and-inherit", Finsert_and_inherit
, Sinsert_and_inherit
,
2304 doc
: /* Insert the arguments at point, inheriting properties from adjoining text.
2305 Point and before-insertion markers move forward to end up
2306 after the inserted text.
2307 Any other markers at the point of insertion remain before the text.
2309 If the current buffer is multibyte, unibyte strings are converted
2310 to multibyte for insertion (see `unibyte-char-to-multibyte').
2311 If the current buffer is unibyte, multibyte strings are converted
2312 to unibyte for insertion.
2314 usage: (insert-and-inherit &rest ARGS) */)
2315 (ptrdiff_t nargs
, Lisp_Object
*args
)
2317 general_insert_function (insert_and_inherit
, insert_from_string
, 1,
2322 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
2323 doc
: /* Insert strings or characters at point, relocating markers after the text.
2324 Point and markers move forward to end up after the inserted text.
2326 If the current buffer is multibyte, unibyte strings are converted
2327 to multibyte for insertion (see `unibyte-char-to-multibyte').
2328 If the current buffer is unibyte, multibyte strings are converted
2329 to unibyte for insertion.
2331 usage: (insert-before-markers &rest ARGS) */)
2332 (ptrdiff_t nargs
, Lisp_Object
*args
)
2334 general_insert_function (insert_before_markers
,
2335 insert_from_string_before_markers
, 0,
2340 DEFUN ("insert-before-markers-and-inherit", Finsert_and_inherit_before_markers
,
2341 Sinsert_and_inherit_before_markers
, 0, MANY
, 0,
2342 doc
: /* Insert text at point, relocating markers and inheriting properties.
2343 Point and markers move forward to end up after the inserted text.
2345 If the current buffer is multibyte, unibyte strings are converted
2346 to multibyte for insertion (see `unibyte-char-to-multibyte').
2347 If the current buffer is unibyte, multibyte strings are converted
2348 to unibyte for insertion.
2350 usage: (insert-before-markers-and-inherit &rest ARGS) */)
2351 (ptrdiff_t nargs
, Lisp_Object
*args
)
2353 general_insert_function (insert_before_markers_and_inherit
,
2354 insert_from_string_before_markers
, 1,
2359 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 1, 3,
2360 "(list (read-char-by-name \"Insert character (Unicode name or hex): \")\
2361 (prefix-numeric-value current-prefix-arg)\
2363 doc
: /* Insert COUNT copies of CHARACTER.
2364 Interactively, prompt for CHARACTER. You can specify CHARACTER in one
2367 - As its Unicode character name, e.g. \"LATIN SMALL LETTER A\".
2368 Completion is available; if you type a substring of the name
2369 preceded by an asterisk `*', Emacs shows all names which include
2370 that substring, not necessarily at the beginning of the name.
2372 - As a hexadecimal code point, e.g. 263A. Note that code points in
2373 Emacs are equivalent to Unicode up to 10FFFF (which is the limit of
2374 the Unicode code space).
2376 - As a code point with a radix specified with #, e.g. #o21430
2377 (octal), #x2318 (hex), or #10r8984 (decimal).
2379 If called interactively, COUNT is given by the prefix argument. If
2380 omitted or nil, it defaults to 1.
2382 Inserting the character(s) relocates point and before-insertion
2383 markers in the same ways as the function `insert'.
2385 The optional third argument INHERIT, if non-nil, says to inherit text
2386 properties from adjoining text, if those properties are sticky. If
2387 called interactively, INHERIT is t. */)
2388 (Lisp_Object character
, Lisp_Object count
, Lisp_Object inherit
)
2391 register ptrdiff_t n
;
2393 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2396 CHECK_CHARACTER (character
);
2398 XSETFASTINT (count
, 1);
2399 CHECK_NUMBER (count
);
2400 c
= XFASTINT (character
);
2402 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2403 len
= CHAR_STRING (c
, str
);
2405 str
[0] = c
, len
= 1;
2406 if (XINT (count
) <= 0)
2408 if (BUF_BYTES_MAX
/ len
< XINT (count
))
2410 n
= XINT (count
) * len
;
2411 stringlen
= min (n
, sizeof string
- sizeof string
% len
);
2412 for (i
= 0; i
< stringlen
; i
++)
2413 string
[i
] = str
[i
% len
];
2414 while (n
> stringlen
)
2417 if (!NILP (inherit
))
2418 insert_and_inherit (string
, stringlen
);
2420 insert (string
, stringlen
);
2423 if (!NILP (inherit
))
2424 insert_and_inherit (string
, n
);
2430 DEFUN ("insert-byte", Finsert_byte
, Sinsert_byte
, 2, 3, 0,
2431 doc
: /* Insert COUNT (second arg) copies of BYTE (first arg).
2432 Both arguments are required.
2433 BYTE is a number of the range 0..255.
2435 If BYTE is 128..255 and the current buffer is multibyte, the
2436 corresponding eight-bit character is inserted.
2438 Point, and before-insertion markers, are relocated as in the function `insert'.
2439 The optional third arg INHERIT, if non-nil, says to inherit text properties
2440 from adjoining text, if those properties are sticky. */)
2441 (Lisp_Object byte
, Lisp_Object count
, Lisp_Object inherit
)
2443 CHECK_NUMBER (byte
);
2444 if (XINT (byte
) < 0 || XINT (byte
) > 255)
2445 args_out_of_range_3 (byte
, make_number (0), make_number (255));
2446 if (XINT (byte
) >= 128
2447 && ! NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2448 XSETFASTINT (byte
, BYTE8_TO_CHAR (XINT (byte
)));
2449 return Finsert_char (byte
, count
, inherit
);
2453 /* Making strings from buffer contents. */
2455 /* Return a Lisp_String containing the text of the current buffer from
2456 START to END. If text properties are in use and the current buffer
2457 has properties in the range specified, the resulting string will also
2458 have them, if PROPS is nonzero.
2460 We don't want to use plain old make_string here, because it calls
2461 make_uninit_string, which can cause the buffer arena to be
2462 compacted. make_string has no way of knowing that the data has
2463 been moved, and thus copies the wrong data into the string. This
2464 doesn't effect most of the other users of make_string, so it should
2465 be left as is. But we should use this function when conjuring
2466 buffer substrings. */
2469 make_buffer_string (ptrdiff_t start
, ptrdiff_t end
, int props
)
2471 ptrdiff_t start_byte
= CHAR_TO_BYTE (start
);
2472 ptrdiff_t end_byte
= CHAR_TO_BYTE (end
);
2474 return make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
);
2477 /* Return a Lisp_String containing the text of the current buffer from
2478 START / START_BYTE to END / END_BYTE.
2480 If text properties are in use and the current buffer
2481 has properties in the range specified, the resulting string will also
2482 have them, if PROPS is nonzero.
2484 We don't want to use plain old make_string here, because it calls
2485 make_uninit_string, which can cause the buffer arena to be
2486 compacted. make_string has no way of knowing that the data has
2487 been moved, and thus copies the wrong data into the string. This
2488 doesn't effect most of the other users of make_string, so it should
2489 be left as is. But we should use this function when conjuring
2490 buffer substrings. */
2493 make_buffer_string_both (ptrdiff_t start
, ptrdiff_t start_byte
,
2494 ptrdiff_t end
, ptrdiff_t end_byte
, int props
)
2496 Lisp_Object result
, tem
, tem1
;
2498 if (start
< GPT
&& GPT
< end
)
2501 if (! NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2502 result
= make_uninit_multibyte_string (end
- start
, end_byte
- start_byte
);
2504 result
= make_uninit_string (end
- start
);
2505 memcpy (SDATA (result
), BYTE_POS_ADDR (start_byte
), end_byte
- start_byte
);
2507 /* If desired, update and copy the text properties. */
2510 update_buffer_properties (start
, end
);
2512 tem
= Fnext_property_change (make_number (start
), Qnil
, make_number (end
));
2513 tem1
= Ftext_properties_at (make_number (start
), Qnil
);
2515 if (XINT (tem
) != end
|| !NILP (tem1
))
2516 copy_intervals_to_string (result
, current_buffer
, start
,
2523 /* Call Vbuffer_access_fontify_functions for the range START ... END
2524 in the current buffer, if necessary. */
2527 update_buffer_properties (ptrdiff_t start
, ptrdiff_t end
)
2529 /* If this buffer has some access functions,
2530 call them, specifying the range of the buffer being accessed. */
2531 if (!NILP (Vbuffer_access_fontify_functions
))
2533 Lisp_Object args
[3];
2536 args
[0] = Qbuffer_access_fontify_functions
;
2537 XSETINT (args
[1], start
);
2538 XSETINT (args
[2], end
);
2540 /* But don't call them if we can tell that the work
2541 has already been done. */
2542 if (!NILP (Vbuffer_access_fontified_property
))
2544 tem
= Ftext_property_any (args
[1], args
[2],
2545 Vbuffer_access_fontified_property
,
2548 Frun_hook_with_args (3, args
);
2551 Frun_hook_with_args (3, args
);
2555 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
2556 doc
: /* Return the contents of part of the current buffer as a string.
2557 The two arguments START and END are character positions;
2558 they can be in either order.
2559 The string returned is multibyte if the buffer is multibyte.
2561 This function copies the text properties of that part of the buffer
2562 into the result string; if you don't want the text properties,
2563 use `buffer-substring-no-properties' instead. */)
2564 (Lisp_Object start
, Lisp_Object end
)
2566 register ptrdiff_t b
, e
;
2568 validate_region (&start
, &end
);
2572 return make_buffer_string (b
, e
, 1);
2575 DEFUN ("buffer-substring-no-properties", Fbuffer_substring_no_properties
,
2576 Sbuffer_substring_no_properties
, 2, 2, 0,
2577 doc
: /* Return the characters of part of the buffer, without the text properties.
2578 The two arguments START and END are character positions;
2579 they can be in either order. */)
2580 (Lisp_Object start
, Lisp_Object end
)
2582 register ptrdiff_t b
, e
;
2584 validate_region (&start
, &end
);
2588 return make_buffer_string (b
, e
, 0);
2591 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
2592 doc
: /* Return the contents of the current buffer as a string.
2593 If narrowing is in effect, this function returns only the visible part
2597 return make_buffer_string (BEGV
, ZV
, 1);
2600 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
2602 doc
: /* Insert before point a substring of the contents of BUFFER.
2603 BUFFER may be a buffer or a buffer name.
2604 Arguments START and END are character positions specifying the substring.
2605 They default to the values of (point-min) and (point-max) in BUFFER. */)
2606 (Lisp_Object buffer
, Lisp_Object start
, Lisp_Object end
)
2608 register EMACS_INT b
, e
, temp
;
2609 register struct buffer
*bp
, *obuf
;
2612 buf
= Fget_buffer (buffer
);
2616 if (NILP (BVAR (bp
, name
)))
2617 error ("Selecting deleted buffer");
2623 CHECK_NUMBER_COERCE_MARKER (start
);
2630 CHECK_NUMBER_COERCE_MARKER (end
);
2635 temp
= b
, b
= e
, e
= temp
;
2637 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
2638 args_out_of_range (start
, end
);
2640 obuf
= current_buffer
;
2641 set_buffer_internal_1 (bp
);
2642 update_buffer_properties (b
, e
);
2643 set_buffer_internal_1 (obuf
);
2645 insert_from_buffer (bp
, b
, e
- b
, 0);
2649 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
2651 doc
: /* Compare two substrings of two buffers; return result as number.
2652 the value is -N if first string is less after N-1 chars,
2653 +N if first string is greater after N-1 chars, or 0 if strings match.
2654 Each substring is represented as three arguments: BUFFER, START and END.
2655 That makes six args in all, three for each substring.
2657 The value of `case-fold-search' in the current buffer
2658 determines whether case is significant or ignored. */)
2659 (Lisp_Object buffer1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object buffer2
, Lisp_Object start2
, Lisp_Object end2
)
2661 register EMACS_INT begp1
, endp1
, begp2
, endp2
, temp
;
2662 register struct buffer
*bp1
, *bp2
;
2663 register Lisp_Object trt
2664 = (!NILP (BVAR (current_buffer
, case_fold_search
))
2665 ? BVAR (current_buffer
, case_canon_table
) : Qnil
);
2666 ptrdiff_t chars
= 0;
2667 ptrdiff_t i1
, i2
, i1_byte
, i2_byte
;
2669 /* Find the first buffer and its substring. */
2672 bp1
= current_buffer
;
2676 buf1
= Fget_buffer (buffer1
);
2679 bp1
= XBUFFER (buf1
);
2680 if (NILP (BVAR (bp1
, name
)))
2681 error ("Selecting deleted buffer");
2685 begp1
= BUF_BEGV (bp1
);
2688 CHECK_NUMBER_COERCE_MARKER (start1
);
2689 begp1
= XINT (start1
);
2692 endp1
= BUF_ZV (bp1
);
2695 CHECK_NUMBER_COERCE_MARKER (end1
);
2696 endp1
= XINT (end1
);
2700 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
2702 if (!(BUF_BEGV (bp1
) <= begp1
2704 && endp1
<= BUF_ZV (bp1
)))
2705 args_out_of_range (start1
, end1
);
2707 /* Likewise for second substring. */
2710 bp2
= current_buffer
;
2714 buf2
= Fget_buffer (buffer2
);
2717 bp2
= XBUFFER (buf2
);
2718 if (NILP (BVAR (bp2
, name
)))
2719 error ("Selecting deleted buffer");
2723 begp2
= BUF_BEGV (bp2
);
2726 CHECK_NUMBER_COERCE_MARKER (start2
);
2727 begp2
= XINT (start2
);
2730 endp2
= BUF_ZV (bp2
);
2733 CHECK_NUMBER_COERCE_MARKER (end2
);
2734 endp2
= XINT (end2
);
2738 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
2740 if (!(BUF_BEGV (bp2
) <= begp2
2742 && endp2
<= BUF_ZV (bp2
)))
2743 args_out_of_range (start2
, end2
);
2747 i1_byte
= buf_charpos_to_bytepos (bp1
, i1
);
2748 i2_byte
= buf_charpos_to_bytepos (bp2
, i2
);
2750 while (i1
< endp1
&& i2
< endp2
)
2752 /* When we find a mismatch, we must compare the
2753 characters, not just the bytes. */
2758 if (! NILP (BVAR (bp1
, enable_multibyte_characters
)))
2760 c1
= BUF_FETCH_MULTIBYTE_CHAR (bp1
, i1_byte
);
2761 BUF_INC_POS (bp1
, i1_byte
);
2766 c1
= BUF_FETCH_BYTE (bp1
, i1
);
2767 MAKE_CHAR_MULTIBYTE (c1
);
2771 if (! NILP (BVAR (bp2
, enable_multibyte_characters
)))
2773 c2
= BUF_FETCH_MULTIBYTE_CHAR (bp2
, i2_byte
);
2774 BUF_INC_POS (bp2
, i2_byte
);
2779 c2
= BUF_FETCH_BYTE (bp2
, i2
);
2780 MAKE_CHAR_MULTIBYTE (c2
);
2786 c1
= CHAR_TABLE_TRANSLATE (trt
, c1
);
2787 c2
= CHAR_TABLE_TRANSLATE (trt
, c2
);
2790 return make_number (- 1 - chars
);
2792 return make_number (chars
+ 1);
2797 /* The strings match as far as they go.
2798 If one is shorter, that one is less. */
2799 if (chars
< endp1
- begp1
)
2800 return make_number (chars
+ 1);
2801 else if (chars
< endp2
- begp2
)
2802 return make_number (- chars
- 1);
2804 /* Same length too => they are equal. */
2805 return make_number (0);
2809 subst_char_in_region_unwind (Lisp_Object arg
)
2811 bset_undo_list (current_buffer
, arg
);
2816 subst_char_in_region_unwind_1 (Lisp_Object arg
)
2818 bset_filename (current_buffer
, arg
);
2822 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
2823 Ssubst_char_in_region
, 4, 5, 0,
2824 doc
: /* From START to END, replace FROMCHAR with TOCHAR each time it occurs.
2825 If optional arg NOUNDO is non-nil, don't record this change for undo
2826 and don't mark the buffer as really changed.
2827 Both characters must have the same length of multi-byte form. */)
2828 (Lisp_Object start
, Lisp_Object end
, Lisp_Object fromchar
, Lisp_Object tochar
, Lisp_Object noundo
)
2830 register ptrdiff_t pos
, pos_byte
, stop
, i
, len
, end_byte
;
2831 /* Keep track of the first change in the buffer:
2832 if 0 we haven't found it yet.
2833 if < 0 we've found it and we've run the before-change-function.
2834 if > 0 we've actually performed it and the value is its position. */
2835 ptrdiff_t changed
= 0;
2836 unsigned char fromstr
[MAX_MULTIBYTE_LENGTH
], tostr
[MAX_MULTIBYTE_LENGTH
];
2838 ptrdiff_t count
= SPECPDL_INDEX ();
2839 #define COMBINING_NO 0
2840 #define COMBINING_BEFORE 1
2841 #define COMBINING_AFTER 2
2842 #define COMBINING_BOTH (COMBINING_BEFORE | COMBINING_AFTER)
2843 int maybe_byte_combining
= COMBINING_NO
;
2844 ptrdiff_t last_changed
= 0;
2845 int multibyte_p
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
2850 validate_region (&start
, &end
);
2851 CHECK_CHARACTER (fromchar
);
2852 CHECK_CHARACTER (tochar
);
2853 fromc
= XFASTINT (fromchar
);
2854 toc
= XFASTINT (tochar
);
2858 len
= CHAR_STRING (fromc
, fromstr
);
2859 if (CHAR_STRING (toc
, tostr
) != len
)
2860 error ("Characters in `subst-char-in-region' have different byte-lengths");
2861 if (!ASCII_BYTE_P (*tostr
))
2863 /* If *TOSTR is in the range 0x80..0x9F and TOCHAR is not a
2864 complete multibyte character, it may be combined with the
2865 after bytes. If it is in the range 0xA0..0xFF, it may be
2866 combined with the before and after bytes. */
2867 if (!CHAR_HEAD_P (*tostr
))
2868 maybe_byte_combining
= COMBINING_BOTH
;
2869 else if (BYTES_BY_CHAR_HEAD (*tostr
) > len
)
2870 maybe_byte_combining
= COMBINING_AFTER
;
2881 pos_byte
= CHAR_TO_BYTE (pos
);
2882 stop
= CHAR_TO_BYTE (XINT (end
));
2885 /* If we don't want undo, turn off putting stuff on the list.
2886 That's faster than getting rid of things,
2887 and it prevents even the entry for a first change.
2888 Also inhibit locking the file. */
2889 if (!changed
&& !NILP (noundo
))
2891 record_unwind_protect (subst_char_in_region_unwind
,
2892 BVAR (current_buffer
, undo_list
));
2893 bset_undo_list (current_buffer
, Qt
);
2894 /* Don't do file-locking. */
2895 record_unwind_protect (subst_char_in_region_unwind_1
,
2896 BVAR (current_buffer
, filename
));
2897 bset_filename (current_buffer
, Qnil
);
2900 if (pos_byte
< GPT_BYTE
)
2901 stop
= min (stop
, GPT_BYTE
);
2904 ptrdiff_t pos_byte_next
= pos_byte
;
2906 if (pos_byte
>= stop
)
2908 if (pos_byte
>= end_byte
) break;
2911 p
= BYTE_POS_ADDR (pos_byte
);
2913 INC_POS (pos_byte_next
);
2916 if (pos_byte_next
- pos_byte
== len
2917 && p
[0] == fromstr
[0]
2919 || (p
[1] == fromstr
[1]
2920 && (len
== 2 || (p
[2] == fromstr
[2]
2921 && (len
== 3 || p
[3] == fromstr
[3]))))))
2924 /* We've already seen this and run the before-change-function;
2925 this time we only need to record the actual position. */
2930 modify_region (current_buffer
, pos
, XINT (end
), 0);
2932 if (! NILP (noundo
))
2934 if (MODIFF
- 1 == SAVE_MODIFF
)
2936 if (MODIFF
- 1 == BUF_AUTOSAVE_MODIFF (current_buffer
))
2937 BUF_AUTOSAVE_MODIFF (current_buffer
)++;
2940 /* The before-change-function may have moved the gap
2941 or even modified the buffer so we should start over. */
2945 /* Take care of the case where the new character
2946 combines with neighboring bytes. */
2947 if (maybe_byte_combining
2948 && (maybe_byte_combining
== COMBINING_AFTER
2949 ? (pos_byte_next
< Z_BYTE
2950 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2951 : ((pos_byte_next
< Z_BYTE
2952 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2953 || (pos_byte
> BEG_BYTE
2954 && ! ASCII_BYTE_P (FETCH_BYTE (pos_byte
- 1))))))
2956 Lisp_Object tem
, string
;
2958 struct gcpro gcpro1
;
2960 tem
= BVAR (current_buffer
, undo_list
);
2963 /* Make a multibyte string containing this single character. */
2964 string
= make_multibyte_string ((char *) tostr
, 1, len
);
2965 /* replace_range is less efficient, because it moves the gap,
2966 but it handles combining correctly. */
2967 replace_range (pos
, pos
+ 1, string
,
2969 pos_byte_next
= CHAR_TO_BYTE (pos
);
2970 if (pos_byte_next
> pos_byte
)
2971 /* Before combining happened. We should not increment
2972 POS. So, to cancel the later increment of POS,
2976 INC_POS (pos_byte_next
);
2978 if (! NILP (noundo
))
2979 bset_undo_list (current_buffer
, tem
);
2986 record_change (pos
, 1);
2987 for (i
= 0; i
< len
; i
++) *p
++ = tostr
[i
];
2989 last_changed
= pos
+ 1;
2991 pos_byte
= pos_byte_next
;
2997 signal_after_change (changed
,
2998 last_changed
- changed
, last_changed
- changed
);
2999 update_compositions (changed
, last_changed
, CHECK_ALL
);
3002 unbind_to (count
, Qnil
);
3007 static Lisp_Object
check_translation (ptrdiff_t, ptrdiff_t, ptrdiff_t,
3010 /* Helper function for Ftranslate_region_internal.
3012 Check if a character sequence at POS (POS_BYTE) matches an element
3013 of VAL. VAL is a list (([FROM-CHAR ...] . TO) ...). If a matching
3014 element is found, return it. Otherwise return Qnil. */
3017 check_translation (ptrdiff_t pos
, ptrdiff_t pos_byte
, ptrdiff_t end
,
3020 int buf_size
= 16, buf_used
= 0;
3021 int *buf
= alloca (sizeof (int) * buf_size
);
3023 for (; CONSP (val
); val
= XCDR (val
))
3032 if (! VECTORP (elt
))
3035 if (len
<= end
- pos
)
3037 for (i
= 0; i
< len
; i
++)
3041 unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
3044 if (buf_used
== buf_size
)
3049 newbuf
= alloca (sizeof (int) * buf_size
);
3050 memcpy (newbuf
, buf
, sizeof (int) * buf_used
);
3053 buf
[buf_used
++] = STRING_CHAR_AND_LENGTH (p
, len1
);
3056 if (XINT (AREF (elt
, i
)) != buf
[i
])
3067 DEFUN ("translate-region-internal", Ftranslate_region_internal
,
3068 Stranslate_region_internal
, 3, 3, 0,
3069 doc
: /* Internal use only.
3070 From START to END, translate characters according to TABLE.
3071 TABLE is a string or a char-table; the Nth character in it is the
3072 mapping for the character with code N.
3073 It returns the number of characters changed. */)
3074 (Lisp_Object start
, Lisp_Object end
, register Lisp_Object table
)
3076 register unsigned char *tt
; /* Trans table. */
3077 register int nc
; /* New character. */
3078 int cnt
; /* Number of changes made. */
3079 ptrdiff_t size
; /* Size of translate table. */
3080 ptrdiff_t pos
, pos_byte
, end_pos
;
3081 int multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3082 int string_multibyte
IF_LINT (= 0);
3084 validate_region (&start
, &end
);
3085 if (CHAR_TABLE_P (table
))
3087 if (! EQ (XCHAR_TABLE (table
)->purpose
, Qtranslation_table
))
3088 error ("Not a translation table");
3094 CHECK_STRING (table
);
3096 if (! multibyte
&& (SCHARS (table
) < SBYTES (table
)))
3097 table
= string_make_unibyte (table
);
3098 string_multibyte
= SCHARS (table
) < SBYTES (table
);
3099 size
= SBYTES (table
);
3104 pos_byte
= CHAR_TO_BYTE (pos
);
3105 end_pos
= XINT (end
);
3106 modify_region (current_buffer
, pos
, end_pos
, 0);
3109 for (; pos
< end_pos
; )
3111 register unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
3112 unsigned char *str
, buf
[MAX_MULTIBYTE_LENGTH
];
3118 oc
= STRING_CHAR_AND_LENGTH (p
, len
);
3125 /* Reload as signal_after_change in last iteration may GC. */
3127 if (string_multibyte
)
3129 str
= tt
+ string_char_to_byte (table
, oc
);
3130 nc
= STRING_CHAR_AND_LENGTH (str
, str_len
);
3135 if (! ASCII_BYTE_P (nc
) && multibyte
)
3137 str_len
= BYTE8_STRING (nc
, buf
);
3150 val
= CHAR_TABLE_REF (table
, oc
);
3151 if (CHARACTERP (val
))
3153 nc
= XFASTINT (val
);
3154 str_len
= CHAR_STRING (nc
, buf
);
3157 else if (VECTORP (val
) || (CONSP (val
)))
3159 /* VAL is [TO_CHAR ...] or (([FROM-CHAR ...] . TO) ...)
3160 where TO is TO-CHAR or [TO-CHAR ...]. */
3165 if (nc
!= oc
&& nc
>= 0)
3167 /* Simple one char to one char translation. */
3172 /* This is less efficient, because it moves the gap,
3173 but it should handle multibyte characters correctly. */
3174 string
= make_multibyte_string ((char *) str
, 1, str_len
);
3175 replace_range (pos
, pos
+ 1, string
, 1, 0, 1);
3180 record_change (pos
, 1);
3181 while (str_len
-- > 0)
3183 signal_after_change (pos
, 1, 1);
3184 update_compositions (pos
, pos
+ 1, CHECK_BORDER
);
3194 val
= check_translation (pos
, pos_byte
, end_pos
, val
);
3201 /* VAL is ([FROM-CHAR ...] . TO). */
3202 len
= ASIZE (XCAR (val
));
3210 string
= Fconcat (1, &val
);
3214 string
= Fmake_string (make_number (1), val
);
3216 replace_range (pos
, pos
+ len
, string
, 1, 0, 1);
3217 pos_byte
+= SBYTES (string
);
3218 pos
+= SCHARS (string
);
3219 cnt
+= SCHARS (string
);
3220 end_pos
+= SCHARS (string
) - len
;
3228 return make_number (cnt
);
3231 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
3232 doc
: /* Delete the text between START and END.
3233 If called interactively, delete the region between point and mark.
3234 This command deletes buffer text without modifying the kill ring. */)
3235 (Lisp_Object start
, Lisp_Object end
)
3237 validate_region (&start
, &end
);
3238 del_range (XINT (start
), XINT (end
));
3242 DEFUN ("delete-and-extract-region", Fdelete_and_extract_region
,
3243 Sdelete_and_extract_region
, 2, 2, 0,
3244 doc
: /* Delete the text between START and END and return it. */)
3245 (Lisp_Object start
, Lisp_Object end
)
3247 validate_region (&start
, &end
);
3248 if (XINT (start
) == XINT (end
))
3249 return empty_unibyte_string
;
3250 return del_range_1 (XINT (start
), XINT (end
), 1, 1);
3253 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
3254 doc
: /* Remove restrictions (narrowing) from current buffer.
3255 This allows the buffer's full text to be seen and edited. */)
3258 if (BEG
!= BEGV
|| Z
!= ZV
)
3259 current_buffer
->clip_changed
= 1;
3261 BEGV_BYTE
= BEG_BYTE
;
3262 SET_BUF_ZV_BOTH (current_buffer
, Z
, Z_BYTE
);
3263 /* Changing the buffer bounds invalidates any recorded current column. */
3264 invalidate_current_column ();
3268 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
3269 doc
: /* Restrict editing in this buffer to the current region.
3270 The rest of the text becomes temporarily invisible and untouchable
3271 but is not deleted; if you save the buffer in a file, the invisible
3272 text is included in the file. \\[widen] makes all visible again.
3273 See also `save-restriction'.
3275 When calling from a program, pass two arguments; positions (integers
3276 or markers) bounding the text that should remain visible. */)
3277 (register Lisp_Object start
, Lisp_Object end
)
3279 CHECK_NUMBER_COERCE_MARKER (start
);
3280 CHECK_NUMBER_COERCE_MARKER (end
);
3282 if (XINT (start
) > XINT (end
))
3285 tem
= start
; start
= end
; end
= tem
;
3288 if (!(BEG
<= XINT (start
) && XINT (start
) <= XINT (end
) && XINT (end
) <= Z
))
3289 args_out_of_range (start
, end
);
3291 if (BEGV
!= XFASTINT (start
) || ZV
!= XFASTINT (end
))
3292 current_buffer
->clip_changed
= 1;
3294 SET_BUF_BEGV (current_buffer
, XFASTINT (start
));
3295 SET_BUF_ZV (current_buffer
, XFASTINT (end
));
3296 if (PT
< XFASTINT (start
))
3297 SET_PT (XFASTINT (start
));
3298 if (PT
> XFASTINT (end
))
3299 SET_PT (XFASTINT (end
));
3300 /* Changing the buffer bounds invalidates any recorded current column. */
3301 invalidate_current_column ();
3306 save_restriction_save (void)
3308 if (BEGV
== BEG
&& ZV
== Z
)
3309 /* The common case that the buffer isn't narrowed.
3310 We return just the buffer object, which save_restriction_restore
3311 recognizes as meaning `no restriction'. */
3312 return Fcurrent_buffer ();
3314 /* We have to save a restriction, so return a pair of markers, one
3315 for the beginning and one for the end. */
3317 Lisp_Object beg
, end
;
3319 beg
= build_marker (current_buffer
, BEGV
, BEGV_BYTE
);
3320 end
= build_marker (current_buffer
, ZV
, ZV_BYTE
);
3322 /* END must move forward if text is inserted at its exact location. */
3323 XMARKER (end
)->insertion_type
= 1;
3325 return Fcons (beg
, end
);
3330 save_restriction_restore (Lisp_Object data
)
3332 struct buffer
*cur
= NULL
;
3333 struct buffer
*buf
= (CONSP (data
)
3334 ? XMARKER (XCAR (data
))->buffer
3337 if (buf
&& buf
!= current_buffer
&& !NILP (BVAR (buf
, pt_marker
)))
3338 { /* If `buf' uses markers to keep track of PT, BEGV, and ZV (as
3339 is the case if it is or has an indirect buffer), then make
3340 sure it is current before we update BEGV, so
3341 set_buffer_internal takes care of managing those markers. */
3342 cur
= current_buffer
;
3343 set_buffer_internal (buf
);
3347 /* A pair of marks bounding a saved restriction. */
3349 struct Lisp_Marker
*beg
= XMARKER (XCAR (data
));
3350 struct Lisp_Marker
*end
= XMARKER (XCDR (data
));
3351 eassert (buf
== end
->buffer
);
3353 if (buf
/* Verify marker still points to a buffer. */
3354 && (beg
->charpos
!= BUF_BEGV (buf
) || end
->charpos
!= BUF_ZV (buf
)))
3355 /* The restriction has changed from the saved one, so restore
3356 the saved restriction. */
3358 ptrdiff_t pt
= BUF_PT (buf
);
3360 SET_BUF_BEGV_BOTH (buf
, beg
->charpos
, beg
->bytepos
);
3361 SET_BUF_ZV_BOTH (buf
, end
->charpos
, end
->bytepos
);
3363 if (pt
< beg
->charpos
|| pt
> end
->charpos
)
3364 /* The point is outside the new visible range, move it inside. */
3365 SET_BUF_PT_BOTH (buf
,
3366 clip_to_bounds (beg
->charpos
, pt
, end
->charpos
),
3367 clip_to_bounds (beg
->bytepos
, BUF_PT_BYTE (buf
),
3370 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3372 /* These aren't needed anymore, so don't wait for GC. */
3373 free_marker (XCAR (data
));
3374 free_marker (XCDR (data
));
3375 free_cons (XCONS (data
));
3378 /* A buffer, which means that there was no old restriction. */
3380 if (buf
/* Verify marker still points to a buffer. */
3381 && (BUF_BEGV (buf
) != BUF_BEG (buf
) || BUF_ZV (buf
) != BUF_Z (buf
)))
3382 /* The buffer has been narrowed, get rid of the narrowing. */
3384 SET_BUF_BEGV_BOTH (buf
, BUF_BEG (buf
), BUF_BEG_BYTE (buf
));
3385 SET_BUF_ZV_BOTH (buf
, BUF_Z (buf
), BUF_Z_BYTE (buf
));
3387 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3391 /* Changing the buffer bounds invalidates any recorded current column. */
3392 invalidate_current_column ();
3395 set_buffer_internal (cur
);
3400 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
3401 doc
: /* Execute BODY, saving and restoring current buffer's restrictions.
3402 The buffer's restrictions make parts of the beginning and end invisible.
3403 \(They are set up with `narrow-to-region' and eliminated with `widen'.)
3404 This special form, `save-restriction', saves the current buffer's restrictions
3405 when it is entered, and restores them when it is exited.
3406 So any `narrow-to-region' within BODY lasts only until the end of the form.
3407 The old restrictions settings are restored
3408 even in case of abnormal exit (throw or error).
3410 The value returned is the value of the last form in BODY.
3412 Note: if you are using both `save-excursion' and `save-restriction',
3413 use `save-excursion' outermost:
3414 (save-excursion (save-restriction ...))
3416 usage: (save-restriction &rest BODY) */)
3419 register Lisp_Object val
;
3420 ptrdiff_t count
= SPECPDL_INDEX ();
3422 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
3423 val
= Fprogn (body
);
3424 return unbind_to (count
, val
);
3427 /* Buffer for the most recent text displayed by Fmessage_box. */
3428 static char *message_text
;
3430 /* Allocated length of that buffer. */
3431 static ptrdiff_t message_length
;
3433 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
3434 doc
: /* Display a message at the bottom of the screen.
3435 The message also goes into the `*Messages*' buffer.
3436 \(In keyboard macros, that's all it does.)
3439 The first argument is a format control string, and the rest are data
3440 to be formatted under control of the string. See `format' for details.
3442 Note: Use (message "%s" VALUE) to print the value of expressions and
3443 variables to avoid accidentally interpreting `%' as format specifiers.
3445 If the first argument is nil or the empty string, the function clears
3446 any existing message; this lets the minibuffer contents show. See
3447 also `current-message'.
3449 usage: (message FORMAT-STRING &rest ARGS) */)
3450 (ptrdiff_t nargs
, Lisp_Object
*args
)
3453 || (STRINGP (args
[0])
3454 && SBYTES (args
[0]) == 0))
3461 register Lisp_Object val
;
3462 val
= Fformat (nargs
, args
);
3463 message3 (val
, SBYTES (val
), STRING_MULTIBYTE (val
));
3468 DEFUN ("message-box", Fmessage_box
, Smessage_box
, 1, MANY
, 0,
3469 doc
: /* Display a message, in a dialog box if possible.
3470 If a dialog box is not available, use the echo area.
3471 The first argument is a format control string, and the rest are data
3472 to be formatted under control of the string. See `format' for details.
3474 If the first argument is nil or the empty string, clear any existing
3475 message; let the minibuffer contents show.
3477 usage: (message-box FORMAT-STRING &rest ARGS) */)
3478 (ptrdiff_t nargs
, Lisp_Object
*args
)
3487 register Lisp_Object val
;
3488 val
= Fformat (nargs
, args
);
3490 /* The MS-DOS frames support popup menus even though they are
3491 not FRAME_WINDOW_P. */
3492 if (FRAME_WINDOW_P (XFRAME (selected_frame
))
3493 || FRAME_MSDOS_P (XFRAME (selected_frame
)))
3495 Lisp_Object pane
, menu
;
3496 struct gcpro gcpro1
;
3497 pane
= Fcons (Fcons (build_string ("OK"), Qt
), Qnil
);
3499 menu
= Fcons (val
, pane
);
3500 Fx_popup_dialog (Qt
, menu
, Qt
);
3504 #endif /* HAVE_MENUS */
3505 /* Copy the data so that it won't move when we GC. */
3506 if (SBYTES (val
) > message_length
)
3508 ptrdiff_t new_length
= SBYTES (val
) + 80;
3509 message_text
= xrealloc (message_text
, new_length
);
3510 message_length
= new_length
;
3512 memcpy (message_text
, SDATA (val
), SBYTES (val
));
3513 message2 (message_text
, SBYTES (val
),
3514 STRING_MULTIBYTE (val
));
3519 DEFUN ("message-or-box", Fmessage_or_box
, Smessage_or_box
, 1, MANY
, 0,
3520 doc
: /* Display a message in a dialog box or in the echo area.
3521 If this command was invoked with the mouse, use a dialog box if
3522 `use-dialog-box' is non-nil.
3523 Otherwise, use the echo area.
3524 The first argument is a format control string, and the rest are data
3525 to be formatted under control of the string. See `format' for details.
3527 If the first argument is nil or the empty string, clear any existing
3528 message; let the minibuffer contents show.
3530 usage: (message-or-box FORMAT-STRING &rest ARGS) */)
3531 (ptrdiff_t nargs
, Lisp_Object
*args
)
3534 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3536 return Fmessage_box (nargs
, args
);
3538 return Fmessage (nargs
, args
);
3541 DEFUN ("current-message", Fcurrent_message
, Scurrent_message
, 0, 0, 0,
3542 doc
: /* Return the string currently displayed in the echo area, or nil if none. */)
3545 return current_message ();
3549 DEFUN ("propertize", Fpropertize
, Spropertize
, 1, MANY
, 0,
3550 doc
: /* Return a copy of STRING with text properties added.
3551 First argument is the string to copy.
3552 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
3553 properties to add to the result.
3554 usage: (propertize STRING &rest PROPERTIES) */)
3555 (ptrdiff_t nargs
, Lisp_Object
*args
)
3557 Lisp_Object properties
, string
;
3558 struct gcpro gcpro1
, gcpro2
;
3561 /* Number of args must be odd. */
3562 if ((nargs
& 1) == 0)
3563 error ("Wrong number of arguments");
3565 properties
= string
= Qnil
;
3566 GCPRO2 (properties
, string
);
3568 /* First argument must be a string. */
3569 CHECK_STRING (args
[0]);
3570 string
= Fcopy_sequence (args
[0]);
3572 for (i
= 1; i
< nargs
; i
+= 2)
3573 properties
= Fcons (args
[i
], Fcons (args
[i
+ 1], properties
));
3575 Fadd_text_properties (make_number (0),
3576 make_number (SCHARS (string
)),
3577 properties
, string
);
3578 RETURN_UNGCPRO (string
);
3581 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
3582 doc
: /* Format a string out of a format-string and arguments.
3583 The first argument is a format control string.
3584 The other arguments are substituted into it to make the result, a string.
3586 The format control string may contain %-sequences meaning to substitute
3587 the next available argument:
3589 %s means print a string argument. Actually, prints any object, with `princ'.
3590 %d means print as number in decimal (%o octal, %x hex).
3591 %X is like %x, but uses upper case.
3592 %e means print a number in exponential notation.
3593 %f means print a number in decimal-point notation.
3594 %g means print a number in exponential notation
3595 or decimal-point notation, whichever uses fewer characters.
3596 %c means print a number as a single character.
3597 %S means print any object as an s-expression (using `prin1').
3599 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.
3600 Use %% to put a single % into the output.
3602 A %-sequence may contain optional flag, width, and precision
3603 specifiers, as follows:
3605 %<flags><width><precision>character
3607 where flags is [+ #-0]+, width is [0-9]+, and precision is .[0-9]+
3609 The + flag character inserts a + before any positive number, while a
3610 space inserts a space before any positive number; these flags only
3611 affect %d, %e, %f, and %g sequences, and the + flag takes precedence.
3612 The - and 0 flags affect the width specifier, as described below.
3614 The # flag means to use an alternate display form for %o, %x, %X, %e,
3615 %f, and %g sequences: for %o, it ensures that the result begins with
3616 \"0\"; for %x and %X, it prefixes the result with \"0x\" or \"0X\";
3617 for %e, %f, and %g, it causes a decimal point to be included even if
3618 the precision is zero.
3620 The width specifier supplies a lower limit for the length of the
3621 printed representation. The padding, if any, normally goes on the
3622 left, but it goes on the right if the - flag is present. The padding
3623 character is normally a space, but it is 0 if the 0 flag is present.
3624 The 0 flag is ignored if the - flag is present, or the format sequence
3625 is something other than %d, %e, %f, and %g.
3627 For %e, %f, and %g sequences, the number after the "." in the
3628 precision specifier says how many decimal places to show; if zero, the
3629 decimal point itself is omitted. For %s and %S, the precision
3630 specifier truncates the string to the given width.
3632 usage: (format STRING &rest OBJECTS) */)
3633 (ptrdiff_t nargs
, Lisp_Object
*args
)
3635 ptrdiff_t n
; /* The number of the next arg to substitute */
3636 char initial_buffer
[4000];
3637 char *buf
= initial_buffer
;
3638 ptrdiff_t bufsize
= sizeof initial_buffer
;
3639 ptrdiff_t max_bufsize
= STRING_BYTES_BOUND
+ 1;
3641 Lisp_Object buf_save_value
IF_LINT (= {0});
3642 char *format
, *end
, *format_start
;
3643 ptrdiff_t formatlen
, nchars
;
3644 /* True if the format is multibyte. */
3645 bool multibyte_format
= 0;
3646 /* True if the output should be a multibyte string,
3647 which is true if any of the inputs is one. */
3649 /* When we make a multibyte string, we must pay attention to the
3650 byte combining problem, i.e., a byte may be combined with a
3651 multibyte character of the previous string. This flag tells if we
3652 must consider such a situation or not. */
3653 int maybe_combine_byte
;
3655 int arg_intervals
= 0;
3658 /* discarded[I] is 1 if byte I of the format
3659 string was not copied into the output.
3660 It is 2 if byte I was not the first byte of its character. */
3663 /* Each element records, for one argument,
3664 the start and end bytepos in the output string,
3665 whether the argument has been converted to string (e.g., due to "%S"),
3666 and whether the argument is a string with intervals.
3667 info[0] is unused. Unused elements have -1 for start. */
3670 ptrdiff_t start
, end
;
3671 int converted_to_string
;
3675 /* It should not be necessary to GCPRO ARGS, because
3676 the caller in the interpreter should take care of that. */
3678 CHECK_STRING (args
[0]);
3679 format_start
= SSDATA (args
[0]);
3680 formatlen
= SBYTES (args
[0]);
3682 /* Allocate the info and discarded tables. */
3685 if ((SIZE_MAX
- formatlen
) / sizeof (struct info
) <= nargs
)
3686 memory_full (SIZE_MAX
);
3687 info
= SAFE_ALLOCA ((nargs
+ 1) * sizeof *info
+ formatlen
);
3688 discarded
= (char *) &info
[nargs
+ 1];
3689 for (i
= 0; i
< nargs
+ 1; i
++)
3692 info
[i
].intervals
= info
[i
].converted_to_string
= 0;
3694 memset (discarded
, 0, formatlen
);
3697 /* Try to determine whether the result should be multibyte.
3698 This is not always right; sometimes the result needs to be multibyte
3699 because of an object that we will pass through prin1,
3700 and in that case, we won't know it here. */
3701 multibyte_format
= STRING_MULTIBYTE (args
[0]);
3702 multibyte
= multibyte_format
;
3703 for (n
= 1; !multibyte
&& n
< nargs
; n
++)
3704 if (STRINGP (args
[n
]) && STRING_MULTIBYTE (args
[n
]))
3707 /* If we start out planning a unibyte result,
3708 then discover it has to be multibyte, we jump back to retry. */
3715 /* Scan the format and store result in BUF. */
3716 format
= format_start
;
3717 end
= format
+ formatlen
;
3718 maybe_combine_byte
= 0;
3720 while (format
!= end
)
3722 /* The values of N and FORMAT when the loop body is entered. */
3724 char *format0
= format
;
3726 /* Bytes needed to represent the output of this conversion. */
3727 ptrdiff_t convbytes
;
3731 /* General format specifications look like
3733 '%' [flags] [field-width] [precision] format
3738 field-width ::= [0-9]+
3739 precision ::= '.' [0-9]*
3741 If a field-width is specified, it specifies to which width
3742 the output should be padded with blanks, if the output
3743 string is shorter than field-width.
3745 If precision is specified, it specifies the number of
3746 digits to print after the '.' for floats, or the max.
3747 number of chars to print from a string. */
3754 ptrdiff_t field_width
;
3755 int precision_given
;
3756 uintmax_t precision
= UINTMAX_MAX
;
3764 case '-': minus_flag
= 1; continue;
3765 case '+': plus_flag
= 1; continue;
3766 case ' ': space_flag
= 1; continue;
3767 case '#': sharp_flag
= 1; continue;
3768 case '0': zero_flag
= 1; continue;
3773 /* Ignore flags when sprintf ignores them. */
3774 space_flag
&= ~ plus_flag
;
3775 zero_flag
&= ~ minus_flag
;
3778 uintmax_t w
= strtoumax (format
, &num_end
, 10);
3779 if (max_bufsize
<= w
)
3783 precision_given
= *num_end
== '.';
3784 if (precision_given
)
3785 precision
= strtoumax (num_end
+ 1, &num_end
, 10);
3789 error ("Format string ends in middle of format specifier");
3791 memset (&discarded
[format0
- format_start
], 1, format
- format0
);
3792 conversion
= *format
;
3793 if (conversion
== '%')
3795 discarded
[format
- format_start
] = 1;
3800 error ("Not enough arguments for format string");
3802 /* For 'S', prin1 the argument, and then treat like 's'.
3803 For 's', princ any argument that is not a string or
3804 symbol. But don't do this conversion twice, which might
3805 happen after retrying. */
3806 if ((conversion
== 'S'
3807 || (conversion
== 's'
3808 && ! STRINGP (args
[n
]) && ! SYMBOLP (args
[n
]))))
3810 if (! info
[n
].converted_to_string
)
3812 Lisp_Object noescape
= conversion
== 'S' ? Qnil
: Qt
;
3813 args
[n
] = Fprin1_to_string (args
[n
], noescape
);
3814 info
[n
].converted_to_string
= 1;
3815 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
3823 else if (conversion
== 'c')
3825 if (FLOATP (args
[n
]))
3827 double d
= XFLOAT_DATA (args
[n
]);
3828 args
[n
] = make_number (FIXNUM_OVERFLOW_P (d
) ? -1 : d
);
3831 if (INTEGERP (args
[n
]) && ! ASCII_CHAR_P (XINT (args
[n
])))
3838 args
[n
] = Fchar_to_string (args
[n
]);
3839 info
[n
].converted_to_string
= 1;
3842 if (info
[n
].converted_to_string
)
3847 if (SYMBOLP (args
[n
]))
3849 args
[n
] = SYMBOL_NAME (args
[n
]);
3850 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
3857 if (conversion
== 's')
3859 /* handle case (precision[n] >= 0) */
3861 ptrdiff_t width
, padding
, nbytes
;
3862 ptrdiff_t nchars_string
;
3864 ptrdiff_t prec
= -1;
3865 if (precision_given
&& precision
<= TYPE_MAXIMUM (ptrdiff_t))
3868 /* lisp_string_width ignores a precision of 0, but GNU
3869 libc functions print 0 characters when the precision
3870 is 0. Imitate libc behavior here. Changing
3871 lisp_string_width is the right thing, and will be
3872 done, but meanwhile we work with it. */
3875 width
= nchars_string
= nbytes
= 0;
3879 width
= lisp_string_width (args
[n
], prec
, &nch
, &nby
);
3882 nchars_string
= SCHARS (args
[n
]);
3883 nbytes
= SBYTES (args
[n
]);
3887 nchars_string
= nch
;
3893 if (convbytes
&& multibyte
&& ! STRING_MULTIBYTE (args
[n
]))
3894 convbytes
= count_size_as_multibyte (SDATA (args
[n
]), nbytes
);
3896 padding
= width
< field_width
? field_width
- width
: 0;
3898 if (max_bufsize
- padding
<= convbytes
)
3900 convbytes
+= padding
;
3901 if (convbytes
<= buf
+ bufsize
- p
)
3905 memset (p
, ' ', padding
);
3912 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3913 && STRING_MULTIBYTE (args
[n
])
3914 && !CHAR_HEAD_P (SREF (args
[n
], 0)))
3915 maybe_combine_byte
= 1;
3917 p
+= copy_text (SDATA (args
[n
]), (unsigned char *) p
,
3919 STRING_MULTIBYTE (args
[n
]), multibyte
);
3921 info
[n
].start
= nchars
;
3922 nchars
+= nchars_string
;
3923 info
[n
].end
= nchars
;
3927 memset (p
, ' ', padding
);
3932 /* If this argument has text properties, record where
3933 in the result string it appears. */
3934 if (string_intervals (args
[n
]))
3935 info
[n
].intervals
= arg_intervals
= 1;
3940 else if (! (conversion
== 'c' || conversion
== 'd'
3941 || conversion
== 'e' || conversion
== 'f'
3942 || conversion
== 'g' || conversion
== 'i'
3943 || conversion
== 'o' || conversion
== 'x'
3944 || conversion
== 'X'))
3945 error ("Invalid format operation %%%c",
3946 STRING_CHAR ((unsigned char *) format
- 1));
3947 else if (! (INTEGERP (args
[n
]) || FLOATP (args
[n
])))
3948 error ("Format specifier doesn't match argument type");
3953 /* Maximum precision for a %f conversion such that the
3954 trailing output digit might be nonzero. Any precision
3955 larger than this will not yield useful information. */
3956 USEFUL_PRECISION_MAX
=
3958 * (FLT_RADIX
== 2 || FLT_RADIX
== 10 ? 1
3959 : FLT_RADIX
== 16 ? 4
3962 /* Maximum number of bytes generated by any format, if
3963 precision is no more than USEFUL_PRECISION_MAX.
3964 On all practical hosts, %f is the worst case. */
3966 sizeof "-." + (DBL_MAX_10_EXP
+ 1) + USEFUL_PRECISION_MAX
,
3968 /* Length of pM (that is, of pMd without the
3970 pMlen
= sizeof pMd
- 2
3972 verify (0 < USEFUL_PRECISION_MAX
);
3975 ptrdiff_t padding
, sprintf_bytes
;
3976 uintmax_t excess_precision
, numwidth
;
3977 uintmax_t leading_zeros
= 0, trailing_zeros
= 0;
3979 char sprintf_buf
[SPRINTF_BUFSIZE
];
3981 /* Copy of conversion specification, modified somewhat.
3982 At most three flags F can be specified at once. */
3983 char convspec
[sizeof "%FFF.*d" + pMlen
];
3985 /* Avoid undefined behavior in underlying sprintf. */
3986 if (conversion
== 'd' || conversion
== 'i')
3989 /* Create the copy of the conversion specification, with
3990 any width and precision removed, with ".*" inserted,
3991 and with pM inserted for integer formats. */
3995 *f
= '-'; f
+= minus_flag
;
3996 *f
= '+'; f
+= plus_flag
;
3997 *f
= ' '; f
+= space_flag
;
3998 *f
= '#'; f
+= sharp_flag
;
3999 *f
= '0'; f
+= zero_flag
;
4002 if (conversion
== 'd' || conversion
== 'i'
4003 || conversion
== 'o' || conversion
== 'x'
4004 || conversion
== 'X')
4006 memcpy (f
, pMd
, pMlen
);
4008 zero_flag
&= ~ precision_given
;
4015 if (precision_given
)
4016 prec
= min (precision
, USEFUL_PRECISION_MAX
);
4018 /* Use sprintf to format this number into sprintf_buf. Omit
4019 padding and excess precision, though, because sprintf limits
4020 output length to INT_MAX.
4022 There are four types of conversion: double, unsigned
4023 char (passed as int), wide signed int, and wide
4024 unsigned int. Treat them separately because the
4025 sprintf ABI is sensitive to which type is passed. Be
4026 careful about integer overflow, NaNs, infinities, and
4027 conversions; for example, the min and max macros are
4028 not suitable here. */
4029 if (conversion
== 'e' || conversion
== 'f' || conversion
== 'g')
4031 double x
= (INTEGERP (args
[n
])
4033 : XFLOAT_DATA (args
[n
]));
4034 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4036 else if (conversion
== 'c')
4038 /* Don't use sprintf here, as it might mishandle prec. */
4039 sprintf_buf
[0] = XINT (args
[n
]);
4040 sprintf_bytes
= prec
!= 0;
4042 else if (conversion
== 'd')
4044 /* For float, maybe we should use "%1.0f"
4045 instead so it also works for values outside
4046 the integer range. */
4048 if (INTEGERP (args
[n
]))
4052 double d
= XFLOAT_DATA (args
[n
]);
4055 x
= TYPE_MINIMUM (printmax_t
);
4061 x
= TYPE_MAXIMUM (printmax_t
);
4066 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4070 /* Don't sign-extend for octal or hex printing. */
4072 if (INTEGERP (args
[n
]))
4073 x
= XUINT (args
[n
]);
4076 double d
= XFLOAT_DATA (args
[n
]);
4081 x
= TYPE_MAXIMUM (uprintmax_t
);
4086 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4089 /* Now the length of the formatted item is known, except it omits
4090 padding and excess precision. Deal with excess precision
4091 first. This happens only when the format specifies
4092 ridiculously large precision. */
4093 excess_precision
= precision
- prec
;
4094 if (excess_precision
)
4096 if (conversion
== 'e' || conversion
== 'f'
4097 || conversion
== 'g')
4099 if ((conversion
== 'g' && ! sharp_flag
)
4100 || ! ('0' <= sprintf_buf
[sprintf_bytes
- 1]
4101 && sprintf_buf
[sprintf_bytes
- 1] <= '9'))
4102 excess_precision
= 0;
4105 if (conversion
== 'g')
4107 char *dot
= strchr (sprintf_buf
, '.');
4109 excess_precision
= 0;
4112 trailing_zeros
= excess_precision
;
4115 leading_zeros
= excess_precision
;
4118 /* Compute the total bytes needed for this item, including
4119 excess precision and padding. */
4120 numwidth
= sprintf_bytes
+ excess_precision
;
4121 padding
= numwidth
< field_width
? field_width
- numwidth
: 0;
4122 if (max_bufsize
- sprintf_bytes
<= excess_precision
4123 || max_bufsize
- padding
<= numwidth
)
4125 convbytes
= numwidth
+ padding
;
4127 if (convbytes
<= buf
+ bufsize
- p
)
4129 /* Copy the formatted item from sprintf_buf into buf,
4130 inserting padding and excess-precision zeros. */
4132 char *src
= sprintf_buf
;
4134 int exponent_bytes
= 0;
4135 int signedp
= src0
== '-' || src0
== '+' || src0
== ' ';
4136 int significand_bytes
;
4138 && ((src
[signedp
] >= '0' && src
[signedp
] <= '9')
4139 || (src
[signedp
] >= 'a' && src
[signedp
] <= 'f')
4140 || (src
[signedp
] >= 'A' && src
[signedp
] <= 'F')))
4142 leading_zeros
+= padding
;
4146 if (excess_precision
4147 && (conversion
== 'e' || conversion
== 'g'))
4149 char *e
= strchr (src
, 'e');
4151 exponent_bytes
= src
+ sprintf_bytes
- e
;
4156 memset (p
, ' ', padding
);
4164 memset (p
, '0', leading_zeros
);
4166 significand_bytes
= sprintf_bytes
- signedp
- exponent_bytes
;
4167 memcpy (p
, src
, significand_bytes
);
4168 p
+= significand_bytes
;
4169 src
+= significand_bytes
;
4170 memset (p
, '0', trailing_zeros
);
4171 p
+= trailing_zeros
;
4172 memcpy (p
, src
, exponent_bytes
);
4173 p
+= exponent_bytes
;
4175 info
[n
].start
= nchars
;
4176 nchars
+= leading_zeros
+ sprintf_bytes
+ trailing_zeros
;
4177 info
[n
].end
= nchars
;
4181 memset (p
, ' ', padding
);
4193 /* Copy a single character from format to buf. */
4196 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
4198 if (multibyte_format
)
4200 /* Copy a whole multibyte character. */
4202 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
4203 && !CHAR_HEAD_P (*format
))
4204 maybe_combine_byte
= 1;
4208 while (! CHAR_HEAD_P (*format
));
4210 convbytes
= format
- src
;
4211 memset (&discarded
[src
+ 1 - format_start
], 2, convbytes
- 1);
4215 unsigned char uc
= *format
++;
4216 if (! multibyte
|| ASCII_BYTE_P (uc
))
4220 int c
= BYTE8_TO_CHAR (uc
);
4221 convbytes
= CHAR_STRING (c
, str
);
4226 if (convbytes
<= buf
+ bufsize
- p
)
4228 memcpy (p
, src
, convbytes
);
4235 /* There wasn't enough room to store this conversion or single
4236 character. CONVBYTES says how much room is needed. Allocate
4237 enough room (and then some) and do it again. */
4239 ptrdiff_t used
= p
- buf
;
4241 if (max_bufsize
- used
< convbytes
)
4243 bufsize
= used
+ convbytes
;
4244 bufsize
= bufsize
< max_bufsize
/ 2 ? bufsize
* 2 : max_bufsize
;
4246 if (buf
== initial_buffer
)
4248 buf
= xmalloc (bufsize
);
4250 buf_save_value
= make_save_value (buf
, 0);
4251 record_unwind_protect (safe_alloca_unwind
, buf_save_value
);
4252 memcpy (buf
, initial_buffer
, used
);
4255 XSAVE_VALUE (buf_save_value
)->pointer
= buf
= xrealloc (buf
, bufsize
);
4264 if (bufsize
< p
- buf
)
4267 if (maybe_combine_byte
)
4268 nchars
= multibyte_chars_in_text ((unsigned char *) buf
, p
- buf
);
4269 val
= make_specified_string (buf
, nchars
, p
- buf
, multibyte
);
4271 /* If we allocated BUF with malloc, free it too. */
4274 /* If the format string has text properties, or any of the string
4275 arguments has text properties, set up text properties of the
4278 if (string_intervals (args
[0]) || arg_intervals
)
4280 Lisp_Object len
, new_len
, props
;
4281 struct gcpro gcpro1
;
4283 /* Add text properties from the format string. */
4284 len
= make_number (SCHARS (args
[0]));
4285 props
= text_property_list (args
[0], make_number (0), len
, Qnil
);
4290 ptrdiff_t bytepos
= 0, position
= 0, translated
= 0;
4294 /* Adjust the bounds of each text property
4295 to the proper start and end in the output string. */
4297 /* Put the positions in PROPS in increasing order, so that
4298 we can do (effectively) one scan through the position
4299 space of the format string. */
4300 props
= Fnreverse (props
);
4302 /* BYTEPOS is the byte position in the format string,
4303 POSITION is the untranslated char position in it,
4304 TRANSLATED is the translated char position in BUF,
4305 and ARGN is the number of the next arg we will come to. */
4306 for (list
= props
; CONSP (list
); list
= XCDR (list
))
4313 /* First adjust the property start position. */
4314 pos
= XINT (XCAR (item
));
4316 /* Advance BYTEPOS, POSITION, TRANSLATED and ARGN
4317 up to this position. */
4318 for (; position
< pos
; bytepos
++)
4320 if (! discarded
[bytepos
])
4321 position
++, translated
++;
4322 else if (discarded
[bytepos
] == 1)
4325 if (translated
== info
[argn
].start
)
4327 translated
+= info
[argn
].end
- info
[argn
].start
;
4333 XSETCAR (item
, make_number (translated
));
4335 /* Likewise adjust the property end position. */
4336 pos
= XINT (XCAR (XCDR (item
)));
4338 for (; position
< pos
; bytepos
++)
4340 if (! discarded
[bytepos
])
4341 position
++, translated
++;
4342 else if (discarded
[bytepos
] == 1)
4345 if (translated
== info
[argn
].start
)
4347 translated
+= info
[argn
].end
- info
[argn
].start
;
4353 XSETCAR (XCDR (item
), make_number (translated
));
4356 add_text_properties_from_list (val
, props
, make_number (0));
4359 /* Add text properties from arguments. */
4361 for (n
= 1; n
< nargs
; ++n
)
4362 if (info
[n
].intervals
)
4364 len
= make_number (SCHARS (args
[n
]));
4365 new_len
= make_number (info
[n
].end
- info
[n
].start
);
4366 props
= text_property_list (args
[n
], make_number (0), len
, Qnil
);
4367 props
= extend_property_ranges (props
, new_len
);
4368 /* If successive arguments have properties, be sure that
4369 the value of `composition' property be the copy. */
4370 if (n
> 1 && info
[n
- 1].end
)
4371 make_composition_value_copy (props
);
4372 add_text_properties_from_list (val
, props
,
4373 make_number (info
[n
].start
));
4383 format2 (const char *string1
, Lisp_Object arg0
, Lisp_Object arg1
)
4385 Lisp_Object args
[3];
4386 args
[0] = build_string (string1
);
4389 return Fformat (3, args
);
4392 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
4393 doc
: /* Return t if two characters match, optionally ignoring case.
4394 Both arguments must be characters (i.e. integers).
4395 Case is ignored if `case-fold-search' is non-nil in the current buffer. */)
4396 (register Lisp_Object c1
, Lisp_Object c2
)
4399 /* Check they're chars, not just integers, otherwise we could get array
4400 bounds violations in downcase. */
4401 CHECK_CHARACTER (c1
);
4402 CHECK_CHARACTER (c2
);
4404 if (XINT (c1
) == XINT (c2
))
4406 if (NILP (BVAR (current_buffer
, case_fold_search
)))
4410 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
))
4411 && ! ASCII_CHAR_P (i1
))
4413 MAKE_CHAR_MULTIBYTE (i1
);
4416 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
))
4417 && ! ASCII_CHAR_P (i2
))
4419 MAKE_CHAR_MULTIBYTE (i2
);
4421 return (downcase (i1
) == downcase (i2
) ? Qt
: Qnil
);
4424 /* Transpose the markers in two regions of the current buffer, and
4425 adjust the ones between them if necessary (i.e.: if the regions
4428 START1, END1 are the character positions of the first region.
4429 START1_BYTE, END1_BYTE are the byte positions.
4430 START2, END2 are the character positions of the second region.
4431 START2_BYTE, END2_BYTE are the byte positions.
4433 Traverses the entire marker list of the buffer to do so, adding an
4434 appropriate amount to some, subtracting from some, and leaving the
4435 rest untouched. Most of this is copied from adjust_markers in insdel.c.
4437 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
4440 transpose_markers (ptrdiff_t start1
, ptrdiff_t end1
,
4441 ptrdiff_t start2
, ptrdiff_t end2
,
4442 ptrdiff_t start1_byte
, ptrdiff_t end1_byte
,
4443 ptrdiff_t start2_byte
, ptrdiff_t end2_byte
)
4445 register ptrdiff_t amt1
, amt1_byte
, amt2
, amt2_byte
, diff
, diff_byte
, mpos
;
4446 register struct Lisp_Marker
*marker
;
4448 /* Update point as if it were a marker. */
4452 TEMP_SET_PT_BOTH (PT
+ (end2
- end1
),
4453 PT_BYTE
+ (end2_byte
- end1_byte
));
4454 else if (PT
< start2
)
4455 TEMP_SET_PT_BOTH (PT
+ (end2
- start2
) - (end1
- start1
),
4456 (PT_BYTE
+ (end2_byte
- start2_byte
)
4457 - (end1_byte
- start1_byte
)));
4459 TEMP_SET_PT_BOTH (PT
- (start2
- start1
),
4460 PT_BYTE
- (start2_byte
- start1_byte
));
4462 /* We used to adjust the endpoints here to account for the gap, but that
4463 isn't good enough. Even if we assume the caller has tried to move the
4464 gap out of our way, it might still be at start1 exactly, for example;
4465 and that places it `inside' the interval, for our purposes. The amount
4466 of adjustment is nontrivial if there's a `denormalized' marker whose
4467 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
4468 the dirty work to Fmarker_position, below. */
4470 /* The difference between the region's lengths */
4471 diff
= (end2
- start2
) - (end1
- start1
);
4472 diff_byte
= (end2_byte
- start2_byte
) - (end1_byte
- start1_byte
);
4474 /* For shifting each marker in a region by the length of the other
4475 region plus the distance between the regions. */
4476 amt1
= (end2
- start2
) + (start2
- end1
);
4477 amt2
= (end1
- start1
) + (start2
- end1
);
4478 amt1_byte
= (end2_byte
- start2_byte
) + (start2_byte
- end1_byte
);
4479 amt2_byte
= (end1_byte
- start1_byte
) + (start2_byte
- end1_byte
);
4481 for (marker
= BUF_MARKERS (current_buffer
); marker
; marker
= marker
->next
)
4483 mpos
= marker
->bytepos
;
4484 if (mpos
>= start1_byte
&& mpos
< end2_byte
)
4486 if (mpos
< end1_byte
)
4488 else if (mpos
< start2_byte
)
4492 marker
->bytepos
= mpos
;
4494 mpos
= marker
->charpos
;
4495 if (mpos
>= start1
&& mpos
< end2
)
4499 else if (mpos
< start2
)
4504 marker
->charpos
= mpos
;
4508 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
4509 doc
: /* Transpose region STARTR1 to ENDR1 with STARTR2 to ENDR2.
4510 The regions should not be overlapping, because the size of the buffer is
4511 never changed in a transposition.
4513 Optional fifth arg LEAVE-MARKERS, if non-nil, means don't update
4514 any markers that happen to be located in the regions.
4516 Transposing beyond buffer boundaries is an error. */)
4517 (Lisp_Object startr1
, Lisp_Object endr1
, Lisp_Object startr2
, Lisp_Object endr2
, Lisp_Object leave_markers
)
4519 register ptrdiff_t start1
, end1
, start2
, end2
;
4520 ptrdiff_t start1_byte
, start2_byte
, len1_byte
, len2_byte
;
4521 ptrdiff_t gap
, len1
, len_mid
, len2
;
4522 unsigned char *start1_addr
, *start2_addr
, *temp
;
4524 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
, tmp_interval3
;
4527 XSETBUFFER (buf
, current_buffer
);
4528 cur_intv
= buffer_intervals (current_buffer
);
4530 validate_region (&startr1
, &endr1
);
4531 validate_region (&startr2
, &endr2
);
4533 start1
= XFASTINT (startr1
);
4534 end1
= XFASTINT (endr1
);
4535 start2
= XFASTINT (startr2
);
4536 end2
= XFASTINT (endr2
);
4539 /* Swap the regions if they're reversed. */
4542 register ptrdiff_t glumph
= start1
;
4550 len1
= end1
- start1
;
4551 len2
= end2
- start2
;
4554 error ("Transposed regions overlap");
4555 /* Nothing to change for adjacent regions with one being empty */
4556 else if ((start1
== end1
|| start2
== end2
) && end1
== start2
)
4559 /* The possibilities are:
4560 1. Adjacent (contiguous) regions, or separate but equal regions
4561 (no, really equal, in this case!), or
4562 2. Separate regions of unequal size.
4564 The worst case is usually No. 2. It means that (aside from
4565 potential need for getting the gap out of the way), there also
4566 needs to be a shifting of the text between the two regions. So
4567 if they are spread far apart, we are that much slower... sigh. */
4569 /* It must be pointed out that the really studly thing to do would
4570 be not to move the gap at all, but to leave it in place and work
4571 around it if necessary. This would be extremely efficient,
4572 especially considering that people are likely to do
4573 transpositions near where they are working interactively, which
4574 is exactly where the gap would be found. However, such code
4575 would be much harder to write and to read. So, if you are
4576 reading this comment and are feeling squirrely, by all means have
4577 a go! I just didn't feel like doing it, so I will simply move
4578 the gap the minimum distance to get it out of the way, and then
4579 deal with an unbroken array. */
4581 /* Make sure the gap won't interfere, by moving it out of the text
4582 we will operate on. */
4583 if (start1
< gap
&& gap
< end2
)
4585 if (gap
- start1
< end2
- gap
)
4591 start1_byte
= CHAR_TO_BYTE (start1
);
4592 start2_byte
= CHAR_TO_BYTE (start2
);
4593 len1_byte
= CHAR_TO_BYTE (end1
) - start1_byte
;
4594 len2_byte
= CHAR_TO_BYTE (end2
) - start2_byte
;
4596 #ifdef BYTE_COMBINING_DEBUG
4599 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4600 len2_byte
, start1
, start1_byte
)
4601 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4602 len1_byte
, end2
, start2_byte
+ len2_byte
)
4603 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4604 len1_byte
, end2
, start2_byte
+ len2_byte
))
4609 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4610 len2_byte
, start1
, start1_byte
)
4611 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4612 len1_byte
, start2
, start2_byte
)
4613 || count_combining_after (BYTE_POS_ADDR (start2_byte
),
4614 len2_byte
, end1
, start1_byte
+ len1_byte
)
4615 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4616 len1_byte
, end2
, start2_byte
+ len2_byte
))
4621 /* Hmmm... how about checking to see if the gap is large
4622 enough to use as the temporary storage? That would avoid an
4623 allocation... interesting. Later, don't fool with it now. */
4625 /* Working without memmove, for portability (sigh), so must be
4626 careful of overlapping subsections of the array... */
4628 if (end1
== start2
) /* adjacent regions */
4630 modify_region (current_buffer
, start1
, end2
, 0);
4631 record_change (start1
, len1
+ len2
);
4633 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4634 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4635 /* Don't use Fset_text_properties: that can cause GC, which can
4636 clobber objects stored in the tmp_intervals. */
4637 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4639 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4641 /* First region smaller than second. */
4642 if (len1_byte
< len2_byte
)
4646 temp
= SAFE_ALLOCA (len2_byte
);
4648 /* Don't precompute these addresses. We have to compute them
4649 at the last minute, because the relocating allocator might
4650 have moved the buffer around during the xmalloc. */
4651 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4652 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4654 memcpy (temp
, start2_addr
, len2_byte
);
4655 memcpy (start1_addr
+ len2_byte
, start1_addr
, len1_byte
);
4656 memcpy (start1_addr
, temp
, len2_byte
);
4660 /* First region not smaller than second. */
4664 temp
= SAFE_ALLOCA (len1_byte
);
4665 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4666 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4667 memcpy (temp
, start1_addr
, len1_byte
);
4668 memcpy (start1_addr
, start2_addr
, len2_byte
);
4669 memcpy (start1_addr
+ len2_byte
, temp
, len1_byte
);
4672 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
4673 len1
, current_buffer
, 0);
4674 graft_intervals_into_buffer (tmp_interval2
, start1
,
4675 len2
, current_buffer
, 0);
4676 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4677 update_compositions (start1
+ len2
, end2
, CHECK_TAIL
);
4679 /* Non-adjacent regions, because end1 != start2, bleagh... */
4682 len_mid
= start2_byte
- (start1_byte
+ len1_byte
);
4684 if (len1_byte
== len2_byte
)
4685 /* Regions are same size, though, how nice. */
4689 modify_region (current_buffer
, start1
, end1
, 0);
4690 modify_region (current_buffer
, start2
, end2
, 0);
4691 record_change (start1
, len1
);
4692 record_change (start2
, len2
);
4693 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4694 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4696 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr1
, 0);
4698 set_text_properties_1 (startr1
, endr1
, Qnil
, buf
, tmp_interval3
);
4700 tmp_interval3
= validate_interval_range (buf
, &startr2
, &endr2
, 0);
4702 set_text_properties_1 (startr2
, endr2
, Qnil
, buf
, tmp_interval3
);
4704 temp
= SAFE_ALLOCA (len1_byte
);
4705 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4706 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4707 memcpy (temp
, start1_addr
, len1_byte
);
4708 memcpy (start1_addr
, start2_addr
, len2_byte
);
4709 memcpy (start2_addr
, temp
, len1_byte
);
4712 graft_intervals_into_buffer (tmp_interval1
, start2
,
4713 len1
, current_buffer
, 0);
4714 graft_intervals_into_buffer (tmp_interval2
, start1
,
4715 len2
, current_buffer
, 0);
4718 else if (len1_byte
< len2_byte
) /* Second region larger than first */
4719 /* Non-adjacent & unequal size, area between must also be shifted. */
4723 modify_region (current_buffer
, start1
, end2
, 0);
4724 record_change (start1
, (end2
- start1
));
4725 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4726 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4727 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4729 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4731 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4733 /* holds region 2 */
4734 temp
= SAFE_ALLOCA (len2_byte
);
4735 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4736 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4737 memcpy (temp
, start2_addr
, len2_byte
);
4738 memcpy (start1_addr
+ len_mid
+ len2_byte
, start1_addr
, len1_byte
);
4739 memmove (start1_addr
+ len2_byte
, start1_addr
+ len1_byte
, len_mid
);
4740 memcpy (start1_addr
, temp
, len2_byte
);
4743 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4744 len1
, current_buffer
, 0);
4745 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4746 len_mid
, current_buffer
, 0);
4747 graft_intervals_into_buffer (tmp_interval2
, start1
,
4748 len2
, current_buffer
, 0);
4751 /* Second region smaller than first. */
4755 record_change (start1
, (end2
- start1
));
4756 modify_region (current_buffer
, start1
, end2
, 0);
4758 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4759 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4760 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4762 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4764 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4766 /* holds region 1 */
4767 temp
= SAFE_ALLOCA (len1_byte
);
4768 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4769 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4770 memcpy (temp
, start1_addr
, len1_byte
);
4771 memcpy (start1_addr
, start2_addr
, len2_byte
);
4772 memcpy (start1_addr
+ len2_byte
, start1_addr
+ len1_byte
, len_mid
);
4773 memcpy (start1_addr
+ len2_byte
+ len_mid
, temp
, len1_byte
);
4776 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4777 len1
, current_buffer
, 0);
4778 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4779 len_mid
, current_buffer
, 0);
4780 graft_intervals_into_buffer (tmp_interval2
, start1
,
4781 len2
, current_buffer
, 0);
4784 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4785 update_compositions (end2
- len1
, end2
, CHECK_BORDER
);
4788 /* When doing multiple transpositions, it might be nice
4789 to optimize this. Perhaps the markers in any one buffer
4790 should be organized in some sorted data tree. */
4791 if (NILP (leave_markers
))
4793 transpose_markers (start1
, end1
, start2
, end2
,
4794 start1_byte
, start1_byte
+ len1_byte
,
4795 start2_byte
, start2_byte
+ len2_byte
);
4796 fix_start_end_in_overlays (start1
, end2
);
4799 signal_after_change (start1
, end2
- start1
, end2
- start1
);
4805 syms_of_editfns (void)
4810 DEFSYM (Qbuffer_access_fontify_functions
, "buffer-access-fontify-functions");
4812 DEFVAR_LISP ("inhibit-field-text-motion", Vinhibit_field_text_motion
,
4813 doc
: /* Non-nil means text motion commands don't notice fields. */);
4814 Vinhibit_field_text_motion
= Qnil
;
4816 DEFVAR_LISP ("buffer-access-fontify-functions",
4817 Vbuffer_access_fontify_functions
,
4818 doc
: /* List of functions called by `buffer-substring' to fontify if necessary.
4819 Each function is called with two arguments which specify the range
4820 of the buffer being accessed. */);
4821 Vbuffer_access_fontify_functions
= Qnil
;
4825 obuf
= Fcurrent_buffer ();
4826 /* Do this here, because init_buffer_once is too early--it won't work. */
4827 Fset_buffer (Vprin1_to_string_buffer
);
4828 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
4829 Fset (Fmake_local_variable (intern_c_string ("buffer-access-fontify-functions")),
4834 DEFVAR_LISP ("buffer-access-fontified-property",
4835 Vbuffer_access_fontified_property
,
4836 doc
: /* Property which (if non-nil) indicates text has been fontified.
4837 `buffer-substring' need not call the `buffer-access-fontify-functions'
4838 functions if all the text being accessed has this property. */);
4839 Vbuffer_access_fontified_property
= Qnil
;
4841 DEFVAR_LISP ("system-name", Vsystem_name
,
4842 doc
: /* The host name of the machine Emacs is running on. */);
4844 DEFVAR_LISP ("user-full-name", Vuser_full_name
,
4845 doc
: /* The full name of the user logged in. */);
4847 DEFVAR_LISP ("user-login-name", Vuser_login_name
,
4848 doc
: /* The user's name, taken from environment variables if possible. */);
4850 DEFVAR_LISP ("user-real-login-name", Vuser_real_login_name
,
4851 doc
: /* The user's name, based upon the real uid only. */);
4853 DEFVAR_LISP ("operating-system-release", Voperating_system_release
,
4854 doc
: /* The release of the operating system Emacs is running on. */);
4856 defsubr (&Spropertize
);
4857 defsubr (&Schar_equal
);
4858 defsubr (&Sgoto_char
);
4859 defsubr (&Sstring_to_char
);
4860 defsubr (&Schar_to_string
);
4861 defsubr (&Sbyte_to_string
);
4862 defsubr (&Sbuffer_substring
);
4863 defsubr (&Sbuffer_substring_no_properties
);
4864 defsubr (&Sbuffer_string
);
4866 defsubr (&Spoint_marker
);
4867 defsubr (&Smark_marker
);
4869 defsubr (&Sregion_beginning
);
4870 defsubr (&Sregion_end
);
4872 DEFSYM (Qfield
, "field");
4873 DEFSYM (Qboundary
, "boundary");
4874 defsubr (&Sfield_beginning
);
4875 defsubr (&Sfield_end
);
4876 defsubr (&Sfield_string
);
4877 defsubr (&Sfield_string_no_properties
);
4878 defsubr (&Sdelete_field
);
4879 defsubr (&Sconstrain_to_field
);
4881 defsubr (&Sline_beginning_position
);
4882 defsubr (&Sline_end_position
);
4884 /* defsubr (&Smark); */
4885 /* defsubr (&Sset_mark); */
4886 defsubr (&Ssave_excursion
);
4887 defsubr (&Ssave_current_buffer
);
4889 defsubr (&Sbufsize
);
4890 defsubr (&Spoint_max
);
4891 defsubr (&Spoint_min
);
4892 defsubr (&Spoint_min_marker
);
4893 defsubr (&Spoint_max_marker
);
4894 defsubr (&Sgap_position
);
4895 defsubr (&Sgap_size
);
4896 defsubr (&Sposition_bytes
);
4897 defsubr (&Sbyte_to_position
);
4903 defsubr (&Sfollowing_char
);
4904 defsubr (&Sprevious_char
);
4905 defsubr (&Schar_after
);
4906 defsubr (&Schar_before
);
4908 defsubr (&Sinsert_before_markers
);
4909 defsubr (&Sinsert_and_inherit
);
4910 defsubr (&Sinsert_and_inherit_before_markers
);
4911 defsubr (&Sinsert_char
);
4912 defsubr (&Sinsert_byte
);
4914 defsubr (&Suser_login_name
);
4915 defsubr (&Suser_real_login_name
);
4916 defsubr (&Suser_uid
);
4917 defsubr (&Suser_real_uid
);
4918 defsubr (&Suser_full_name
);
4919 defsubr (&Semacs_pid
);
4920 defsubr (&Scurrent_time
);
4921 defsubr (&Sget_internal_run_time
);
4922 defsubr (&Sformat_time_string
);
4923 defsubr (&Sfloat_time
);
4924 defsubr (&Sdecode_time
);
4925 defsubr (&Sencode_time
);
4926 defsubr (&Scurrent_time_string
);
4927 defsubr (&Scurrent_time_zone
);
4928 defsubr (&Sset_time_zone_rule
);
4929 defsubr (&Ssystem_name
);
4930 defsubr (&Smessage
);
4931 defsubr (&Smessage_box
);
4932 defsubr (&Smessage_or_box
);
4933 defsubr (&Scurrent_message
);
4936 defsubr (&Sinsert_buffer_substring
);
4937 defsubr (&Scompare_buffer_substrings
);
4938 defsubr (&Ssubst_char_in_region
);
4939 defsubr (&Stranslate_region_internal
);
4940 defsubr (&Sdelete_region
);
4941 defsubr (&Sdelete_and_extract_region
);
4943 defsubr (&Snarrow_to_region
);
4944 defsubr (&Ssave_restriction
);
4945 defsubr (&Stranspose_regions
);