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>
54 #include "intervals.h"
55 #include "character.h"
60 #include "blockinput.h"
62 #ifndef USER_FULL_NAME
63 #define USER_FULL_NAME pw->pw_gecos
67 extern char **environ
;
70 #define TM_YEAR_BASE 1900
73 extern Lisp_Object
w32_get_internal_run_time (void);
76 static Lisp_Object
format_time_string (char const *, ptrdiff_t, EMACS_TIME
,
78 static int tm_diff (struct tm
*, struct tm
*);
79 static void update_buffer_properties (ptrdiff_t, ptrdiff_t);
81 static Lisp_Object Qbuffer_access_fontify_functions
;
83 /* Symbol for the text property used to mark fields. */
87 /* A special value for Qfield properties. */
89 static Lisp_Object Qboundary
;
95 const char *user_name
;
97 struct passwd
*pw
; /* password entry for the current user */
100 /* Set up system_name even when dumping. */
104 /* Don't bother with this on initial start when just dumping out */
107 #endif /* not CANNOT_DUMP */
109 pw
= getpwuid (getuid ());
111 /* We let the real user name default to "root" because that's quite
112 accurate on MSDOG and because it lets Emacs find the init file.
113 (The DVX libraries override the Djgpp libraries here.) */
114 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "root");
116 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "unknown");
119 /* Get the effective user name, by consulting environment variables,
120 or the effective uid if those are unset. */
121 user_name
= getenv ("LOGNAME");
124 user_name
= getenv ("USERNAME"); /* it's USERNAME on NT */
125 #else /* WINDOWSNT */
126 user_name
= getenv ("USER");
127 #endif /* WINDOWSNT */
130 pw
= getpwuid (geteuid ());
131 user_name
= pw
? pw
->pw_name
: "unknown";
133 Vuser_login_name
= build_string (user_name
);
135 /* If the user name claimed in the environment vars differs from
136 the real uid, use the claimed name to find the full name. */
137 tem
= Fstring_equal (Vuser_login_name
, Vuser_real_login_name
);
139 tem
= Vuser_login_name
;
142 uid_t euid
= geteuid ();
143 tem
= make_fixnum_or_float (euid
);
145 Vuser_full_name
= Fuser_full_name (tem
);
149 Vuser_full_name
= build_string (p
);
150 else if (NILP (Vuser_full_name
))
151 Vuser_full_name
= build_string ("unknown");
153 #ifdef HAVE_SYS_UTSNAME_H
157 Voperating_system_release
= build_string (uts
.release
);
160 Voperating_system_release
= Qnil
;
164 DEFUN ("char-to-string", Fchar_to_string
, Schar_to_string
, 1, 1, 0,
165 doc
: /* Convert arg CHAR to a string containing that character.
166 usage: (char-to-string CHAR) */)
167 (Lisp_Object character
)
170 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
172 CHECK_CHARACTER (character
);
173 c
= XFASTINT (character
);
175 len
= CHAR_STRING (c
, str
);
176 return make_string_from_bytes ((char *) str
, 1, len
);
179 DEFUN ("byte-to-string", Fbyte_to_string
, Sbyte_to_string
, 1, 1, 0,
180 doc
: /* Convert arg BYTE to a unibyte string containing that byte. */)
185 if (XINT (byte
) < 0 || XINT (byte
) > 255)
186 error ("Invalid byte");
188 return make_string_from_bytes ((char *) &b
, 1, 1);
191 DEFUN ("string-to-char", Fstring_to_char
, Sstring_to_char
, 1, 1, 0,
192 doc
: /* Return the first character in STRING. */)
193 (register Lisp_Object string
)
195 register Lisp_Object val
;
196 CHECK_STRING (string
);
199 if (STRING_MULTIBYTE (string
))
200 XSETFASTINT (val
, STRING_CHAR (SDATA (string
)));
202 XSETFASTINT (val
, SREF (string
, 0));
205 XSETFASTINT (val
, 0);
209 DEFUN ("point", Fpoint
, Spoint
, 0, 0, 0,
210 doc
: /* Return value of point, as an integer.
211 Beginning of buffer is position (point-min). */)
215 XSETFASTINT (temp
, PT
);
219 DEFUN ("point-marker", Fpoint_marker
, Spoint_marker
, 0, 0, 0,
220 doc
: /* Return value of point, as a marker object. */)
223 return build_marker (current_buffer
, PT
, PT_BYTE
);
226 DEFUN ("goto-char", Fgoto_char
, Sgoto_char
, 1, 1, "NGoto char: ",
227 doc
: /* Set point to POSITION, a number or marker.
228 Beginning of buffer is position (point-min), end is (point-max).
230 The return value is POSITION. */)
231 (register Lisp_Object position
)
235 if (MARKERP (position
)
236 && current_buffer
== XMARKER (position
)->buffer
)
238 pos
= marker_position (position
);
240 SET_PT_BOTH (BEGV
, BEGV_BYTE
);
242 SET_PT_BOTH (ZV
, ZV_BYTE
);
244 SET_PT_BOTH (pos
, marker_byte_position (position
));
249 CHECK_NUMBER_COERCE_MARKER (position
);
251 pos
= clip_to_bounds (BEGV
, XINT (position
), ZV
);
257 /* Return the start or end position of the region.
258 BEGINNINGP non-zero means return the start.
259 If there is no region active, signal an error. */
262 region_limit (int beginningp
)
266 if (!NILP (Vtransient_mark_mode
)
267 && NILP (Vmark_even_if_inactive
)
268 && NILP (BVAR (current_buffer
, mark_active
)))
269 xsignal0 (Qmark_inactive
);
271 m
= Fmarker_position (BVAR (current_buffer
, mark
));
273 error ("The mark is not set now, so there is no region");
275 /* Clip to the current narrowing (bug#11770). */
276 return make_number ((PT
< XFASTINT (m
)) == (beginningp
!= 0)
278 : clip_to_bounds (BEGV
, XFASTINT (m
), ZV
));
281 DEFUN ("region-beginning", Fregion_beginning
, Sregion_beginning
, 0, 0, 0,
282 doc
: /* Return the integer value of point or mark, whichever is smaller. */)
285 return region_limit (1);
288 DEFUN ("region-end", Fregion_end
, Sregion_end
, 0, 0, 0,
289 doc
: /* Return the integer value of point or mark, whichever is larger. */)
292 return region_limit (0);
295 DEFUN ("mark-marker", Fmark_marker
, Smark_marker
, 0, 0, 0,
296 doc
: /* Return this buffer's mark, as a marker object.
297 Watch out! Moving this marker changes the mark position.
298 If you set the marker not to point anywhere, the buffer will have no mark. */)
301 return BVAR (current_buffer
, mark
);
305 /* Find all the overlays in the current buffer that touch position POS.
306 Return the number found, and store them in a vector in VEC
310 overlays_around (EMACS_INT pos
, Lisp_Object
*vec
, ptrdiff_t len
)
312 Lisp_Object overlay
, start
, end
;
313 struct Lisp_Overlay
*tail
;
314 ptrdiff_t startpos
, endpos
;
317 for (tail
= current_buffer
->overlays_before
; tail
; tail
= tail
->next
)
319 XSETMISC (overlay
, tail
);
321 end
= OVERLAY_END (overlay
);
322 endpos
= OVERLAY_POSITION (end
);
325 start
= OVERLAY_START (overlay
);
326 startpos
= OVERLAY_POSITION (start
);
331 /* Keep counting overlays even if we can't return them all. */
336 for (tail
= current_buffer
->overlays_after
; tail
; tail
= tail
->next
)
338 XSETMISC (overlay
, tail
);
340 start
= OVERLAY_START (overlay
);
341 startpos
= OVERLAY_POSITION (start
);
344 end
= OVERLAY_END (overlay
);
345 endpos
= OVERLAY_POSITION (end
);
357 /* Return the value of property PROP, in OBJECT at POSITION.
358 It's the value of PROP that a char inserted at POSITION would get.
359 OBJECT is optional and defaults to the current buffer.
360 If OBJECT is a buffer, then overlay properties are considered as well as
362 If OBJECT is a window, then that window's buffer is used, but
363 window-specific overlays are considered only if they are associated
366 get_pos_property (Lisp_Object position
, register Lisp_Object prop
, Lisp_Object object
)
368 CHECK_NUMBER_COERCE_MARKER (position
);
371 XSETBUFFER (object
, current_buffer
);
372 else if (WINDOWP (object
))
373 object
= XWINDOW (object
)->buffer
;
375 if (!BUFFERP (object
))
376 /* pos-property only makes sense in buffers right now, since strings
377 have no overlays and no notion of insertion for which stickiness
379 return Fget_text_property (position
, prop
, object
);
382 EMACS_INT posn
= XINT (position
);
384 Lisp_Object
*overlay_vec
, tem
;
385 struct buffer
*obuf
= current_buffer
;
387 set_buffer_temp (XBUFFER (object
));
389 /* First try with room for 40 overlays. */
391 overlay_vec
= alloca (noverlays
* sizeof *overlay_vec
);
392 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
394 /* If there are more than 40,
395 make enough space for all, and try again. */
398 overlay_vec
= alloca (noverlays
* sizeof *overlay_vec
);
399 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
401 noverlays
= sort_overlays (overlay_vec
, noverlays
, NULL
);
403 set_buffer_temp (obuf
);
405 /* Now check the overlays in order of decreasing priority. */
406 while (--noverlays
>= 0)
408 Lisp_Object ol
= overlay_vec
[noverlays
];
409 tem
= Foverlay_get (ol
, prop
);
412 /* Check the overlay is indeed active at point. */
413 Lisp_Object start
= OVERLAY_START (ol
), finish
= OVERLAY_END (ol
);
414 if ((OVERLAY_POSITION (start
) == posn
415 && XMARKER (start
)->insertion_type
== 1)
416 || (OVERLAY_POSITION (finish
) == posn
417 && XMARKER (finish
)->insertion_type
== 0))
418 ; /* The overlay will not cover a char inserted at point. */
426 { /* Now check the text properties. */
427 int stickiness
= text_property_stickiness (prop
, position
, object
);
429 return Fget_text_property (position
, prop
, object
);
430 else if (stickiness
< 0
431 && XINT (position
) > BUF_BEGV (XBUFFER (object
)))
432 return Fget_text_property (make_number (XINT (position
) - 1),
440 /* Find the field surrounding POS in *BEG and *END. If POS is nil,
441 the value of point is used instead. If BEG or END is null,
442 means don't store the beginning or end of the field.
444 BEG_LIMIT and END_LIMIT serve to limit the ranged of the returned
445 results; they do not effect boundary behavior.
447 If MERGE_AT_BOUNDARY is nonzero, then if POS is at the very first
448 position of a field, then the beginning of the previous field is
449 returned instead of the beginning of POS's field (since the end of a
450 field is actually also the beginning of the next input field, this
451 behavior is sometimes useful). Additionally in the MERGE_AT_BOUNDARY
452 true case, if two fields are separated by a field with the special
453 value `boundary', and POS lies within it, then the two separated
454 fields are considered to be adjacent, and POS between them, when
455 finding the beginning and ending of the "merged" field.
457 Either BEG or END may be 0, in which case the corresponding value
461 find_field (Lisp_Object pos
, Lisp_Object merge_at_boundary
,
462 Lisp_Object beg_limit
,
463 ptrdiff_t *beg
, Lisp_Object end_limit
, ptrdiff_t *end
)
465 /* Fields right before and after the point. */
466 Lisp_Object before_field
, after_field
;
467 /* 1 if POS counts as the start of a field. */
468 int at_field_start
= 0;
469 /* 1 if POS counts as the end of a field. */
470 int at_field_end
= 0;
473 XSETFASTINT (pos
, PT
);
475 CHECK_NUMBER_COERCE_MARKER (pos
);
478 = get_char_property_and_overlay (pos
, Qfield
, Qnil
, NULL
);
480 = (XFASTINT (pos
) > BEGV
481 ? get_char_property_and_overlay (make_number (XINT (pos
) - 1),
483 /* Using nil here would be a more obvious choice, but it would
484 fail when the buffer starts with a non-sticky field. */
487 /* See if we need to handle the case where MERGE_AT_BOUNDARY is nil
488 and POS is at beginning of a field, which can also be interpreted
489 as the end of the previous field. Note that the case where if
490 MERGE_AT_BOUNDARY is non-nil (see function comment) is actually the
491 more natural one; then we avoid treating the beginning of a field
493 if (NILP (merge_at_boundary
))
495 Lisp_Object field
= get_pos_property (pos
, Qfield
, Qnil
);
496 if (!EQ (field
, after_field
))
498 if (!EQ (field
, before_field
))
500 if (NILP (field
) && at_field_start
&& at_field_end
)
501 /* If an inserted char would have a nil field while the surrounding
502 text is non-nil, we're probably not looking at a
503 zero-length field, but instead at a non-nil field that's
504 not intended for editing (such as comint's prompts). */
505 at_field_end
= at_field_start
= 0;
508 /* Note about special `boundary' fields:
510 Consider the case where the point (`.') is between the fields `x' and `y':
514 In this situation, if merge_at_boundary is true, we consider the
515 `x' and `y' fields as forming one big merged field, and so the end
516 of the field is the end of `y'.
518 However, if `x' and `y' are separated by a special `boundary' field
519 (a field with a `field' char-property of 'boundary), then we ignore
520 this special field when merging adjacent fields. Here's the same
521 situation, but with a `boundary' field between the `x' and `y' fields:
525 Here, if point is at the end of `x', the beginning of `y', or
526 anywhere in-between (within the `boundary' field), we merge all
527 three fields and consider the beginning as being the beginning of
528 the `x' field, and the end as being the end of the `y' field. */
533 /* POS is at the edge of a field, and we should consider it as
534 the beginning of the following field. */
535 *beg
= XFASTINT (pos
);
537 /* Find the previous field boundary. */
540 if (!NILP (merge_at_boundary
) && EQ (before_field
, Qboundary
))
541 /* Skip a `boundary' field. */
542 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
545 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
547 *beg
= NILP (p
) ? BEGV
: XFASTINT (p
);
554 /* POS is at the edge of a field, and we should consider it as
555 the end of the previous field. */
556 *end
= XFASTINT (pos
);
558 /* Find the next field boundary. */
560 if (!NILP (merge_at_boundary
) && EQ (after_field
, Qboundary
))
561 /* Skip a `boundary' field. */
562 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
565 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
567 *end
= NILP (pos
) ? ZV
: XFASTINT (pos
);
573 DEFUN ("delete-field", Fdelete_field
, Sdelete_field
, 0, 1, 0,
574 doc
: /* Delete the field surrounding POS.
575 A field is a region of text with the same `field' property.
576 If POS is nil, the value of point is used for POS. */)
580 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
582 del_range (beg
, end
);
586 DEFUN ("field-string", Ffield_string
, Sfield_string
, 0, 1, 0,
587 doc
: /* Return the contents of the field surrounding POS as a string.
588 A field is a region of text with the same `field' property.
589 If POS is nil, the value of point is used for POS. */)
593 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
594 return make_buffer_string (beg
, end
, 1);
597 DEFUN ("field-string-no-properties", Ffield_string_no_properties
, Sfield_string_no_properties
, 0, 1, 0,
598 doc
: /* Return the contents of the field around POS, without text properties.
599 A field is a region of text with the same `field' property.
600 If POS is nil, the value of point is used for POS. */)
604 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
605 return make_buffer_string (beg
, end
, 0);
608 DEFUN ("field-beginning", Ffield_beginning
, Sfield_beginning
, 0, 3, 0,
609 doc
: /* Return the beginning of the field surrounding POS.
610 A field is a region of text with the same `field' property.
611 If POS is nil, the value of point is used for POS.
612 If ESCAPE-FROM-EDGE is non-nil and POS is at the beginning of its
613 field, then the beginning of the *previous* field is returned.
614 If LIMIT is non-nil, it is a buffer position; if the beginning of the field
615 is before LIMIT, then LIMIT will be returned instead. */)
616 (Lisp_Object pos
, Lisp_Object escape_from_edge
, Lisp_Object limit
)
619 find_field (pos
, escape_from_edge
, limit
, &beg
, Qnil
, 0);
620 return make_number (beg
);
623 DEFUN ("field-end", Ffield_end
, Sfield_end
, 0, 3, 0,
624 doc
: /* Return the end of the field surrounding POS.
625 A field is a region of text with the same `field' property.
626 If POS is nil, the value of point is used for POS.
627 If ESCAPE-FROM-EDGE is non-nil and POS is at the end of its field,
628 then the end of the *following* field is returned.
629 If LIMIT is non-nil, it is a buffer position; if the end of the field
630 is after LIMIT, then LIMIT will be returned instead. */)
631 (Lisp_Object pos
, Lisp_Object escape_from_edge
, Lisp_Object limit
)
634 find_field (pos
, escape_from_edge
, Qnil
, 0, limit
, &end
);
635 return make_number (end
);
638 DEFUN ("constrain-to-field", Fconstrain_to_field
, Sconstrain_to_field
, 2, 5, 0,
639 doc
: /* Return the position closest to NEW-POS that is in the same field as OLD-POS.
640 A field is a region of text with the same `field' property.
642 If NEW-POS is nil, then use the current point instead, and move point
643 to the resulting constrained position, in addition to returning that
646 If OLD-POS is at the boundary of two fields, then the allowable
647 positions for NEW-POS depends on the value of the optional argument
648 ESCAPE-FROM-EDGE: If ESCAPE-FROM-EDGE is nil, then NEW-POS is
649 constrained to the field that has the same `field' char-property
650 as any new characters inserted at OLD-POS, whereas if ESCAPE-FROM-EDGE
651 is non-nil, NEW-POS is constrained to the union of the two adjacent
652 fields. Additionally, if two fields are separated by another field with
653 the special value `boundary', then any point within this special field is
654 also considered to be `on the boundary'.
656 If the optional argument ONLY-IN-LINE is non-nil and constraining
657 NEW-POS would move it to a different line, NEW-POS is returned
658 unconstrained. This useful for commands that move by line, like
659 \\[next-line] or \\[beginning-of-line], which should generally respect field boundaries
660 only in the case where they can still move to the right line.
662 If the optional argument INHIBIT-CAPTURE-PROPERTY is non-nil, and OLD-POS has
663 a non-nil property of that name, then any field boundaries are ignored.
665 Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */)
666 (Lisp_Object new_pos
, Lisp_Object old_pos
, Lisp_Object escape_from_edge
, Lisp_Object only_in_line
, Lisp_Object inhibit_capture_property
)
668 /* If non-zero, then the original point, before re-positioning. */
669 ptrdiff_t orig_point
= 0;
671 Lisp_Object prev_old
, prev_new
;
674 /* Use the current point, and afterwards, set it. */
677 XSETFASTINT (new_pos
, PT
);
680 CHECK_NUMBER_COERCE_MARKER (new_pos
);
681 CHECK_NUMBER_COERCE_MARKER (old_pos
);
683 fwd
= (XINT (new_pos
) > XINT (old_pos
));
685 prev_old
= make_number (XINT (old_pos
) - 1);
686 prev_new
= make_number (XINT (new_pos
) - 1);
688 if (NILP (Vinhibit_field_text_motion
)
689 && !EQ (new_pos
, old_pos
)
690 && (!NILP (Fget_char_property (new_pos
, Qfield
, Qnil
))
691 || !NILP (Fget_char_property (old_pos
, Qfield
, Qnil
))
692 /* To recognize field boundaries, we must also look at the
693 previous positions; we could use `get_pos_property'
694 instead, but in itself that would fail inside non-sticky
695 fields (like comint prompts). */
696 || (XFASTINT (new_pos
) > BEGV
697 && !NILP (Fget_char_property (prev_new
, Qfield
, Qnil
)))
698 || (XFASTINT (old_pos
) > BEGV
699 && !NILP (Fget_char_property (prev_old
, Qfield
, Qnil
))))
700 && (NILP (inhibit_capture_property
)
701 /* Field boundaries are again a problem; but now we must
702 decide the case exactly, so we need to call
703 `get_pos_property' as well. */
704 || (NILP (get_pos_property (old_pos
, inhibit_capture_property
, Qnil
))
705 && (XFASTINT (old_pos
) <= BEGV
706 || NILP (Fget_char_property (old_pos
, inhibit_capture_property
, Qnil
))
707 || NILP (Fget_char_property (prev_old
, inhibit_capture_property
, Qnil
))))))
708 /* It is possible that NEW_POS is not within the same field as
709 OLD_POS; try to move NEW_POS so that it is. */
712 Lisp_Object field_bound
;
715 field_bound
= Ffield_end (old_pos
, escape_from_edge
, new_pos
);
717 field_bound
= Ffield_beginning (old_pos
, escape_from_edge
, new_pos
);
719 if (/* See if ESCAPE_FROM_EDGE caused FIELD_BOUND to jump to the
720 other side of NEW_POS, which would mean that NEW_POS is
721 already acceptable, and it's not necessary to constrain it
723 ((XFASTINT (field_bound
) < XFASTINT (new_pos
)) ? fwd
: !fwd
)
724 /* NEW_POS should be constrained, but only if either
725 ONLY_IN_LINE is nil (in which case any constraint is OK),
726 or NEW_POS and FIELD_BOUND are on the same line (in which
727 case the constraint is OK even if ONLY_IN_LINE is non-nil). */
728 && (NILP (only_in_line
)
729 /* This is the ONLY_IN_LINE case, check that NEW_POS and
730 FIELD_BOUND are on the same line by seeing whether
731 there's an intervening newline or not. */
732 || (scan_buffer ('\n',
733 XFASTINT (new_pos
), XFASTINT (field_bound
),
734 fwd
? -1 : 1, &shortage
, 1),
736 /* Constrain NEW_POS to FIELD_BOUND. */
737 new_pos
= field_bound
;
739 if (orig_point
&& XFASTINT (new_pos
) != orig_point
)
740 /* The NEW_POS argument was originally nil, so automatically set PT. */
741 SET_PT (XFASTINT (new_pos
));
748 DEFUN ("line-beginning-position",
749 Fline_beginning_position
, Sline_beginning_position
, 0, 1, 0,
750 doc
: /* Return the character position of the first character on the current line.
751 With argument N not nil or 1, move forward N - 1 lines first.
752 If scan reaches end of buffer, return that position.
754 The returned position is of the first character in the logical order,
755 i.e. the one that has the smallest character position.
757 This function constrains the returned position to the current field
758 unless that would be on a different line than the original,
759 unconstrained result. If N is nil or 1, and a front-sticky field
760 starts at point, the scan stops as soon as it starts. To ignore field
761 boundaries bind `inhibit-field-text-motion' to t.
763 This function does not move point. */)
766 ptrdiff_t orig
, orig_byte
, end
;
767 ptrdiff_t count
= SPECPDL_INDEX ();
768 specbind (Qinhibit_point_motion_hooks
, Qt
);
777 Fforward_line (make_number (XINT (n
) - 1));
780 SET_PT_BOTH (orig
, orig_byte
);
782 unbind_to (count
, Qnil
);
784 /* Return END constrained to the current input field. */
785 return Fconstrain_to_field (make_number (end
), make_number (orig
),
786 XINT (n
) != 1 ? Qt
: Qnil
,
790 DEFUN ("line-end-position", Fline_end_position
, Sline_end_position
, 0, 1, 0,
791 doc
: /* Return the character position of the last character on the current line.
792 With argument N not nil or 1, move forward N - 1 lines first.
793 If scan reaches end of buffer, return that position.
795 The returned position is of the last character in the logical order,
796 i.e. the character whose buffer position is the largest one.
798 This function constrains the returned position to the current field
799 unless that would be on a different line than the original,
800 unconstrained result. If N is nil or 1, and a rear-sticky field ends
801 at point, the scan stops as soon as it starts. To ignore field
802 boundaries bind `inhibit-field-text-motion' to t.
804 This function does not move point. */)
816 clipped_n
= clip_to_bounds (PTRDIFF_MIN
+ 1, XINT (n
), PTRDIFF_MAX
);
817 end_pos
= find_before_next_newline (orig
, 0, clipped_n
- (clipped_n
<= 0));
819 /* Return END_POS constrained to the current input field. */
820 return Fconstrain_to_field (make_number (end_pos
), make_number (orig
),
826 save_excursion_save (void)
828 int visible
= (XBUFFER (XWINDOW (selected_window
)->buffer
)
831 return Fcons (Fpoint_marker (),
832 Fcons (Fcopy_marker (BVAR (current_buffer
, mark
), Qnil
),
833 Fcons (visible
? Qt
: Qnil
,
834 Fcons (BVAR (current_buffer
, mark_active
),
839 save_excursion_restore (Lisp_Object info
)
841 Lisp_Object tem
, tem1
, omark
, nmark
;
842 struct gcpro gcpro1
, gcpro2
, gcpro3
;
845 tem
= Fmarker_buffer (XCAR (info
));
846 /* If buffer being returned to is now deleted, avoid error */
847 /* Otherwise could get error here while unwinding to top level
849 /* In that case, Fmarker_buffer returns nil now. */
853 omark
= nmark
= Qnil
;
854 GCPRO3 (info
, omark
, nmark
);
861 unchain_marker (XMARKER (tem
));
866 omark
= Fmarker_position (BVAR (current_buffer
, mark
));
867 Fset_marker (BVAR (current_buffer
, mark
), tem
, Fcurrent_buffer ());
868 nmark
= Fmarker_position (tem
);
869 unchain_marker (XMARKER (tem
));
873 visible_p
= !NILP (XCAR (info
));
875 #if 0 /* We used to make the current buffer visible in the selected window
876 if that was true previously. That avoids some anomalies.
877 But it creates others, and it wasn't documented, and it is simpler
878 and cleaner never to alter the window/buffer connections. */
881 && current_buffer
!= XBUFFER (XWINDOW (selected_window
)->buffer
))
882 Fswitch_to_buffer (Fcurrent_buffer (), Qnil
);
888 tem1
= BVAR (current_buffer
, mark_active
);
889 BVAR (current_buffer
, mark_active
) = tem
;
891 /* If mark is active now, and either was not active
892 or was at a different place, run the activate hook. */
895 if (! EQ (omark
, nmark
))
897 tem
= intern ("activate-mark-hook");
898 Frun_hooks (1, &tem
);
901 /* If mark has ceased to be active, run deactivate hook. */
902 else if (! NILP (tem1
))
904 tem
= intern ("deactivate-mark-hook");
905 Frun_hooks (1, &tem
);
908 /* If buffer was visible in a window, and a different window was
909 selected, and the old selected window is still showing this
910 buffer, restore point in that window. */
913 && !EQ (tem
, selected_window
)
914 && (tem1
= XWINDOW (tem
)->buffer
,
915 (/* Window is live... */
917 /* ...and it shows the current buffer. */
918 && XBUFFER (tem1
) == current_buffer
)))
919 Fset_window_point (tem
, make_number (PT
));
925 DEFUN ("save-excursion", Fsave_excursion
, Ssave_excursion
, 0, UNEVALLED
, 0,
926 doc
: /* Save point, mark, and current buffer; execute BODY; restore those things.
927 Executes BODY just like `progn'.
928 The values of point, mark and the current buffer are restored
929 even in case of abnormal exit (throw or error).
930 The state of activation of the mark is also restored.
932 This construct does not save `deactivate-mark', and therefore
933 functions that change the buffer will still cause deactivation
934 of the mark at the end of the command. To prevent that, bind
935 `deactivate-mark' with `let'.
937 If you only want to save the current buffer but not point nor mark,
938 then just use `save-current-buffer', or even `with-current-buffer'.
940 usage: (save-excursion &rest BODY) */)
943 register Lisp_Object val
;
944 ptrdiff_t count
= SPECPDL_INDEX ();
946 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
949 return unbind_to (count
, val
);
952 DEFUN ("save-current-buffer", Fsave_current_buffer
, Ssave_current_buffer
, 0, UNEVALLED
, 0,
953 doc
: /* Save the current buffer; execute BODY; restore the current buffer.
954 Executes BODY just like `progn'.
955 usage: (save-current-buffer &rest BODY) */)
959 ptrdiff_t count
= SPECPDL_INDEX ();
961 record_unwind_protect (set_buffer_if_live
, Fcurrent_buffer ());
964 return unbind_to (count
, val
);
967 DEFUN ("buffer-size", Fbufsize
, Sbufsize
, 0, 1, 0,
968 doc
: /* Return the number of characters in the current buffer.
969 If BUFFER, return the number of characters in that buffer instead. */)
973 return make_number (Z
- BEG
);
976 CHECK_BUFFER (buffer
);
977 return make_number (BUF_Z (XBUFFER (buffer
))
978 - BUF_BEG (XBUFFER (buffer
)));
982 DEFUN ("point-min", Fpoint_min
, Spoint_min
, 0, 0, 0,
983 doc
: /* Return the minimum permissible value of point in the current buffer.
984 This is 1, unless narrowing (a buffer restriction) is in effect. */)
988 XSETFASTINT (temp
, BEGV
);
992 DEFUN ("point-min-marker", Fpoint_min_marker
, Spoint_min_marker
, 0, 0, 0,
993 doc
: /* Return a marker to the minimum permissible value of point in this buffer.
994 This is the beginning, unless narrowing (a buffer restriction) is in effect. */)
997 return build_marker (current_buffer
, BEGV
, BEGV_BYTE
);
1000 DEFUN ("point-max", Fpoint_max
, Spoint_max
, 0, 0, 0,
1001 doc
: /* Return the maximum permissible value of point in the current buffer.
1002 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1003 is in effect, in which case it is less. */)
1007 XSETFASTINT (temp
, ZV
);
1011 DEFUN ("point-max-marker", Fpoint_max_marker
, Spoint_max_marker
, 0, 0, 0,
1012 doc
: /* Return a marker to the maximum permissible value of point in this buffer.
1013 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1014 is in effect, in which case it is less. */)
1017 return build_marker (current_buffer
, ZV
, ZV_BYTE
);
1020 DEFUN ("gap-position", Fgap_position
, Sgap_position
, 0, 0, 0,
1021 doc
: /* Return the position of the gap, in the current buffer.
1022 See also `gap-size'. */)
1026 XSETFASTINT (temp
, GPT
);
1030 DEFUN ("gap-size", Fgap_size
, Sgap_size
, 0, 0, 0,
1031 doc
: /* Return the size of the current buffer's gap.
1032 See also `gap-position'. */)
1036 XSETFASTINT (temp
, GAP_SIZE
);
1040 DEFUN ("position-bytes", Fposition_bytes
, Sposition_bytes
, 1, 1, 0,
1041 doc
: /* Return the byte position for character position POSITION.
1042 If POSITION is out of range, the value is nil. */)
1043 (Lisp_Object position
)
1045 CHECK_NUMBER_COERCE_MARKER (position
);
1046 if (XINT (position
) < BEG
|| XINT (position
) > Z
)
1048 return make_number (CHAR_TO_BYTE (XINT (position
)));
1051 DEFUN ("byte-to-position", Fbyte_to_position
, Sbyte_to_position
, 1, 1, 0,
1052 doc
: /* Return the character position for byte position BYTEPOS.
1053 If BYTEPOS is out of range, the value is nil. */)
1054 (Lisp_Object bytepos
)
1056 CHECK_NUMBER (bytepos
);
1057 if (XINT (bytepos
) < BEG_BYTE
|| XINT (bytepos
) > Z_BYTE
)
1059 return make_number (BYTE_TO_CHAR (XINT (bytepos
)));
1062 DEFUN ("following-char", Ffollowing_char
, Sfollowing_char
, 0, 0, 0,
1063 doc
: /* Return the character following point, as a number.
1064 At the end of the buffer or accessible region, return 0. */)
1069 XSETFASTINT (temp
, 0);
1071 XSETFASTINT (temp
, FETCH_CHAR (PT_BYTE
));
1075 DEFUN ("preceding-char", Fprevious_char
, Sprevious_char
, 0, 0, 0,
1076 doc
: /* Return the character preceding point, as a number.
1077 At the beginning of the buffer or accessible region, return 0. */)
1082 XSETFASTINT (temp
, 0);
1083 else if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
1085 ptrdiff_t pos
= PT_BYTE
;
1087 XSETFASTINT (temp
, FETCH_CHAR (pos
));
1090 XSETFASTINT (temp
, FETCH_BYTE (PT_BYTE
- 1));
1094 DEFUN ("bobp", Fbobp
, Sbobp
, 0, 0, 0,
1095 doc
: /* Return t if point is at the beginning of the buffer.
1096 If the buffer is narrowed, this means the beginning of the narrowed part. */)
1104 DEFUN ("eobp", Feobp
, Seobp
, 0, 0, 0,
1105 doc
: /* Return t if point is at the end of the buffer.
1106 If the buffer is narrowed, this means the end of the narrowed part. */)
1114 DEFUN ("bolp", Fbolp
, Sbolp
, 0, 0, 0,
1115 doc
: /* Return t if point is at the beginning of a line. */)
1118 if (PT
== BEGV
|| FETCH_BYTE (PT_BYTE
- 1) == '\n')
1123 DEFUN ("eolp", Feolp
, Seolp
, 0, 0, 0,
1124 doc
: /* Return t if point is at the end of a line.
1125 `End of a line' includes point being at the end of the buffer. */)
1128 if (PT
== ZV
|| FETCH_BYTE (PT_BYTE
) == '\n')
1133 DEFUN ("char-after", Fchar_after
, Schar_after
, 0, 1, 0,
1134 doc
: /* Return character in current buffer at position POS.
1135 POS is an integer or a marker and defaults to point.
1136 If POS is out of range, the value is nil. */)
1139 register ptrdiff_t pos_byte
;
1144 XSETFASTINT (pos
, PT
);
1149 pos_byte
= marker_byte_position (pos
);
1150 if (pos_byte
< BEGV_BYTE
|| pos_byte
>= ZV_BYTE
)
1155 CHECK_NUMBER_COERCE_MARKER (pos
);
1156 if (XINT (pos
) < BEGV
|| XINT (pos
) >= ZV
)
1159 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1162 return make_number (FETCH_CHAR (pos_byte
));
1165 DEFUN ("char-before", Fchar_before
, Schar_before
, 0, 1, 0,
1166 doc
: /* Return character in current buffer preceding position POS.
1167 POS is an integer or a marker and defaults to point.
1168 If POS is out of range, the value is nil. */)
1171 register Lisp_Object val
;
1172 register ptrdiff_t pos_byte
;
1177 XSETFASTINT (pos
, PT
);
1182 pos_byte
= marker_byte_position (pos
);
1184 if (pos_byte
<= BEGV_BYTE
|| pos_byte
> ZV_BYTE
)
1189 CHECK_NUMBER_COERCE_MARKER (pos
);
1191 if (XINT (pos
) <= BEGV
|| XINT (pos
) > ZV
)
1194 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1197 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
1200 XSETFASTINT (val
, FETCH_CHAR (pos_byte
));
1205 XSETFASTINT (val
, FETCH_BYTE (pos_byte
));
1210 DEFUN ("user-login-name", Fuser_login_name
, Suser_login_name
, 0, 1, 0,
1211 doc
: /* Return the name under which the user logged in, as a string.
1212 This is based on the effective uid, not the real uid.
1213 Also, if the environment variables LOGNAME or USER are set,
1214 that determines the value of this function.
1216 If optional argument UID is an integer or a float, return the login name
1217 of the user with that uid, or nil if there is no such user. */)
1223 /* Set up the user name info if we didn't do it before.
1224 (That can happen if Emacs is dumpable
1225 but you decide to run `temacs -l loadup' and not dump. */
1226 if (INTEGERP (Vuser_login_name
))
1230 return Vuser_login_name
;
1232 CONS_TO_INTEGER (uid
, uid_t
, id
);
1236 return (pw
? build_string (pw
->pw_name
) : Qnil
);
1239 DEFUN ("user-real-login-name", Fuser_real_login_name
, Suser_real_login_name
,
1241 doc
: /* Return the name of the user's real uid, as a string.
1242 This ignores the environment variables LOGNAME and USER, so it differs from
1243 `user-login-name' when running under `su'. */)
1246 /* Set up the user name info if we didn't do it before.
1247 (That can happen if Emacs is dumpable
1248 but you decide to run `temacs -l loadup' and not dump. */
1249 if (INTEGERP (Vuser_login_name
))
1251 return Vuser_real_login_name
;
1254 DEFUN ("user-uid", Fuser_uid
, Suser_uid
, 0, 0, 0,
1255 doc
: /* Return the effective uid of Emacs.
1256 Value is an integer or a float, depending on the value. */)
1259 uid_t euid
= geteuid ();
1260 return make_fixnum_or_float (euid
);
1263 DEFUN ("user-real-uid", Fuser_real_uid
, Suser_real_uid
, 0, 0, 0,
1264 doc
: /* Return the real uid of Emacs.
1265 Value is an integer or a float, depending on the value. */)
1268 uid_t uid
= getuid ();
1269 return make_fixnum_or_float (uid
);
1272 DEFUN ("user-full-name", Fuser_full_name
, Suser_full_name
, 0, 1, 0,
1273 doc
: /* Return the full name of the user logged in, as a string.
1274 If the full name corresponding to Emacs's userid is not known,
1277 If optional argument UID is an integer or float, return the full name
1278 of the user with that uid, or nil if there is no such user.
1279 If UID is a string, return the full name of the user with that login
1280 name, or nil if there is no such user. */)
1284 register char *p
, *q
;
1288 return Vuser_full_name
;
1289 else if (NUMBERP (uid
))
1292 CONS_TO_INTEGER (uid
, uid_t
, u
);
1297 else if (STRINGP (uid
))
1300 pw
= getpwnam (SSDATA (uid
));
1304 error ("Invalid UID specification");
1310 /* Chop off everything after the first comma. */
1311 q
= strchr (p
, ',');
1312 full
= make_string (p
, q
? q
- p
: strlen (p
));
1314 #ifdef AMPERSAND_FULL_NAME
1316 q
= strchr (p
, '&');
1317 /* Substitute the login name for the &, upcasing the first character. */
1323 login
= Fuser_login_name (make_number (pw
->pw_uid
));
1324 r
= alloca (strlen (p
) + SCHARS (login
) + 1);
1325 memcpy (r
, p
, q
- p
);
1327 strcat (r
, SSDATA (login
));
1328 r
[q
- p
] = upcase ((unsigned char) r
[q
- p
]);
1330 full
= build_string (r
);
1332 #endif /* AMPERSAND_FULL_NAME */
1337 DEFUN ("system-name", Fsystem_name
, Ssystem_name
, 0, 0, 0,
1338 doc
: /* Return the host name of the machine you are running on, as a string. */)
1341 return Vsystem_name
;
1345 get_system_name (void)
1347 if (STRINGP (Vsystem_name
))
1348 return SSDATA (Vsystem_name
);
1353 DEFUN ("emacs-pid", Femacs_pid
, Semacs_pid
, 0, 0, 0,
1354 doc
: /* Return the process ID of Emacs, as a number. */)
1357 pid_t pid
= getpid ();
1358 return make_fixnum_or_float (pid
);
1364 # define TIME_T_MIN TYPE_MINIMUM (time_t)
1367 # define TIME_T_MAX TYPE_MAXIMUM (time_t)
1370 /* Report that a time value is out of range for Emacs. */
1372 time_overflow (void)
1374 error ("Specified time is not representable");
1377 /* Return the upper part of the time T (everything but the bottom 16 bits). */
1381 time_t hi
= t
>> 16;
1383 /* Check for overflow, helping the compiler for common cases where
1384 no runtime check is needed, and taking care not to convert
1385 negative numbers to unsigned before comparing them. */
1386 if (! ((! TYPE_SIGNED (time_t)
1387 || MOST_NEGATIVE_FIXNUM
<= TIME_T_MIN
>> 16
1388 || MOST_NEGATIVE_FIXNUM
<= hi
)
1389 && (TIME_T_MAX
>> 16 <= MOST_POSITIVE_FIXNUM
1390 || hi
<= MOST_POSITIVE_FIXNUM
)))
1396 /* Return the bottom 16 bits of the time T. */
1400 return t
& ((1 << 16) - 1);
1403 DEFUN ("current-time", Fcurrent_time
, Scurrent_time
, 0, 0, 0,
1404 doc
: /* Return the current time, as the number of seconds since 1970-01-01 00:00:00.
1405 The time is returned as a list of integers (HIGH LOW USEC PSEC).
1406 HIGH has the most significant bits of the seconds, while LOW has the
1407 least significant 16 bits. USEC and PSEC are the microsecond and
1408 picosecond counts. */)
1414 return make_lisp_time (t
);
1417 DEFUN ("get-internal-run-time", Fget_internal_run_time
, Sget_internal_run_time
,
1419 doc
: /* Return the current run time used by Emacs.
1420 The time is returned as a list (HIGH LOW USEC PSEC), using the same
1421 style as (current-time).
1423 On systems that can't determine the run time, `get-internal-run-time'
1424 does the same thing as `current-time'. */)
1427 #ifdef HAVE_GETRUSAGE
1428 struct rusage usage
;
1433 if (getrusage (RUSAGE_SELF
, &usage
) < 0)
1434 /* This shouldn't happen. What action is appropriate? */
1437 /* Sum up user time and system time. */
1438 secs
= usage
.ru_utime
.tv_sec
+ usage
.ru_stime
.tv_sec
;
1439 usecs
= usage
.ru_utime
.tv_usec
+ usage
.ru_stime
.tv_usec
;
1440 if (usecs
>= 1000000)
1445 EMACS_SET_SECS_USECS (t
, secs
, usecs
);
1446 return make_lisp_time (t
);
1447 #else /* ! HAVE_GETRUSAGE */
1449 return w32_get_internal_run_time ();
1450 #else /* ! WINDOWSNT */
1451 return Fcurrent_time ();
1452 #endif /* WINDOWSNT */
1453 #endif /* HAVE_GETRUSAGE */
1457 /* Make a Lisp list that represents the time T with fraction TAIL. */
1459 make_time_tail (time_t t
, Lisp_Object tail
)
1461 return Fcons (make_number (hi_time (t
)),
1462 Fcons (make_number (lo_time (t
)), tail
));
1465 /* Make a Lisp list that represents the system time T. */
1467 make_time (time_t t
)
1469 return make_time_tail (t
, Qnil
);
1472 /* Make a Lisp list that represents the Emacs time T. T may be an
1473 invalid time, with a slightly negative tv_nsec value such as
1474 UNKNOWN_MODTIME_NSECS; in that case, the Lisp list contains a
1475 correspondingly negative picosecond count. */
1477 make_lisp_time (EMACS_TIME t
)
1479 int ns
= EMACS_NSECS (t
);
1480 return make_time_tail (EMACS_SECS (t
),
1481 list2 (make_number (ns
/ 1000),
1482 make_number (ns
% 1000 * 1000)));
1485 /* Decode a Lisp list SPECIFIED_TIME that represents a time.
1486 Set *PHIGH, *PLOW, *PUSEC, *PPSEC to its parts; do not check their values.
1487 Return nonzero if successful. */
1489 disassemble_lisp_time (Lisp_Object specified_time
, Lisp_Object
*phigh
,
1490 Lisp_Object
*plow
, Lisp_Object
*pusec
,
1493 if (CONSP (specified_time
))
1495 Lisp_Object low
= XCDR (specified_time
);
1496 Lisp_Object usec
= make_number (0);
1497 Lisp_Object psec
= make_number (0);
1500 Lisp_Object low_tail
= XCDR (low
);
1502 if (CONSP (low_tail
))
1504 usec
= XCAR (low_tail
);
1505 low_tail
= XCDR (low_tail
);
1506 if (CONSP (low_tail
))
1507 psec
= XCAR (low_tail
);
1509 else if (!NILP (low_tail
))
1513 *phigh
= XCAR (specified_time
);
1523 /* From the time components HIGH, LOW, USEC and PSEC taken from a Lisp
1524 list, generate the corresponding time value.
1526 If RESULT is not null, store into *RESULT the converted time;
1527 this can fail if the converted time does not fit into EMACS_TIME.
1528 If *DRESULT is not null, store into *DRESULT the number of
1529 seconds since the start of the POSIX Epoch.
1531 Return nonzero if successful. */
1533 decode_time_components (Lisp_Object high
, Lisp_Object low
, Lisp_Object usec
,
1535 EMACS_TIME
*result
, double *dresult
)
1537 EMACS_INT hi
, lo
, us
, ps
;
1538 if (! (INTEGERP (high
) && INTEGERP (low
)
1539 && INTEGERP (usec
) && INTEGERP (psec
)))
1546 /* Normalize out-of-range lower-order components by carrying
1547 each overflow into the next higher-order component. */
1548 us
+= ps
/ 1000000 - (ps
% 1000000 < 0);
1549 lo
+= us
/ 1000000 - (us
% 1000000 < 0);
1551 ps
= ps
% 1000000 + 1000000 * (ps
% 1000000 < 0);
1552 us
= us
% 1000000 + 1000000 * (us
% 1000000 < 0);
1553 lo
&= (1 << 16) - 1;
1557 if ((TYPE_SIGNED (time_t) ? TIME_T_MIN
>> 16 <= hi
: 0 <= hi
)
1558 && hi
<= TIME_T_MAX
>> 16)
1560 /* Return the greatest representable time that is not greater
1561 than the requested time. */
1563 EMACS_SET_SECS_NSECS (*result
, (sec
<< 16) + lo
,
1564 us
* 1000 + ps
/ 1000);
1568 /* Overflow in the highest-order component. */
1574 *dresult
= (us
* 1e6
+ ps
) / 1e12
+ lo
+ hi
* 65536.0;
1579 /* Decode a Lisp list SPECIFIED_TIME that represents a time.
1580 If SPECIFIED_TIME is nil, use the current time.
1582 Round the time down to the nearest EMACS_TIME value.
1583 Return seconds since the Epoch.
1584 Signal an error if unsuccessful. */
1586 lisp_time_argument (Lisp_Object specified_time
)
1589 if (NILP (specified_time
))
1593 Lisp_Object high
, low
, usec
, psec
;
1594 if (! (disassemble_lisp_time (specified_time
, &high
, &low
, &usec
, &psec
)
1595 && decode_time_components (high
, low
, usec
, psec
, &t
, 0)))
1596 error ("Invalid time specification");
1601 /* Like lisp_time_argument, except decode only the seconds part,
1602 do not allow out-of-range time stamps, do not check the subseconds part,
1603 and always round down. */
1605 lisp_seconds_argument (Lisp_Object specified_time
)
1607 if (NILP (specified_time
))
1611 Lisp_Object high
, low
, usec
, psec
;
1613 if (! (disassemble_lisp_time (specified_time
, &high
, &low
, &usec
, &psec
)
1614 && decode_time_components (high
, low
, make_number (0),
1615 make_number (0), &t
, 0)))
1616 error ("Invalid time specification");
1617 return EMACS_SECS (t
);
1621 DEFUN ("float-time", Ffloat_time
, Sfloat_time
, 0, 1, 0,
1622 doc
: /* Return the current time, as a float number of seconds since the epoch.
1623 If SPECIFIED-TIME is given, it is the time to convert to float
1624 instead of the current time. The argument should have the form
1625 (HIGH LOW) or (HIGH LOW USEC) or (HIGH LOW USEC PSEC). Thus,
1626 you can use times from `current-time' and from `file-attributes'.
1627 SPECIFIED-TIME can also have the form (HIGH . LOW), but this is
1628 considered obsolete.
1630 WARNING: Since the result is floating point, it may not be exact.
1631 If precise time stamps are required, use either `current-time',
1632 or (if you need time as a string) `format-time-string'. */)
1633 (Lisp_Object specified_time
)
1636 if (NILP (specified_time
))
1639 EMACS_GET_TIME (now
);
1640 t
= EMACS_SECS (now
) + EMACS_NSECS (now
) / 1e9
;
1644 Lisp_Object high
, low
, usec
, psec
;
1645 if (! (disassemble_lisp_time (specified_time
, &high
, &low
, &usec
, &psec
)
1646 && decode_time_components (high
, low
, usec
, psec
, 0, &t
)))
1647 error ("Invalid time specification");
1649 return make_float (t
);
1652 /* Write information into buffer S of size MAXSIZE, according to the
1653 FORMAT of length FORMAT_LEN, using time information taken from *TP.
1654 Default to Universal Time if UT is nonzero, local time otherwise.
1655 Use NS as the number of nanoseconds in the %N directive.
1656 Return the number of bytes written, not including the terminating
1657 '\0'. If S is NULL, nothing will be written anywhere; so to
1658 determine how many bytes would be written, use NULL for S and
1659 ((size_t) -1) for MAXSIZE.
1661 This function behaves like nstrftime, except it allows null
1662 bytes in FORMAT and it does not support nanoseconds. */
1664 emacs_nmemftime (char *s
, size_t maxsize
, const char *format
,
1665 size_t format_len
, const struct tm
*tp
, int ut
, int ns
)
1669 /* Loop through all the null-terminated strings in the format
1670 argument. Normally there's just one null-terminated string, but
1671 there can be arbitrarily many, concatenated together, if the
1672 format contains '\0' bytes. nstrftime stops at the first
1673 '\0' byte so we must invoke it separately for each such string. */
1682 result
= nstrftime (s
, maxsize
, format
, tp
, ut
, ns
);
1686 if (result
== 0 && s
[0] != '\0')
1691 maxsize
-= result
+ 1;
1693 len
= strlen (format
);
1694 if (len
== format_len
)
1698 format_len
-= len
+ 1;
1702 DEFUN ("format-time-string", Fformat_time_string
, Sformat_time_string
, 1, 3, 0,
1703 doc
: /* Use FORMAT-STRING to format the time TIME, or now if omitted.
1704 TIME is specified as (HIGH LOW USEC PSEC), as returned by
1705 `current-time' or `file-attributes'. The obsolete form (HIGH . LOW)
1706 is also still accepted.
1707 The third, optional, argument UNIVERSAL, if non-nil, means describe TIME
1708 as Universal Time; nil means describe TIME in the local time zone.
1709 The value is a copy of FORMAT-STRING, but with certain constructs replaced
1710 by text that describes the specified date and time in TIME:
1712 %Y is the year, %y within the century, %C the century.
1713 %G is the year corresponding to the ISO week, %g within the century.
1714 %m is the numeric month.
1715 %b and %h are the locale's abbreviated month name, %B the full name.
1716 %d is the day of the month, zero-padded, %e is blank-padded.
1717 %u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.
1718 %a is the locale's abbreviated name of the day of week, %A the full name.
1719 %U is the week number starting on Sunday, %W starting on Monday,
1720 %V according to ISO 8601.
1721 %j is the day of the year.
1723 %H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H
1724 only blank-padded, %l is like %I blank-padded.
1725 %p is the locale's equivalent of either AM or PM.
1728 %N is the nanosecond, %6N the microsecond, %3N the millisecond, etc.
1729 %Z is the time zone name, %z is the numeric form.
1730 %s is the number of seconds since 1970-01-01 00:00:00 +0000.
1732 %c is the locale's date and time format.
1733 %x is the locale's "preferred" date format.
1734 %D is like "%m/%d/%y".
1736 %R is like "%H:%M", %T is like "%H:%M:%S", %r is like "%I:%M:%S %p".
1737 %X is the locale's "preferred" time format.
1739 Finally, %n is a newline, %t is a tab, %% is a literal %.
1741 Certain flags and modifiers are available with some format controls.
1742 The flags are `_', `-', `^' and `#'. For certain characters X,
1743 %_X is like %X, but padded with blanks; %-X is like %X,
1744 but without padding. %^X is like %X, but with all textual
1745 characters up-cased; %#X is like %X, but with letter-case of
1746 all textual characters reversed.
1747 %NX (where N stands for an integer) is like %X,
1748 but takes up at least N (a number) positions.
1749 The modifiers are `E' and `O'. For certain characters X,
1750 %EX is a locale's alternative version of %X;
1751 %OX is like %X, but uses the locale's number symbols.
1753 For example, to produce full ISO 8601 format, use "%Y-%m-%dT%T%z".
1755 usage: (format-time-string FORMAT-STRING &optional TIME UNIVERSAL) */)
1756 (Lisp_Object format_string
, Lisp_Object timeval
, Lisp_Object universal
)
1758 EMACS_TIME t
= lisp_time_argument (timeval
);
1761 CHECK_STRING (format_string
);
1762 format_string
= code_convert_string_norecord (format_string
,
1763 Vlocale_coding_system
, 1);
1764 return format_time_string (SSDATA (format_string
), SBYTES (format_string
),
1765 t
, ! NILP (universal
), &tm
);
1769 format_time_string (char const *format
, ptrdiff_t formatlen
,
1770 EMACS_TIME t
, int ut
, struct tm
*tmp
)
1774 ptrdiff_t size
= sizeof buffer
;
1776 Lisp_Object bufstring
;
1777 int ns
= EMACS_NSECS (t
);
1785 synchronize_system_time_locale ();
1787 tm
= ut
? gmtime (EMACS_SECS_ADDR (t
)) : localtime (EMACS_SECS_ADDR (t
));
1796 len
= emacs_nmemftime (buf
, size
, format
, formatlen
, tm
, ut
, ns
);
1797 if ((0 < len
&& len
< size
) || (len
== 0 && buf
[0] == '\0'))
1800 /* Buffer was too small, so make it bigger and try again. */
1801 len
= emacs_nmemftime (NULL
, SIZE_MAX
, format
, formatlen
, tm
, ut
, ns
);
1803 if (STRING_BYTES_BOUND
<= len
)
1806 SAFE_ALLOCA (buf
, char *, size
);
1810 bufstring
= make_unibyte_string (buf
, len
);
1812 return code_convert_string_norecord (bufstring
, Vlocale_coding_system
, 0);
1815 DEFUN ("decode-time", Fdecode_time
, Sdecode_time
, 0, 1, 0,
1816 doc
: /* Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST ZONE).
1817 The optional SPECIFIED-TIME should be a list of (HIGH LOW . IGNORED),
1818 as from `current-time' and `file-attributes', or nil to use the
1819 current time. The obsolete form (HIGH . LOW) is also still accepted.
1820 The list has the following nine members: SEC is an integer between 0
1821 and 60; SEC is 60 for a leap second, which only some operating systems
1822 support. MINUTE is an integer between 0 and 59. HOUR is an integer
1823 between 0 and 23. DAY is an integer between 1 and 31. MONTH is an
1824 integer between 1 and 12. YEAR is an integer indicating the
1825 four-digit year. DOW is the day of week, an integer between 0 and 6,
1826 where 0 is Sunday. DST is t if daylight saving time is in effect,
1827 otherwise nil. ZONE is an integer indicating the number of seconds
1828 east of Greenwich. (Note that Common Lisp has different meanings for
1830 (Lisp_Object specified_time
)
1832 time_t time_spec
= lisp_seconds_argument (specified_time
);
1834 struct tm
*decoded_time
;
1835 Lisp_Object list_args
[9];
1838 decoded_time
= localtime (&time_spec
);
1840 save_tm
= *decoded_time
;
1843 && MOST_NEGATIVE_FIXNUM
- TM_YEAR_BASE
<= save_tm
.tm_year
1844 && save_tm
.tm_year
<= MOST_POSITIVE_FIXNUM
- TM_YEAR_BASE
))
1846 XSETFASTINT (list_args
[0], save_tm
.tm_sec
);
1847 XSETFASTINT (list_args
[1], save_tm
.tm_min
);
1848 XSETFASTINT (list_args
[2], save_tm
.tm_hour
);
1849 XSETFASTINT (list_args
[3], save_tm
.tm_mday
);
1850 XSETFASTINT (list_args
[4], save_tm
.tm_mon
+ 1);
1851 /* On 64-bit machines an int is narrower than EMACS_INT, thus the
1852 cast below avoids overflow in int arithmetics. */
1853 XSETINT (list_args
[5], TM_YEAR_BASE
+ (EMACS_INT
) save_tm
.tm_year
);
1854 XSETFASTINT (list_args
[6], save_tm
.tm_wday
);
1855 list_args
[7] = save_tm
.tm_isdst
? Qt
: Qnil
;
1858 decoded_time
= gmtime (&time_spec
);
1859 if (decoded_time
== 0)
1860 list_args
[8] = Qnil
;
1862 XSETINT (list_args
[8], tm_diff (&save_tm
, decoded_time
));
1864 return Flist (9, list_args
);
1867 /* Return OBJ - OFFSET, checking that OBJ is a valid fixnum and that
1868 the result is representable as an int. Assume OFFSET is small and
1871 check_tm_member (Lisp_Object obj
, int offset
)
1876 if (! (INT_MIN
+ offset
<= n
&& n
- offset
<= INT_MAX
))
1881 DEFUN ("encode-time", Fencode_time
, Sencode_time
, 6, MANY
, 0,
1882 doc
: /* Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.
1883 This is the reverse operation of `decode-time', which see.
1884 ZONE defaults to the current time zone rule. This can
1885 be a string or t (as from `set-time-zone-rule'), or it can be a list
1886 \(as from `current-time-zone') or an integer (as from `decode-time')
1887 applied without consideration for daylight saving time.
1889 You can pass more than 7 arguments; then the first six arguments
1890 are used as SECOND through YEAR, and the *last* argument is used as ZONE.
1891 The intervening arguments are ignored.
1892 This feature lets (apply 'encode-time (decode-time ...)) work.
1894 Out-of-range values for SECOND, MINUTE, HOUR, DAY, or MONTH are allowed;
1895 for example, a DAY of 0 means the day preceding the given month.
1896 Year numbers less than 100 are treated just like other year numbers.
1897 If you want them to stand for years in this century, you must do that yourself.
1899 Years before 1970 are not guaranteed to work. On some systems,
1900 year values as low as 1901 do work.
1902 usage: (encode-time SECOND MINUTE HOUR DAY MONTH YEAR &optional ZONE) */)
1903 (ptrdiff_t nargs
, Lisp_Object
*args
)
1907 Lisp_Object zone
= (nargs
> 6 ? args
[nargs
- 1] : Qnil
);
1909 tm
.tm_sec
= check_tm_member (args
[0], 0);
1910 tm
.tm_min
= check_tm_member (args
[1], 0);
1911 tm
.tm_hour
= check_tm_member (args
[2], 0);
1912 tm
.tm_mday
= check_tm_member (args
[3], 0);
1913 tm
.tm_mon
= check_tm_member (args
[4], 1);
1914 tm
.tm_year
= check_tm_member (args
[5], TM_YEAR_BASE
);
1922 value
= mktime (&tm
);
1928 const char *tzstring
;
1929 char **oldenv
= environ
, **newenv
;
1933 else if (STRINGP (zone
))
1934 tzstring
= SSDATA (zone
);
1935 else if (INTEGERP (zone
))
1937 EMACS_INT abszone
= eabs (XINT (zone
));
1938 EMACS_INT zone_hr
= abszone
/ (60*60);
1939 int zone_min
= (abszone
/60) % 60;
1940 int zone_sec
= abszone
% 60;
1941 sprintf (tzbuf
, "XXX%s%"pI
"d:%02d:%02d", "-" + (XINT (zone
) < 0),
1942 zone_hr
, zone_min
, zone_sec
);
1946 error ("Invalid time zone specification");
1950 /* Set TZ before calling mktime; merely adjusting mktime's returned
1951 value doesn't suffice, since that would mishandle leap seconds. */
1952 set_time_zone_rule (tzstring
);
1954 value
= mktime (&tm
);
1956 /* Restore TZ to previous value. */
1959 #ifdef LOCALTIME_CACHE
1967 if (value
== (time_t) -1)
1970 return make_time (value
);
1973 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
, 0, 1, 0,
1974 doc
: /* Return the current local time, as a human-readable string.
1975 Programs can use this function to decode a time,
1976 since the number of columns in each field is fixed
1977 if the year is in the range 1000-9999.
1978 The format is `Sun Sep 16 01:03:52 1973'.
1979 However, see also the functions `decode-time' and `format-time-string'
1980 which provide a much more powerful and general facility.
1982 If SPECIFIED-TIME is given, it is a time to format instead of the
1983 current time. The argument should have the form (HIGH LOW . IGNORED).
1984 Thus, you can use times obtained from `current-time' and from
1985 `file-attributes'. SPECIFIED-TIME can also have the form (HIGH . LOW),
1986 but this is considered obsolete. */)
1987 (Lisp_Object specified_time
)
1989 time_t value
= lisp_seconds_argument (specified_time
);
1991 char buf
[sizeof "Mon Apr 30 12:49:17 " + INT_STRLEN_BOUND (int) + 1];
1992 int len
IF_LINT (= 0);
1994 /* Convert to a string in ctime format, except without the trailing
1995 newline, and without the 4-digit year limit. Don't use asctime
1996 or ctime, as they might dump core if the year is outside the
1997 range -999 .. 9999. */
1999 tm
= localtime (&value
);
2002 static char const wday_name
[][4] =
2003 { "Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat" };
2004 static char const mon_name
[][4] =
2005 { "Jan", "Feb", "Mar", "Apr", "May", "Jun",
2006 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" };
2007 printmax_t year_base
= TM_YEAR_BASE
;
2009 len
= sprintf (buf
, "%s %s%3d %02d:%02d:%02d %"pMd
,
2010 wday_name
[tm
->tm_wday
], mon_name
[tm
->tm_mon
], tm
->tm_mday
,
2011 tm
->tm_hour
, tm
->tm_min
, tm
->tm_sec
,
2012 tm
->tm_year
+ year_base
);
2018 return make_unibyte_string (buf
, len
);
2021 /* Yield A - B, measured in seconds.
2022 This function is copied from the GNU C Library. */
2024 tm_diff (struct tm
*a
, struct tm
*b
)
2026 /* Compute intervening leap days correctly even if year is negative.
2027 Take care to avoid int overflow in leap day calculations,
2028 but it's OK to assume that A and B are close to each other. */
2029 int a4
= (a
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (a
->tm_year
& 3);
2030 int b4
= (b
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (b
->tm_year
& 3);
2031 int a100
= a4
/ 25 - (a4
% 25 < 0);
2032 int b100
= b4
/ 25 - (b4
% 25 < 0);
2033 int a400
= a100
>> 2;
2034 int b400
= b100
>> 2;
2035 int intervening_leap_days
= (a4
- b4
) - (a100
- b100
) + (a400
- b400
);
2036 int years
= a
->tm_year
- b
->tm_year
;
2037 int days
= (365 * years
+ intervening_leap_days
2038 + (a
->tm_yday
- b
->tm_yday
));
2039 return (60 * (60 * (24 * days
+ (a
->tm_hour
- b
->tm_hour
))
2040 + (a
->tm_min
- b
->tm_min
))
2041 + (a
->tm_sec
- b
->tm_sec
));
2044 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 1, 0,
2045 doc
: /* Return the offset and name for the local time zone.
2046 This returns a list of the form (OFFSET NAME).
2047 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).
2048 A negative value means west of Greenwich.
2049 NAME is a string giving the name of the time zone.
2050 If SPECIFIED-TIME is given, the time zone offset is determined from it
2051 instead of using the current time. The argument should have the form
2052 (HIGH LOW . IGNORED). Thus, you can use times obtained from
2053 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
2054 have the form (HIGH . LOW), but this is considered obsolete.
2056 Some operating systems cannot provide all this information to Emacs;
2057 in this case, `current-time-zone' returns a list containing nil for
2058 the data it can't find. */)
2059 (Lisp_Object specified_time
)
2065 Lisp_Object zone_offset
, zone_name
;
2068 EMACS_SET_SECS_NSECS (value
, lisp_seconds_argument (specified_time
), 0);
2069 zone_name
= format_time_string ("%Z", sizeof "%Z" - 1, value
, 0, &localtm
);
2071 t
= gmtime (EMACS_SECS_ADDR (value
));
2073 offset
= tm_diff (&localtm
, t
);
2078 zone_offset
= make_number (offset
);
2079 if (SCHARS (zone_name
) == 0)
2081 /* No local time zone name is available; use "+-NNNN" instead. */
2082 int m
= offset
/ 60;
2083 int am
= offset
< 0 ? - m
: m
;
2084 char buf
[sizeof "+00" + INT_STRLEN_BOUND (int)];
2085 zone_name
= make_formatted_string (buf
, "%c%02d%02d",
2086 (offset
< 0 ? '-' : '+'),
2091 return list2 (zone_offset
, zone_name
);
2094 /* This holds the value of `environ' produced by the previous
2095 call to Fset_time_zone_rule, or 0 if Fset_time_zone_rule
2096 has never been called. */
2097 static char **environbuf
;
2099 /* This holds the startup value of the TZ environment variable so it
2100 can be restored if the user calls set-time-zone-rule with a nil
2102 static char *initial_tz
;
2104 DEFUN ("set-time-zone-rule", Fset_time_zone_rule
, Sset_time_zone_rule
, 1, 1, 0,
2105 doc
: /* Set the local time zone using TZ, a string specifying a time zone rule.
2106 If TZ is nil, use implementation-defined default time zone information.
2107 If TZ is t, use Universal Time.
2109 Instead of calling this function, you typically want (setenv "TZ" TZ).
2110 That changes both the environment of the Emacs process and the
2111 variable `process-environment', whereas `set-time-zone-rule' affects
2112 only the former. */)
2115 const char *tzstring
;
2116 char **old_environbuf
;
2118 if (! (NILP (tz
) || EQ (tz
, Qt
)))
2123 /* When called for the first time, save the original TZ. */
2124 old_environbuf
= environbuf
;
2125 if (!old_environbuf
)
2126 initial_tz
= (char *) getenv ("TZ");
2129 tzstring
= initial_tz
;
2130 else if (EQ (tz
, Qt
))
2133 tzstring
= SSDATA (tz
);
2135 set_time_zone_rule (tzstring
);
2136 environbuf
= environ
;
2140 xfree (old_environbuf
);
2144 #ifdef LOCALTIME_CACHE
2146 /* These two values are known to load tz files in buggy implementations,
2147 i.e. Solaris 1 executables running under either Solaris 1 or Solaris 2.
2148 Their values shouldn't matter in non-buggy implementations.
2149 We don't use string literals for these strings,
2150 since if a string in the environment is in readonly
2151 storage, it runs afoul of bugs in SVR4 and Solaris 2.3.
2152 See Sun bugs 1113095 and 1114114, ``Timezone routines
2153 improperly modify environment''. */
2155 static char set_time_zone_rule_tz1
[] = "TZ=GMT+0";
2156 static char set_time_zone_rule_tz2
[] = "TZ=GMT+1";
2160 /* Set the local time zone rule to TZSTRING.
2161 This allocates memory into `environ', which it is the caller's
2162 responsibility to free. */
2165 set_time_zone_rule (const char *tzstring
)
2168 char **from
, **to
, **newenv
;
2170 /* Make the ENVIRON vector longer with room for TZSTRING. */
2171 for (from
= environ
; *from
; from
++)
2173 envptrs
= from
- environ
+ 2;
2174 newenv
= to
= xmalloc (envptrs
* sizeof *newenv
2175 + (tzstring
? strlen (tzstring
) + 4 : 0));
2177 /* Add TZSTRING to the end of environ, as a value for TZ. */
2180 char *t
= (char *) (to
+ envptrs
);
2182 strcat (t
, tzstring
);
2186 /* Copy the old environ vector elements into NEWENV,
2187 but don't copy the TZ variable.
2188 So we have only one definition of TZ, which came from TZSTRING. */
2189 for (from
= environ
; *from
; from
++)
2190 if (strncmp (*from
, "TZ=", 3) != 0)
2196 /* If we do have a TZSTRING, NEWENV points to the vector slot where
2197 the TZ variable is stored. If we do not have a TZSTRING,
2198 TO points to the vector slot which has the terminating null. */
2200 #ifdef LOCALTIME_CACHE
2202 /* In SunOS 4.1.3_U1 and 4.1.4, if TZ has a value like
2203 "US/Pacific" that loads a tz file, then changes to a value like
2204 "XXX0" that does not load a tz file, and then changes back to
2205 its original value, the last change is (incorrectly) ignored.
2206 Also, if TZ changes twice in succession to values that do
2207 not load a tz file, tzset can dump core (see Sun bug#1225179).
2208 The following code works around these bugs. */
2212 /* Temporarily set TZ to a value that loads a tz file
2213 and that differs from tzstring. */
2215 *newenv
= (strcmp (tzstring
, set_time_zone_rule_tz1
+ 3) == 0
2216 ? set_time_zone_rule_tz2
: set_time_zone_rule_tz1
);
2222 /* The implied tzstring is unknown, so temporarily set TZ to
2223 two different values that each load a tz file. */
2224 *to
= set_time_zone_rule_tz1
;
2227 *to
= set_time_zone_rule_tz2
;
2232 /* Now TZ has the desired value, and tzset can be invoked safely. */
2239 /* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC
2240 (if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a
2241 type of object is Lisp_String). INHERIT is passed to
2242 INSERT_FROM_STRING_FUNC as the last argument. */
2245 general_insert_function (void (*insert_func
)
2246 (const char *, ptrdiff_t),
2247 void (*insert_from_string_func
)
2248 (Lisp_Object
, ptrdiff_t, ptrdiff_t,
2249 ptrdiff_t, ptrdiff_t, int),
2250 int inherit
, ptrdiff_t nargs
, Lisp_Object
*args
)
2253 register Lisp_Object val
;
2255 for (argnum
= 0; argnum
< nargs
; argnum
++)
2258 if (CHARACTERP (val
))
2260 int c
= XFASTINT (val
);
2261 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2264 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2265 len
= CHAR_STRING (c
, str
);
2268 str
[0] = ASCII_CHAR_P (c
) ? c
: multibyte_char_to_unibyte (c
);
2271 (*insert_func
) ((char *) str
, len
);
2273 else if (STRINGP (val
))
2275 (*insert_from_string_func
) (val
, 0, 0,
2281 wrong_type_argument (Qchar_or_string_p
, val
);
2286 insert1 (Lisp_Object arg
)
2292 /* Callers passing one argument to Finsert need not gcpro the
2293 argument "array", since the only element of the array will
2294 not be used after calling insert or insert_from_string, so
2295 we don't care if it gets trashed. */
2297 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
2298 doc
: /* Insert the arguments, either strings or characters, at point.
2299 Point and before-insertion markers move forward to end up
2300 after the inserted text.
2301 Any other markers at the point of insertion remain before the text.
2303 If the current buffer is multibyte, unibyte strings are converted
2304 to multibyte for insertion (see `string-make-multibyte').
2305 If the current buffer is unibyte, multibyte strings are converted
2306 to unibyte for insertion (see `string-make-unibyte').
2308 When operating on binary data, it may be necessary to preserve the
2309 original bytes of a unibyte string when inserting it into a multibyte
2310 buffer; to accomplish this, apply `string-as-multibyte' to the string
2311 and insert the result.
2313 usage: (insert &rest ARGS) */)
2314 (ptrdiff_t nargs
, Lisp_Object
*args
)
2316 general_insert_function (insert
, insert_from_string
, 0, nargs
, args
);
2320 DEFUN ("insert-and-inherit", Finsert_and_inherit
, Sinsert_and_inherit
,
2322 doc
: /* Insert the arguments at point, inheriting properties from adjoining text.
2323 Point and before-insertion markers move forward to end up
2324 after the inserted text.
2325 Any other markers at the point of insertion remain before the text.
2327 If the current buffer is multibyte, unibyte strings are converted
2328 to multibyte for insertion (see `unibyte-char-to-multibyte').
2329 If the current buffer is unibyte, multibyte strings are converted
2330 to unibyte for insertion.
2332 usage: (insert-and-inherit &rest ARGS) */)
2333 (ptrdiff_t nargs
, Lisp_Object
*args
)
2335 general_insert_function (insert_and_inherit
, insert_from_string
, 1,
2340 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
2341 doc
: /* Insert strings or characters at point, relocating markers after the text.
2342 Point and markers move forward to end up after the inserted text.
2344 If the current buffer is multibyte, unibyte strings are converted
2345 to multibyte for insertion (see `unibyte-char-to-multibyte').
2346 If the current buffer is unibyte, multibyte strings are converted
2347 to unibyte for insertion.
2349 usage: (insert-before-markers &rest ARGS) */)
2350 (ptrdiff_t nargs
, Lisp_Object
*args
)
2352 general_insert_function (insert_before_markers
,
2353 insert_from_string_before_markers
, 0,
2358 DEFUN ("insert-before-markers-and-inherit", Finsert_and_inherit_before_markers
,
2359 Sinsert_and_inherit_before_markers
, 0, MANY
, 0,
2360 doc
: /* Insert text at point, relocating markers and inheriting properties.
2361 Point and markers move forward to end up after the inserted text.
2363 If the current buffer is multibyte, unibyte strings are converted
2364 to multibyte for insertion (see `unibyte-char-to-multibyte').
2365 If the current buffer is unibyte, multibyte strings are converted
2366 to unibyte for insertion.
2368 usage: (insert-before-markers-and-inherit &rest ARGS) */)
2369 (ptrdiff_t nargs
, Lisp_Object
*args
)
2371 general_insert_function (insert_before_markers_and_inherit
,
2372 insert_from_string_before_markers
, 1,
2377 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 2, 3, 0,
2378 doc
: /* Insert COUNT copies of CHARACTER.
2379 Point, and before-insertion markers, are relocated as in the function `insert'.
2380 The optional third arg INHERIT, if non-nil, says to inherit text properties
2381 from adjoining text, if those properties are sticky. */)
2382 (Lisp_Object character
, Lisp_Object count
, Lisp_Object inherit
)
2385 register ptrdiff_t n
;
2387 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2390 CHECK_CHARACTER (character
);
2391 CHECK_NUMBER (count
);
2392 c
= XFASTINT (character
);
2394 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2395 len
= CHAR_STRING (c
, str
);
2397 str
[0] = c
, len
= 1;
2398 if (XINT (count
) <= 0)
2400 if (BUF_BYTES_MAX
/ len
< XINT (count
))
2402 n
= XINT (count
) * len
;
2403 stringlen
= min (n
, sizeof string
- sizeof string
% len
);
2404 for (i
= 0; i
< stringlen
; i
++)
2405 string
[i
] = str
[i
% len
];
2406 while (n
> stringlen
)
2409 if (!NILP (inherit
))
2410 insert_and_inherit (string
, stringlen
);
2412 insert (string
, stringlen
);
2415 if (!NILP (inherit
))
2416 insert_and_inherit (string
, n
);
2422 DEFUN ("insert-byte", Finsert_byte
, Sinsert_byte
, 2, 3, 0,
2423 doc
: /* Insert COUNT (second arg) copies of BYTE (first arg).
2424 Both arguments are required.
2425 BYTE is a number of the range 0..255.
2427 If BYTE is 128..255 and the current buffer is multibyte, the
2428 corresponding eight-bit character is inserted.
2430 Point, and before-insertion markers, are relocated as in the function `insert'.
2431 The optional third arg INHERIT, if non-nil, says to inherit text properties
2432 from adjoining text, if those properties are sticky. */)
2433 (Lisp_Object byte
, Lisp_Object count
, Lisp_Object inherit
)
2435 CHECK_NUMBER (byte
);
2436 if (XINT (byte
) < 0 || XINT (byte
) > 255)
2437 args_out_of_range_3 (byte
, make_number (0), make_number (255));
2438 if (XINT (byte
) >= 128
2439 && ! NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2440 XSETFASTINT (byte
, BYTE8_TO_CHAR (XINT (byte
)));
2441 return Finsert_char (byte
, count
, inherit
);
2445 /* Making strings from buffer contents. */
2447 /* Return a Lisp_String containing the text of the current buffer from
2448 START to END. If text properties are in use and the current buffer
2449 has properties in the range specified, the resulting string will also
2450 have them, if PROPS is nonzero.
2452 We don't want to use plain old make_string here, because it calls
2453 make_uninit_string, which can cause the buffer arena to be
2454 compacted. make_string has no way of knowing that the data has
2455 been moved, and thus copies the wrong data into the string. This
2456 doesn't effect most of the other users of make_string, so it should
2457 be left as is. But we should use this function when conjuring
2458 buffer substrings. */
2461 make_buffer_string (ptrdiff_t start
, ptrdiff_t end
, int props
)
2463 ptrdiff_t start_byte
= CHAR_TO_BYTE (start
);
2464 ptrdiff_t end_byte
= CHAR_TO_BYTE (end
);
2466 return make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
);
2469 /* Return a Lisp_String containing the text of the current buffer from
2470 START / START_BYTE to END / END_BYTE.
2472 If text properties are in use and the current buffer
2473 has properties in the range specified, the resulting string will also
2474 have them, if PROPS is nonzero.
2476 We don't want to use plain old make_string here, because it calls
2477 make_uninit_string, which can cause the buffer arena to be
2478 compacted. make_string has no way of knowing that the data has
2479 been moved, and thus copies the wrong data into the string. This
2480 doesn't effect most of the other users of make_string, so it should
2481 be left as is. But we should use this function when conjuring
2482 buffer substrings. */
2485 make_buffer_string_both (ptrdiff_t start
, ptrdiff_t start_byte
,
2486 ptrdiff_t end
, ptrdiff_t end_byte
, int props
)
2488 Lisp_Object result
, tem
, tem1
;
2490 if (start
< GPT
&& GPT
< end
)
2493 if (! NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2494 result
= make_uninit_multibyte_string (end
- start
, end_byte
- start_byte
);
2496 result
= make_uninit_string (end
- start
);
2497 memcpy (SDATA (result
), BYTE_POS_ADDR (start_byte
), end_byte
- start_byte
);
2499 /* If desired, update and copy the text properties. */
2502 update_buffer_properties (start
, end
);
2504 tem
= Fnext_property_change (make_number (start
), Qnil
, make_number (end
));
2505 tem1
= Ftext_properties_at (make_number (start
), Qnil
);
2507 if (XINT (tem
) != end
|| !NILP (tem1
))
2508 copy_intervals_to_string (result
, current_buffer
, start
,
2515 /* Call Vbuffer_access_fontify_functions for the range START ... END
2516 in the current buffer, if necessary. */
2519 update_buffer_properties (ptrdiff_t start
, ptrdiff_t end
)
2521 /* If this buffer has some access functions,
2522 call them, specifying the range of the buffer being accessed. */
2523 if (!NILP (Vbuffer_access_fontify_functions
))
2525 Lisp_Object args
[3];
2528 args
[0] = Qbuffer_access_fontify_functions
;
2529 XSETINT (args
[1], start
);
2530 XSETINT (args
[2], end
);
2532 /* But don't call them if we can tell that the work
2533 has already been done. */
2534 if (!NILP (Vbuffer_access_fontified_property
))
2536 tem
= Ftext_property_any (args
[1], args
[2],
2537 Vbuffer_access_fontified_property
,
2540 Frun_hook_with_args (3, args
);
2543 Frun_hook_with_args (3, args
);
2547 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
2548 doc
: /* Return the contents of part of the current buffer as a string.
2549 The two arguments START and END are character positions;
2550 they can be in either order.
2551 The string returned is multibyte if the buffer is multibyte.
2553 This function copies the text properties of that part of the buffer
2554 into the result string; if you don't want the text properties,
2555 use `buffer-substring-no-properties' instead. */)
2556 (Lisp_Object start
, Lisp_Object end
)
2558 register ptrdiff_t b
, e
;
2560 validate_region (&start
, &end
);
2564 return make_buffer_string (b
, e
, 1);
2567 DEFUN ("buffer-substring-no-properties", Fbuffer_substring_no_properties
,
2568 Sbuffer_substring_no_properties
, 2, 2, 0,
2569 doc
: /* Return the characters of part of the buffer, without the text properties.
2570 The two arguments START and END are character positions;
2571 they can be in either order. */)
2572 (Lisp_Object start
, Lisp_Object end
)
2574 register ptrdiff_t b
, e
;
2576 validate_region (&start
, &end
);
2580 return make_buffer_string (b
, e
, 0);
2583 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
2584 doc
: /* Return the contents of the current buffer as a string.
2585 If narrowing is in effect, this function returns only the visible part
2589 return make_buffer_string (BEGV
, ZV
, 1);
2592 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
2594 doc
: /* Insert before point a substring of the contents of BUFFER.
2595 BUFFER may be a buffer or a buffer name.
2596 Arguments START and END are character positions specifying the substring.
2597 They default to the values of (point-min) and (point-max) in BUFFER. */)
2598 (Lisp_Object buffer
, Lisp_Object start
, Lisp_Object end
)
2600 register EMACS_INT b
, e
, temp
;
2601 register struct buffer
*bp
, *obuf
;
2604 buf
= Fget_buffer (buffer
);
2608 if (NILP (BVAR (bp
, name
)))
2609 error ("Selecting deleted buffer");
2615 CHECK_NUMBER_COERCE_MARKER (start
);
2622 CHECK_NUMBER_COERCE_MARKER (end
);
2627 temp
= b
, b
= e
, e
= temp
;
2629 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
2630 args_out_of_range (start
, end
);
2632 obuf
= current_buffer
;
2633 set_buffer_internal_1 (bp
);
2634 update_buffer_properties (b
, e
);
2635 set_buffer_internal_1 (obuf
);
2637 insert_from_buffer (bp
, b
, e
- b
, 0);
2641 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
2643 doc
: /* Compare two substrings of two buffers; return result as number.
2644 the value is -N if first string is less after N-1 chars,
2645 +N if first string is greater after N-1 chars, or 0 if strings match.
2646 Each substring is represented as three arguments: BUFFER, START and END.
2647 That makes six args in all, three for each substring.
2649 The value of `case-fold-search' in the current buffer
2650 determines whether case is significant or ignored. */)
2651 (Lisp_Object buffer1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object buffer2
, Lisp_Object start2
, Lisp_Object end2
)
2653 register EMACS_INT begp1
, endp1
, begp2
, endp2
, temp
;
2654 register struct buffer
*bp1
, *bp2
;
2655 register Lisp_Object trt
2656 = (!NILP (BVAR (current_buffer
, case_fold_search
))
2657 ? BVAR (current_buffer
, case_canon_table
) : Qnil
);
2658 ptrdiff_t chars
= 0;
2659 ptrdiff_t i1
, i2
, i1_byte
, i2_byte
;
2661 /* Find the first buffer and its substring. */
2664 bp1
= current_buffer
;
2668 buf1
= Fget_buffer (buffer1
);
2671 bp1
= XBUFFER (buf1
);
2672 if (NILP (BVAR (bp1
, name
)))
2673 error ("Selecting deleted buffer");
2677 begp1
= BUF_BEGV (bp1
);
2680 CHECK_NUMBER_COERCE_MARKER (start1
);
2681 begp1
= XINT (start1
);
2684 endp1
= BUF_ZV (bp1
);
2687 CHECK_NUMBER_COERCE_MARKER (end1
);
2688 endp1
= XINT (end1
);
2692 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
2694 if (!(BUF_BEGV (bp1
) <= begp1
2696 && endp1
<= BUF_ZV (bp1
)))
2697 args_out_of_range (start1
, end1
);
2699 /* Likewise for second substring. */
2702 bp2
= current_buffer
;
2706 buf2
= Fget_buffer (buffer2
);
2709 bp2
= XBUFFER (buf2
);
2710 if (NILP (BVAR (bp2
, name
)))
2711 error ("Selecting deleted buffer");
2715 begp2
= BUF_BEGV (bp2
);
2718 CHECK_NUMBER_COERCE_MARKER (start2
);
2719 begp2
= XINT (start2
);
2722 endp2
= BUF_ZV (bp2
);
2725 CHECK_NUMBER_COERCE_MARKER (end2
);
2726 endp2
= XINT (end2
);
2730 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
2732 if (!(BUF_BEGV (bp2
) <= begp2
2734 && endp2
<= BUF_ZV (bp2
)))
2735 args_out_of_range (start2
, end2
);
2739 i1_byte
= buf_charpos_to_bytepos (bp1
, i1
);
2740 i2_byte
= buf_charpos_to_bytepos (bp2
, i2
);
2742 while (i1
< endp1
&& i2
< endp2
)
2744 /* When we find a mismatch, we must compare the
2745 characters, not just the bytes. */
2750 if (! NILP (BVAR (bp1
, enable_multibyte_characters
)))
2752 c1
= BUF_FETCH_MULTIBYTE_CHAR (bp1
, i1_byte
);
2753 BUF_INC_POS (bp1
, i1_byte
);
2758 c1
= BUF_FETCH_BYTE (bp1
, i1
);
2759 MAKE_CHAR_MULTIBYTE (c1
);
2763 if (! NILP (BVAR (bp2
, enable_multibyte_characters
)))
2765 c2
= BUF_FETCH_MULTIBYTE_CHAR (bp2
, i2_byte
);
2766 BUF_INC_POS (bp2
, i2_byte
);
2771 c2
= BUF_FETCH_BYTE (bp2
, i2
);
2772 MAKE_CHAR_MULTIBYTE (c2
);
2778 c1
= CHAR_TABLE_TRANSLATE (trt
, c1
);
2779 c2
= CHAR_TABLE_TRANSLATE (trt
, c2
);
2782 return make_number (- 1 - chars
);
2784 return make_number (chars
+ 1);
2789 /* The strings match as far as they go.
2790 If one is shorter, that one is less. */
2791 if (chars
< endp1
- begp1
)
2792 return make_number (chars
+ 1);
2793 else if (chars
< endp2
- begp2
)
2794 return make_number (- chars
- 1);
2796 /* Same length too => they are equal. */
2797 return make_number (0);
2801 subst_char_in_region_unwind (Lisp_Object arg
)
2803 return BVAR (current_buffer
, undo_list
) = arg
;
2807 subst_char_in_region_unwind_1 (Lisp_Object arg
)
2809 return BVAR (current_buffer
, filename
) = arg
;
2812 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
2813 Ssubst_char_in_region
, 4, 5, 0,
2814 doc
: /* From START to END, replace FROMCHAR with TOCHAR each time it occurs.
2815 If optional arg NOUNDO is non-nil, don't record this change for undo
2816 and don't mark the buffer as really changed.
2817 Both characters must have the same length of multi-byte form. */)
2818 (Lisp_Object start
, Lisp_Object end
, Lisp_Object fromchar
, Lisp_Object tochar
, Lisp_Object noundo
)
2820 register ptrdiff_t pos
, pos_byte
, stop
, i
, len
, end_byte
;
2821 /* Keep track of the first change in the buffer:
2822 if 0 we haven't found it yet.
2823 if < 0 we've found it and we've run the before-change-function.
2824 if > 0 we've actually performed it and the value is its position. */
2825 ptrdiff_t changed
= 0;
2826 unsigned char fromstr
[MAX_MULTIBYTE_LENGTH
], tostr
[MAX_MULTIBYTE_LENGTH
];
2828 ptrdiff_t count
= SPECPDL_INDEX ();
2829 #define COMBINING_NO 0
2830 #define COMBINING_BEFORE 1
2831 #define COMBINING_AFTER 2
2832 #define COMBINING_BOTH (COMBINING_BEFORE | COMBINING_AFTER)
2833 int maybe_byte_combining
= COMBINING_NO
;
2834 ptrdiff_t last_changed
= 0;
2835 int multibyte_p
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
2840 validate_region (&start
, &end
);
2841 CHECK_CHARACTER (fromchar
);
2842 CHECK_CHARACTER (tochar
);
2843 fromc
= XFASTINT (fromchar
);
2844 toc
= XFASTINT (tochar
);
2848 len
= CHAR_STRING (fromc
, fromstr
);
2849 if (CHAR_STRING (toc
, tostr
) != len
)
2850 error ("Characters in `subst-char-in-region' have different byte-lengths");
2851 if (!ASCII_BYTE_P (*tostr
))
2853 /* If *TOSTR is in the range 0x80..0x9F and TOCHAR is not a
2854 complete multibyte character, it may be combined with the
2855 after bytes. If it is in the range 0xA0..0xFF, it may be
2856 combined with the before and after bytes. */
2857 if (!CHAR_HEAD_P (*tostr
))
2858 maybe_byte_combining
= COMBINING_BOTH
;
2859 else if (BYTES_BY_CHAR_HEAD (*tostr
) > len
)
2860 maybe_byte_combining
= COMBINING_AFTER
;
2871 pos_byte
= CHAR_TO_BYTE (pos
);
2872 stop
= CHAR_TO_BYTE (XINT (end
));
2875 /* If we don't want undo, turn off putting stuff on the list.
2876 That's faster than getting rid of things,
2877 and it prevents even the entry for a first change.
2878 Also inhibit locking the file. */
2879 if (!changed
&& !NILP (noundo
))
2881 record_unwind_protect (subst_char_in_region_unwind
,
2882 BVAR (current_buffer
, undo_list
));
2883 BVAR (current_buffer
, undo_list
) = Qt
;
2884 /* Don't do file-locking. */
2885 record_unwind_protect (subst_char_in_region_unwind_1
,
2886 BVAR (current_buffer
, filename
));
2887 BVAR (current_buffer
, filename
) = Qnil
;
2890 if (pos_byte
< GPT_BYTE
)
2891 stop
= min (stop
, GPT_BYTE
);
2894 ptrdiff_t pos_byte_next
= pos_byte
;
2896 if (pos_byte
>= stop
)
2898 if (pos_byte
>= end_byte
) break;
2901 p
= BYTE_POS_ADDR (pos_byte
);
2903 INC_POS (pos_byte_next
);
2906 if (pos_byte_next
- pos_byte
== len
2907 && p
[0] == fromstr
[0]
2909 || (p
[1] == fromstr
[1]
2910 && (len
== 2 || (p
[2] == fromstr
[2]
2911 && (len
== 3 || p
[3] == fromstr
[3]))))))
2914 /* We've already seen this and run the before-change-function;
2915 this time we only need to record the actual position. */
2920 modify_region (current_buffer
, pos
, XINT (end
), 0);
2922 if (! NILP (noundo
))
2924 if (MODIFF
- 1 == SAVE_MODIFF
)
2926 if (MODIFF
- 1 == BUF_AUTOSAVE_MODIFF (current_buffer
))
2927 BUF_AUTOSAVE_MODIFF (current_buffer
)++;
2930 /* The before-change-function may have moved the gap
2931 or even modified the buffer so we should start over. */
2935 /* Take care of the case where the new character
2936 combines with neighboring bytes. */
2937 if (maybe_byte_combining
2938 && (maybe_byte_combining
== COMBINING_AFTER
2939 ? (pos_byte_next
< Z_BYTE
2940 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2941 : ((pos_byte_next
< Z_BYTE
2942 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2943 || (pos_byte
> BEG_BYTE
2944 && ! ASCII_BYTE_P (FETCH_BYTE (pos_byte
- 1))))))
2946 Lisp_Object tem
, string
;
2948 struct gcpro gcpro1
;
2950 tem
= BVAR (current_buffer
, undo_list
);
2953 /* Make a multibyte string containing this single character. */
2954 string
= make_multibyte_string ((char *) tostr
, 1, len
);
2955 /* replace_range is less efficient, because it moves the gap,
2956 but it handles combining correctly. */
2957 replace_range (pos
, pos
+ 1, string
,
2959 pos_byte_next
= CHAR_TO_BYTE (pos
);
2960 if (pos_byte_next
> pos_byte
)
2961 /* Before combining happened. We should not increment
2962 POS. So, to cancel the later increment of POS,
2966 INC_POS (pos_byte_next
);
2968 if (! NILP (noundo
))
2969 BVAR (current_buffer
, undo_list
) = tem
;
2976 record_change (pos
, 1);
2977 for (i
= 0; i
< len
; i
++) *p
++ = tostr
[i
];
2979 last_changed
= pos
+ 1;
2981 pos_byte
= pos_byte_next
;
2987 signal_after_change (changed
,
2988 last_changed
- changed
, last_changed
- changed
);
2989 update_compositions (changed
, last_changed
, CHECK_ALL
);
2992 unbind_to (count
, Qnil
);
2997 static Lisp_Object
check_translation (ptrdiff_t, ptrdiff_t, ptrdiff_t,
3000 /* Helper function for Ftranslate_region_internal.
3002 Check if a character sequence at POS (POS_BYTE) matches an element
3003 of VAL. VAL is a list (([FROM-CHAR ...] . TO) ...). If a matching
3004 element is found, return it. Otherwise return Qnil. */
3007 check_translation (ptrdiff_t pos
, ptrdiff_t pos_byte
, ptrdiff_t end
,
3010 int buf_size
= 16, buf_used
= 0;
3011 int *buf
= alloca (sizeof (int) * buf_size
);
3013 for (; CONSP (val
); val
= XCDR (val
))
3022 if (! VECTORP (elt
))
3025 if (len
<= end
- pos
)
3027 for (i
= 0; i
< len
; i
++)
3031 unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
3034 if (buf_used
== buf_size
)
3039 newbuf
= alloca (sizeof (int) * buf_size
);
3040 memcpy (newbuf
, buf
, sizeof (int) * buf_used
);
3043 buf
[buf_used
++] = STRING_CHAR_AND_LENGTH (p
, len1
);
3046 if (XINT (AREF (elt
, i
)) != buf
[i
])
3057 DEFUN ("translate-region-internal", Ftranslate_region_internal
,
3058 Stranslate_region_internal
, 3, 3, 0,
3059 doc
: /* Internal use only.
3060 From START to END, translate characters according to TABLE.
3061 TABLE is a string or a char-table; the Nth character in it is the
3062 mapping for the character with code N.
3063 It returns the number of characters changed. */)
3064 (Lisp_Object start
, Lisp_Object end
, register Lisp_Object table
)
3066 register unsigned char *tt
; /* Trans table. */
3067 register int nc
; /* New character. */
3068 int cnt
; /* Number of changes made. */
3069 ptrdiff_t size
; /* Size of translate table. */
3070 ptrdiff_t pos
, pos_byte
, end_pos
;
3071 int multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3072 int string_multibyte
IF_LINT (= 0);
3074 validate_region (&start
, &end
);
3075 if (CHAR_TABLE_P (table
))
3077 if (! EQ (XCHAR_TABLE (table
)->purpose
, Qtranslation_table
))
3078 error ("Not a translation table");
3084 CHECK_STRING (table
);
3086 if (! multibyte
&& (SCHARS (table
) < SBYTES (table
)))
3087 table
= string_make_unibyte (table
);
3088 string_multibyte
= SCHARS (table
) < SBYTES (table
);
3089 size
= SBYTES (table
);
3094 pos_byte
= CHAR_TO_BYTE (pos
);
3095 end_pos
= XINT (end
);
3096 modify_region (current_buffer
, pos
, end_pos
, 0);
3099 for (; pos
< end_pos
; )
3101 register unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
3102 unsigned char *str
, buf
[MAX_MULTIBYTE_LENGTH
];
3108 oc
= STRING_CHAR_AND_LENGTH (p
, len
);
3115 /* Reload as signal_after_change in last iteration may GC. */
3117 if (string_multibyte
)
3119 str
= tt
+ string_char_to_byte (table
, oc
);
3120 nc
= STRING_CHAR_AND_LENGTH (str
, str_len
);
3125 if (! ASCII_BYTE_P (nc
) && multibyte
)
3127 str_len
= BYTE8_STRING (nc
, buf
);
3140 val
= CHAR_TABLE_REF (table
, oc
);
3141 if (CHARACTERP (val
))
3143 nc
= XFASTINT (val
);
3144 str_len
= CHAR_STRING (nc
, buf
);
3147 else if (VECTORP (val
) || (CONSP (val
)))
3149 /* VAL is [TO_CHAR ...] or (([FROM-CHAR ...] . TO) ...)
3150 where TO is TO-CHAR or [TO-CHAR ...]. */
3155 if (nc
!= oc
&& nc
>= 0)
3157 /* Simple one char to one char translation. */
3162 /* This is less efficient, because it moves the gap,
3163 but it should handle multibyte characters correctly. */
3164 string
= make_multibyte_string ((char *) str
, 1, str_len
);
3165 replace_range (pos
, pos
+ 1, string
, 1, 0, 1);
3170 record_change (pos
, 1);
3171 while (str_len
-- > 0)
3173 signal_after_change (pos
, 1, 1);
3174 update_compositions (pos
, pos
+ 1, CHECK_BORDER
);
3184 val
= check_translation (pos
, pos_byte
, end_pos
, val
);
3191 /* VAL is ([FROM-CHAR ...] . TO). */
3192 len
= ASIZE (XCAR (val
));
3200 string
= Fconcat (1, &val
);
3204 string
= Fmake_string (make_number (1), val
);
3206 replace_range (pos
, pos
+ len
, string
, 1, 0, 1);
3207 pos_byte
+= SBYTES (string
);
3208 pos
+= SCHARS (string
);
3209 cnt
+= SCHARS (string
);
3210 end_pos
+= SCHARS (string
) - len
;
3218 return make_number (cnt
);
3221 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
3222 doc
: /* Delete the text between START and END.
3223 If called interactively, delete the region between point and mark.
3224 This command deletes buffer text without modifying the kill ring. */)
3225 (Lisp_Object start
, Lisp_Object end
)
3227 validate_region (&start
, &end
);
3228 del_range (XINT (start
), XINT (end
));
3232 DEFUN ("delete-and-extract-region", Fdelete_and_extract_region
,
3233 Sdelete_and_extract_region
, 2, 2, 0,
3234 doc
: /* Delete the text between START and END and return it. */)
3235 (Lisp_Object start
, Lisp_Object end
)
3237 validate_region (&start
, &end
);
3238 if (XINT (start
) == XINT (end
))
3239 return empty_unibyte_string
;
3240 return del_range_1 (XINT (start
), XINT (end
), 1, 1);
3243 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
3244 doc
: /* Remove restrictions (narrowing) from current buffer.
3245 This allows the buffer's full text to be seen and edited. */)
3248 if (BEG
!= BEGV
|| Z
!= ZV
)
3249 current_buffer
->clip_changed
= 1;
3251 BEGV_BYTE
= BEG_BYTE
;
3252 SET_BUF_ZV_BOTH (current_buffer
, Z
, Z_BYTE
);
3253 /* Changing the buffer bounds invalidates any recorded current column. */
3254 invalidate_current_column ();
3258 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
3259 doc
: /* Restrict editing in this buffer to the current region.
3260 The rest of the text becomes temporarily invisible and untouchable
3261 but is not deleted; if you save the buffer in a file, the invisible
3262 text is included in the file. \\[widen] makes all visible again.
3263 See also `save-restriction'.
3265 When calling from a program, pass two arguments; positions (integers
3266 or markers) bounding the text that should remain visible. */)
3267 (register Lisp_Object start
, Lisp_Object end
)
3269 CHECK_NUMBER_COERCE_MARKER (start
);
3270 CHECK_NUMBER_COERCE_MARKER (end
);
3272 if (XINT (start
) > XINT (end
))
3275 tem
= start
; start
= end
; end
= tem
;
3278 if (!(BEG
<= XINT (start
) && XINT (start
) <= XINT (end
) && XINT (end
) <= Z
))
3279 args_out_of_range (start
, end
);
3281 if (BEGV
!= XFASTINT (start
) || ZV
!= XFASTINT (end
))
3282 current_buffer
->clip_changed
= 1;
3284 SET_BUF_BEGV (current_buffer
, XFASTINT (start
));
3285 SET_BUF_ZV (current_buffer
, XFASTINT (end
));
3286 if (PT
< XFASTINT (start
))
3287 SET_PT (XFASTINT (start
));
3288 if (PT
> XFASTINT (end
))
3289 SET_PT (XFASTINT (end
));
3290 /* Changing the buffer bounds invalidates any recorded current column. */
3291 invalidate_current_column ();
3296 save_restriction_save (void)
3298 if (BEGV
== BEG
&& ZV
== Z
)
3299 /* The common case that the buffer isn't narrowed.
3300 We return just the buffer object, which save_restriction_restore
3301 recognizes as meaning `no restriction'. */
3302 return Fcurrent_buffer ();
3304 /* We have to save a restriction, so return a pair of markers, one
3305 for the beginning and one for the end. */
3307 Lisp_Object beg
, end
;
3309 beg
= build_marker (current_buffer
, BEGV
, BEGV_BYTE
);
3310 end
= build_marker (current_buffer
, ZV
, ZV_BYTE
);
3312 /* END must move forward if text is inserted at its exact location. */
3313 XMARKER (end
)->insertion_type
= 1;
3315 return Fcons (beg
, end
);
3320 save_restriction_restore (Lisp_Object data
)
3322 struct buffer
*cur
= NULL
;
3323 struct buffer
*buf
= (CONSP (data
)
3324 ? XMARKER (XCAR (data
))->buffer
3327 if (buf
&& buf
!= current_buffer
&& !NILP (BVAR (buf
, pt_marker
)))
3328 { /* If `buf' uses markers to keep track of PT, BEGV, and ZV (as
3329 is the case if it is or has an indirect buffer), then make
3330 sure it is current before we update BEGV, so
3331 set_buffer_internal takes care of managing those markers. */
3332 cur
= current_buffer
;
3333 set_buffer_internal (buf
);
3337 /* A pair of marks bounding a saved restriction. */
3339 struct Lisp_Marker
*beg
= XMARKER (XCAR (data
));
3340 struct Lisp_Marker
*end
= XMARKER (XCDR (data
));
3341 eassert (buf
== end
->buffer
);
3343 if (buf
/* Verify marker still points to a buffer. */
3344 && (beg
->charpos
!= BUF_BEGV (buf
) || end
->charpos
!= BUF_ZV (buf
)))
3345 /* The restriction has changed from the saved one, so restore
3346 the saved restriction. */
3348 ptrdiff_t pt
= BUF_PT (buf
);
3350 SET_BUF_BEGV_BOTH (buf
, beg
->charpos
, beg
->bytepos
);
3351 SET_BUF_ZV_BOTH (buf
, end
->charpos
, end
->bytepos
);
3353 if (pt
< beg
->charpos
|| pt
> end
->charpos
)
3354 /* The point is outside the new visible range, move it inside. */
3355 SET_BUF_PT_BOTH (buf
,
3356 clip_to_bounds (beg
->charpos
, pt
, end
->charpos
),
3357 clip_to_bounds (beg
->bytepos
, BUF_PT_BYTE (buf
),
3360 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3364 /* A buffer, which means that there was no old restriction. */
3366 if (buf
/* Verify marker still points to a buffer. */
3367 && (BUF_BEGV (buf
) != BUF_BEG (buf
) || BUF_ZV (buf
) != BUF_Z (buf
)))
3368 /* The buffer has been narrowed, get rid of the narrowing. */
3370 SET_BUF_BEGV_BOTH (buf
, BUF_BEG (buf
), BUF_BEG_BYTE (buf
));
3371 SET_BUF_ZV_BOTH (buf
, BUF_Z (buf
), BUF_Z_BYTE (buf
));
3373 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3377 /* Changing the buffer bounds invalidates any recorded current column. */
3378 invalidate_current_column ();
3381 set_buffer_internal (cur
);
3386 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
3387 doc
: /* Execute BODY, saving and restoring current buffer's restrictions.
3388 The buffer's restrictions make parts of the beginning and end invisible.
3389 \(They are set up with `narrow-to-region' and eliminated with `widen'.)
3390 This special form, `save-restriction', saves the current buffer's restrictions
3391 when it is entered, and restores them when it is exited.
3392 So any `narrow-to-region' within BODY lasts only until the end of the form.
3393 The old restrictions settings are restored
3394 even in case of abnormal exit (throw or error).
3396 The value returned is the value of the last form in BODY.
3398 Note: if you are using both `save-excursion' and `save-restriction',
3399 use `save-excursion' outermost:
3400 (save-excursion (save-restriction ...))
3402 usage: (save-restriction &rest BODY) */)
3405 register Lisp_Object val
;
3406 ptrdiff_t count
= SPECPDL_INDEX ();
3408 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
3409 val
= Fprogn (body
);
3410 return unbind_to (count
, val
);
3413 /* Buffer for the most recent text displayed by Fmessage_box. */
3414 static char *message_text
;
3416 /* Allocated length of that buffer. */
3417 static ptrdiff_t message_length
;
3419 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
3420 doc
: /* Display a message at the bottom of the screen.
3421 The message also goes into the `*Messages*' buffer.
3422 \(In keyboard macros, that's all it does.)
3425 The first argument is a format control string, and the rest are data
3426 to be formatted under control of the string. See `format' for details.
3428 Note: Use (message "%s" VALUE) to print the value of expressions and
3429 variables to avoid accidentally interpreting `%' as format specifiers.
3431 If the first argument is nil or the empty string, the function clears
3432 any existing message; this lets the minibuffer contents show. See
3433 also `current-message'.
3435 usage: (message FORMAT-STRING &rest ARGS) */)
3436 (ptrdiff_t nargs
, Lisp_Object
*args
)
3439 || (STRINGP (args
[0])
3440 && SBYTES (args
[0]) == 0))
3447 register Lisp_Object val
;
3448 val
= Fformat (nargs
, args
);
3449 message3 (val
, SBYTES (val
), STRING_MULTIBYTE (val
));
3454 DEFUN ("message-box", Fmessage_box
, Smessage_box
, 1, MANY
, 0,
3455 doc
: /* Display a message, in a dialog box if possible.
3456 If a dialog box is not available, use the echo area.
3457 The first argument is a format control string, and the rest are data
3458 to be formatted under control of the string. See `format' for details.
3460 If the first argument is nil or the empty string, clear any existing
3461 message; let the minibuffer contents show.
3463 usage: (message-box FORMAT-STRING &rest ARGS) */)
3464 (ptrdiff_t nargs
, Lisp_Object
*args
)
3473 register Lisp_Object val
;
3474 val
= Fformat (nargs
, args
);
3476 /* The MS-DOS frames support popup menus even though they are
3477 not FRAME_WINDOW_P. */
3478 if (FRAME_WINDOW_P (XFRAME (selected_frame
))
3479 || FRAME_MSDOS_P (XFRAME (selected_frame
)))
3481 Lisp_Object pane
, menu
;
3482 struct gcpro gcpro1
;
3483 pane
= Fcons (Fcons (build_string ("OK"), Qt
), Qnil
);
3485 menu
= Fcons (val
, pane
);
3486 Fx_popup_dialog (Qt
, menu
, Qt
);
3490 #endif /* HAVE_MENUS */
3491 /* Copy the data so that it won't move when we GC. */
3492 if (SBYTES (val
) > message_length
)
3494 ptrdiff_t new_length
= SBYTES (val
) + 80;
3495 message_text
= xrealloc (message_text
, new_length
);
3496 message_length
= new_length
;
3498 memcpy (message_text
, SDATA (val
), SBYTES (val
));
3499 message2 (message_text
, SBYTES (val
),
3500 STRING_MULTIBYTE (val
));
3505 DEFUN ("message-or-box", Fmessage_or_box
, Smessage_or_box
, 1, MANY
, 0,
3506 doc
: /* Display a message in a dialog box or in the echo area.
3507 If this command was invoked with the mouse, use a dialog box if
3508 `use-dialog-box' is non-nil.
3509 Otherwise, use the echo area.
3510 The first argument is a format control string, and the rest are data
3511 to be formatted under control of the string. See `format' for details.
3513 If the first argument is nil or the empty string, clear any existing
3514 message; let the minibuffer contents show.
3516 usage: (message-or-box FORMAT-STRING &rest ARGS) */)
3517 (ptrdiff_t nargs
, Lisp_Object
*args
)
3520 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3522 return Fmessage_box (nargs
, args
);
3524 return Fmessage (nargs
, args
);
3527 DEFUN ("current-message", Fcurrent_message
, Scurrent_message
, 0, 0, 0,
3528 doc
: /* Return the string currently displayed in the echo area, or nil if none. */)
3531 return current_message ();
3535 DEFUN ("propertize", Fpropertize
, Spropertize
, 1, MANY
, 0,
3536 doc
: /* Return a copy of STRING with text properties added.
3537 First argument is the string to copy.
3538 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
3539 properties to add to the result.
3540 usage: (propertize STRING &rest PROPERTIES) */)
3541 (ptrdiff_t nargs
, Lisp_Object
*args
)
3543 Lisp_Object properties
, string
;
3544 struct gcpro gcpro1
, gcpro2
;
3547 /* Number of args must be odd. */
3548 if ((nargs
& 1) == 0)
3549 error ("Wrong number of arguments");
3551 properties
= string
= Qnil
;
3552 GCPRO2 (properties
, string
);
3554 /* First argument must be a string. */
3555 CHECK_STRING (args
[0]);
3556 string
= Fcopy_sequence (args
[0]);
3558 for (i
= 1; i
< nargs
; i
+= 2)
3559 properties
= Fcons (args
[i
], Fcons (args
[i
+ 1], properties
));
3561 Fadd_text_properties (make_number (0),
3562 make_number (SCHARS (string
)),
3563 properties
, string
);
3564 RETURN_UNGCPRO (string
);
3567 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
3568 doc
: /* Format a string out of a format-string and arguments.
3569 The first argument is a format control string.
3570 The other arguments are substituted into it to make the result, a string.
3572 The format control string may contain %-sequences meaning to substitute
3573 the next available argument:
3575 %s means print a string argument. Actually, prints any object, with `princ'.
3576 %d means print as number in decimal (%o octal, %x hex).
3577 %X is like %x, but uses upper case.
3578 %e means print a number in exponential notation.
3579 %f means print a number in decimal-point notation.
3580 %g means print a number in exponential notation
3581 or decimal-point notation, whichever uses fewer characters.
3582 %c means print a number as a single character.
3583 %S means print any object as an s-expression (using `prin1').
3585 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.
3586 Use %% to put a single % into the output.
3588 A %-sequence may contain optional flag, width, and precision
3589 specifiers, as follows:
3591 %<flags><width><precision>character
3593 where flags is [+ #-0]+, width is [0-9]+, and precision is .[0-9]+
3595 The + flag character inserts a + before any positive number, while a
3596 space inserts a space before any positive number; these flags only
3597 affect %d, %e, %f, and %g sequences, and the + flag takes precedence.
3598 The # flag means to use an alternate display form for %o, %x, %X, %e,
3599 %f, and %g sequences. The - and 0 flags affect the width specifier,
3602 The width specifier supplies a lower limit for the length of the
3603 printed representation. The padding, if any, normally goes on the
3604 left, but it goes on the right if the - flag is present. The padding
3605 character is normally a space, but it is 0 if the 0 flag is present.
3606 The 0 flag is ignored if the - flag is present, or the format sequence
3607 is something other than %d, %e, %f, and %g.
3609 For %e, %f, and %g sequences, the number after the "." in the
3610 precision specifier says how many decimal places to show; if zero, the
3611 decimal point itself is omitted. For %s and %S, the precision
3612 specifier truncates the string to the given width.
3614 usage: (format STRING &rest OBJECTS) */)
3615 (ptrdiff_t nargs
, Lisp_Object
*args
)
3617 ptrdiff_t n
; /* The number of the next arg to substitute */
3618 char initial_buffer
[4000];
3619 char *buf
= initial_buffer
;
3620 ptrdiff_t bufsize
= sizeof initial_buffer
;
3621 ptrdiff_t max_bufsize
= STRING_BYTES_BOUND
+ 1;
3623 Lisp_Object buf_save_value
IF_LINT (= {0});
3624 register char *format
, *end
, *format_start
;
3625 ptrdiff_t formatlen
, nchars
;
3626 /* Nonzero if the format is multibyte. */
3627 int multibyte_format
= 0;
3628 /* Nonzero if the output should be a multibyte string,
3629 which is true if any of the inputs is one. */
3631 /* When we make a multibyte string, we must pay attention to the
3632 byte combining problem, i.e., a byte may be combined with a
3633 multibyte character of the previous string. This flag tells if we
3634 must consider such a situation or not. */
3635 int maybe_combine_byte
;
3637 int arg_intervals
= 0;
3640 /* discarded[I] is 1 if byte I of the format
3641 string was not copied into the output.
3642 It is 2 if byte I was not the first byte of its character. */
3645 /* Each element records, for one argument,
3646 the start and end bytepos in the output string,
3647 whether the argument has been converted to string (e.g., due to "%S"),
3648 and whether the argument is a string with intervals.
3649 info[0] is unused. Unused elements have -1 for start. */
3652 ptrdiff_t start
, end
;
3653 int converted_to_string
;
3657 /* It should not be necessary to GCPRO ARGS, because
3658 the caller in the interpreter should take care of that. */
3660 CHECK_STRING (args
[0]);
3661 format_start
= SSDATA (args
[0]);
3662 formatlen
= SBYTES (args
[0]);
3664 /* Allocate the info and discarded tables. */
3667 if ((SIZE_MAX
- formatlen
) / sizeof (struct info
) <= nargs
)
3668 memory_full (SIZE_MAX
);
3669 SAFE_ALLOCA (info
, struct info
*, (nargs
+ 1) * sizeof *info
+ formatlen
);
3670 discarded
= (char *) &info
[nargs
+ 1];
3671 for (i
= 0; i
< nargs
+ 1; i
++)
3674 info
[i
].intervals
= info
[i
].converted_to_string
= 0;
3676 memset (discarded
, 0, formatlen
);
3679 /* Try to determine whether the result should be multibyte.
3680 This is not always right; sometimes the result needs to be multibyte
3681 because of an object that we will pass through prin1,
3682 and in that case, we won't know it here. */
3683 multibyte_format
= STRING_MULTIBYTE (args
[0]);
3684 multibyte
= multibyte_format
;
3685 for (n
= 1; !multibyte
&& n
< nargs
; n
++)
3686 if (STRINGP (args
[n
]) && STRING_MULTIBYTE (args
[n
]))
3689 /* If we start out planning a unibyte result,
3690 then discover it has to be multibyte, we jump back to retry. */
3697 /* Scan the format and store result in BUF. */
3698 format
= format_start
;
3699 end
= format
+ formatlen
;
3700 maybe_combine_byte
= 0;
3702 while (format
!= end
)
3704 /* The values of N and FORMAT when the loop body is entered. */
3706 char *format0
= format
;
3708 /* Bytes needed to represent the output of this conversion. */
3709 ptrdiff_t convbytes
;
3713 /* General format specifications look like
3715 '%' [flags] [field-width] [precision] format
3720 field-width ::= [0-9]+
3721 precision ::= '.' [0-9]*
3723 If a field-width is specified, it specifies to which width
3724 the output should be padded with blanks, if the output
3725 string is shorter than field-width.
3727 If precision is specified, it specifies the number of
3728 digits to print after the '.' for floats, or the max.
3729 number of chars to print from a string. */
3736 ptrdiff_t field_width
;
3737 int precision_given
;
3738 uintmax_t precision
= UINTMAX_MAX
;
3746 case '-': minus_flag
= 1; continue;
3747 case '+': plus_flag
= 1; continue;
3748 case ' ': space_flag
= 1; continue;
3749 case '#': sharp_flag
= 1; continue;
3750 case '0': zero_flag
= 1; continue;
3755 /* Ignore flags when sprintf ignores them. */
3756 space_flag
&= ~ plus_flag
;
3757 zero_flag
&= ~ minus_flag
;
3760 uintmax_t w
= strtoumax (format
, &num_end
, 10);
3761 if (max_bufsize
<= w
)
3765 precision_given
= *num_end
== '.';
3766 if (precision_given
)
3767 precision
= strtoumax (num_end
+ 1, &num_end
, 10);
3771 error ("Format string ends in middle of format specifier");
3773 memset (&discarded
[format0
- format_start
], 1, format
- format0
);
3774 conversion
= *format
;
3775 if (conversion
== '%')
3777 discarded
[format
- format_start
] = 1;
3782 error ("Not enough arguments for format string");
3784 /* For 'S', prin1 the argument, and then treat like 's'.
3785 For 's', princ any argument that is not a string or
3786 symbol. But don't do this conversion twice, which might
3787 happen after retrying. */
3788 if ((conversion
== 'S'
3789 || (conversion
== 's'
3790 && ! STRINGP (args
[n
]) && ! SYMBOLP (args
[n
]))))
3792 if (! info
[n
].converted_to_string
)
3794 Lisp_Object noescape
= conversion
== 'S' ? Qnil
: Qt
;
3795 args
[n
] = Fprin1_to_string (args
[n
], noescape
);
3796 info
[n
].converted_to_string
= 1;
3797 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
3805 else if (conversion
== 'c')
3807 if (FLOATP (args
[n
]))
3809 double d
= XFLOAT_DATA (args
[n
]);
3810 args
[n
] = make_number (FIXNUM_OVERFLOW_P (d
) ? -1 : d
);
3813 if (INTEGERP (args
[n
]) && ! ASCII_CHAR_P (XINT (args
[n
])))
3820 args
[n
] = Fchar_to_string (args
[n
]);
3821 info
[n
].converted_to_string
= 1;
3824 if (info
[n
].converted_to_string
)
3829 if (SYMBOLP (args
[n
]))
3831 args
[n
] = SYMBOL_NAME (args
[n
]);
3832 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
3839 if (conversion
== 's')
3841 /* handle case (precision[n] >= 0) */
3843 ptrdiff_t width
, padding
, nbytes
;
3844 ptrdiff_t nchars_string
;
3846 ptrdiff_t prec
= -1;
3847 if (precision_given
&& precision
<= TYPE_MAXIMUM (ptrdiff_t))
3850 /* lisp_string_width ignores a precision of 0, but GNU
3851 libc functions print 0 characters when the precision
3852 is 0. Imitate libc behavior here. Changing
3853 lisp_string_width is the right thing, and will be
3854 done, but meanwhile we work with it. */
3857 width
= nchars_string
= nbytes
= 0;
3861 width
= lisp_string_width (args
[n
], prec
, &nch
, &nby
);
3864 nchars_string
= SCHARS (args
[n
]);
3865 nbytes
= SBYTES (args
[n
]);
3869 nchars_string
= nch
;
3875 if (convbytes
&& multibyte
&& ! STRING_MULTIBYTE (args
[n
]))
3876 convbytes
= count_size_as_multibyte (SDATA (args
[n
]), nbytes
);
3878 padding
= width
< field_width
? field_width
- width
: 0;
3880 if (max_bufsize
- padding
<= convbytes
)
3882 convbytes
+= padding
;
3883 if (convbytes
<= buf
+ bufsize
- p
)
3887 memset (p
, ' ', padding
);
3894 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3895 && STRING_MULTIBYTE (args
[n
])
3896 && !CHAR_HEAD_P (SREF (args
[n
], 0)))
3897 maybe_combine_byte
= 1;
3899 p
+= copy_text (SDATA (args
[n
]), (unsigned char *) p
,
3901 STRING_MULTIBYTE (args
[n
]), multibyte
);
3903 info
[n
].start
= nchars
;
3904 nchars
+= nchars_string
;
3905 info
[n
].end
= nchars
;
3909 memset (p
, ' ', padding
);
3914 /* If this argument has text properties, record where
3915 in the result string it appears. */
3916 if (STRING_INTERVALS (args
[n
]))
3917 info
[n
].intervals
= arg_intervals
= 1;
3922 else if (! (conversion
== 'c' || conversion
== 'd'
3923 || conversion
== 'e' || conversion
== 'f'
3924 || conversion
== 'g' || conversion
== 'i'
3925 || conversion
== 'o' || conversion
== 'x'
3926 || conversion
== 'X'))
3927 error ("Invalid format operation %%%c",
3928 STRING_CHAR ((unsigned char *) format
- 1));
3929 else if (! (INTEGERP (args
[n
]) || FLOATP (args
[n
])))
3930 error ("Format specifier doesn't match argument type");
3935 /* Maximum precision for a %f conversion such that the
3936 trailing output digit might be nonzero. Any precision
3937 larger than this will not yield useful information. */
3938 USEFUL_PRECISION_MAX
=
3940 * (FLT_RADIX
== 2 || FLT_RADIX
== 10 ? 1
3941 : FLT_RADIX
== 16 ? 4
3944 /* Maximum number of bytes generated by any format, if
3945 precision is no more than USEFUL_PRECISION_MAX.
3946 On all practical hosts, %f is the worst case. */
3948 sizeof "-." + (DBL_MAX_10_EXP
+ 1) + USEFUL_PRECISION_MAX
,
3950 /* Length of pM (that is, of pMd without the
3952 pMlen
= sizeof pMd
- 2
3954 verify (0 < USEFUL_PRECISION_MAX
);
3957 ptrdiff_t padding
, sprintf_bytes
;
3958 uintmax_t excess_precision
, numwidth
;
3959 uintmax_t leading_zeros
= 0, trailing_zeros
= 0;
3961 char sprintf_buf
[SPRINTF_BUFSIZE
];
3963 /* Copy of conversion specification, modified somewhat.
3964 At most three flags F can be specified at once. */
3965 char convspec
[sizeof "%FFF.*d" + pMlen
];
3967 /* Avoid undefined behavior in underlying sprintf. */
3968 if (conversion
== 'd' || conversion
== 'i')
3971 /* Create the copy of the conversion specification, with
3972 any width and precision removed, with ".*" inserted,
3973 and with pM inserted for integer formats. */
3977 *f
= '-'; f
+= minus_flag
;
3978 *f
= '+'; f
+= plus_flag
;
3979 *f
= ' '; f
+= space_flag
;
3980 *f
= '#'; f
+= sharp_flag
;
3981 *f
= '0'; f
+= zero_flag
;
3984 if (conversion
== 'd' || conversion
== 'i'
3985 || conversion
== 'o' || conversion
== 'x'
3986 || conversion
== 'X')
3988 memcpy (f
, pMd
, pMlen
);
3990 zero_flag
&= ~ precision_given
;
3997 if (precision_given
)
3998 prec
= min (precision
, USEFUL_PRECISION_MAX
);
4000 /* Use sprintf to format this number into sprintf_buf. Omit
4001 padding and excess precision, though, because sprintf limits
4002 output length to INT_MAX.
4004 There are four types of conversion: double, unsigned
4005 char (passed as int), wide signed int, and wide
4006 unsigned int. Treat them separately because the
4007 sprintf ABI is sensitive to which type is passed. Be
4008 careful about integer overflow, NaNs, infinities, and
4009 conversions; for example, the min and max macros are
4010 not suitable here. */
4011 if (conversion
== 'e' || conversion
== 'f' || conversion
== 'g')
4013 double x
= (INTEGERP (args
[n
])
4015 : XFLOAT_DATA (args
[n
]));
4016 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4018 else if (conversion
== 'c')
4020 /* Don't use sprintf here, as it might mishandle prec. */
4021 sprintf_buf
[0] = XINT (args
[n
]);
4022 sprintf_bytes
= prec
!= 0;
4024 else if (conversion
== 'd')
4026 /* For float, maybe we should use "%1.0f"
4027 instead so it also works for values outside
4028 the integer range. */
4030 if (INTEGERP (args
[n
]))
4034 double d
= XFLOAT_DATA (args
[n
]);
4037 x
= TYPE_MINIMUM (printmax_t
);
4043 x
= TYPE_MAXIMUM (printmax_t
);
4048 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4052 /* Don't sign-extend for octal or hex printing. */
4054 if (INTEGERP (args
[n
]))
4055 x
= XUINT (args
[n
]);
4058 double d
= XFLOAT_DATA (args
[n
]);
4063 x
= TYPE_MAXIMUM (uprintmax_t
);
4068 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4071 /* Now the length of the formatted item is known, except it omits
4072 padding and excess precision. Deal with excess precision
4073 first. This happens only when the format specifies
4074 ridiculously large precision. */
4075 excess_precision
= precision
- prec
;
4076 if (excess_precision
)
4078 if (conversion
== 'e' || conversion
== 'f'
4079 || conversion
== 'g')
4081 if ((conversion
== 'g' && ! sharp_flag
)
4082 || ! ('0' <= sprintf_buf
[sprintf_bytes
- 1]
4083 && sprintf_buf
[sprintf_bytes
- 1] <= '9'))
4084 excess_precision
= 0;
4087 if (conversion
== 'g')
4089 char *dot
= strchr (sprintf_buf
, '.');
4091 excess_precision
= 0;
4094 trailing_zeros
= excess_precision
;
4097 leading_zeros
= excess_precision
;
4100 /* Compute the total bytes needed for this item, including
4101 excess precision and padding. */
4102 numwidth
= sprintf_bytes
+ excess_precision
;
4103 padding
= numwidth
< field_width
? field_width
- numwidth
: 0;
4104 if (max_bufsize
- sprintf_bytes
<= excess_precision
4105 || max_bufsize
- padding
<= numwidth
)
4107 convbytes
= numwidth
+ padding
;
4109 if (convbytes
<= buf
+ bufsize
- p
)
4111 /* Copy the formatted item from sprintf_buf into buf,
4112 inserting padding and excess-precision zeros. */
4114 char *src
= sprintf_buf
;
4116 int exponent_bytes
= 0;
4117 int signedp
= src0
== '-' || src0
== '+' || src0
== ' ';
4118 int significand_bytes
;
4120 && ((src
[signedp
] >= '0' && src
[signedp
] <= '9')
4121 || (src
[signedp
] >= 'a' && src
[signedp
] <= 'f')
4122 || (src
[signedp
] >= 'A' && src
[signedp
] <= 'F')))
4124 leading_zeros
+= padding
;
4128 if (excess_precision
4129 && (conversion
== 'e' || conversion
== 'g'))
4131 char *e
= strchr (src
, 'e');
4133 exponent_bytes
= src
+ sprintf_bytes
- e
;
4138 memset (p
, ' ', padding
);
4146 memset (p
, '0', leading_zeros
);
4148 significand_bytes
= sprintf_bytes
- signedp
- exponent_bytes
;
4149 memcpy (p
, src
, significand_bytes
);
4150 p
+= significand_bytes
;
4151 src
+= significand_bytes
;
4152 memset (p
, '0', trailing_zeros
);
4153 p
+= trailing_zeros
;
4154 memcpy (p
, src
, exponent_bytes
);
4155 p
+= exponent_bytes
;
4157 info
[n
].start
= nchars
;
4158 nchars
+= leading_zeros
+ sprintf_bytes
+ trailing_zeros
;
4159 info
[n
].end
= nchars
;
4163 memset (p
, ' ', padding
);
4175 /* Copy a single character from format to buf. */
4178 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
4180 if (multibyte_format
)
4182 /* Copy a whole multibyte character. */
4184 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
4185 && !CHAR_HEAD_P (*format
))
4186 maybe_combine_byte
= 1;
4190 while (! CHAR_HEAD_P (*format
));
4192 convbytes
= format
- src
;
4193 memset (&discarded
[src
+ 1 - format_start
], 2, convbytes
- 1);
4197 unsigned char uc
= *format
++;
4198 if (! multibyte
|| ASCII_BYTE_P (uc
))
4202 int c
= BYTE8_TO_CHAR (uc
);
4203 convbytes
= CHAR_STRING (c
, str
);
4208 if (convbytes
<= buf
+ bufsize
- p
)
4210 memcpy (p
, src
, convbytes
);
4217 /* There wasn't enough room to store this conversion or single
4218 character. CONVBYTES says how much room is needed. Allocate
4219 enough room (and then some) and do it again. */
4221 ptrdiff_t used
= p
- buf
;
4223 if (max_bufsize
- used
< convbytes
)
4225 bufsize
= used
+ convbytes
;
4226 bufsize
= bufsize
< max_bufsize
/ 2 ? bufsize
* 2 : max_bufsize
;
4228 if (buf
== initial_buffer
)
4230 buf
= xmalloc (bufsize
);
4232 buf_save_value
= make_save_value (buf
, 0);
4233 record_unwind_protect (safe_alloca_unwind
, buf_save_value
);
4234 memcpy (buf
, initial_buffer
, used
);
4237 XSAVE_VALUE (buf_save_value
)->pointer
= buf
= xrealloc (buf
, bufsize
);
4246 if (bufsize
< p
- buf
)
4249 if (maybe_combine_byte
)
4250 nchars
= multibyte_chars_in_text ((unsigned char *) buf
, p
- buf
);
4251 val
= make_specified_string (buf
, nchars
, p
- buf
, multibyte
);
4253 /* If we allocated BUF with malloc, free it too. */
4256 /* If the format string has text properties, or any of the string
4257 arguments has text properties, set up text properties of the
4260 if (STRING_INTERVALS (args
[0]) || arg_intervals
)
4262 Lisp_Object len
, new_len
, props
;
4263 struct gcpro gcpro1
;
4265 /* Add text properties from the format string. */
4266 len
= make_number (SCHARS (args
[0]));
4267 props
= text_property_list (args
[0], make_number (0), len
, Qnil
);
4272 ptrdiff_t bytepos
= 0, position
= 0, translated
= 0;
4276 /* Adjust the bounds of each text property
4277 to the proper start and end in the output string. */
4279 /* Put the positions in PROPS in increasing order, so that
4280 we can do (effectively) one scan through the position
4281 space of the format string. */
4282 props
= Fnreverse (props
);
4284 /* BYTEPOS is the byte position in the format string,
4285 POSITION is the untranslated char position in it,
4286 TRANSLATED is the translated char position in BUF,
4287 and ARGN is the number of the next arg we will come to. */
4288 for (list
= props
; CONSP (list
); list
= XCDR (list
))
4295 /* First adjust the property start position. */
4296 pos
= XINT (XCAR (item
));
4298 /* Advance BYTEPOS, POSITION, TRANSLATED and ARGN
4299 up to this position. */
4300 for (; position
< pos
; bytepos
++)
4302 if (! discarded
[bytepos
])
4303 position
++, translated
++;
4304 else if (discarded
[bytepos
] == 1)
4307 if (translated
== info
[argn
].start
)
4309 translated
+= info
[argn
].end
- info
[argn
].start
;
4315 XSETCAR (item
, make_number (translated
));
4317 /* Likewise adjust the property end position. */
4318 pos
= XINT (XCAR (XCDR (item
)));
4320 for (; position
< pos
; bytepos
++)
4322 if (! discarded
[bytepos
])
4323 position
++, translated
++;
4324 else if (discarded
[bytepos
] == 1)
4327 if (translated
== info
[argn
].start
)
4329 translated
+= info
[argn
].end
- info
[argn
].start
;
4335 XSETCAR (XCDR (item
), make_number (translated
));
4338 add_text_properties_from_list (val
, props
, make_number (0));
4341 /* Add text properties from arguments. */
4343 for (n
= 1; n
< nargs
; ++n
)
4344 if (info
[n
].intervals
)
4346 len
= make_number (SCHARS (args
[n
]));
4347 new_len
= make_number (info
[n
].end
- info
[n
].start
);
4348 props
= text_property_list (args
[n
], make_number (0), len
, Qnil
);
4349 props
= extend_property_ranges (props
, new_len
);
4350 /* If successive arguments have properties, be sure that
4351 the value of `composition' property be the copy. */
4352 if (n
> 1 && info
[n
- 1].end
)
4353 make_composition_value_copy (props
);
4354 add_text_properties_from_list (val
, props
,
4355 make_number (info
[n
].start
));
4365 format2 (const char *string1
, Lisp_Object arg0
, Lisp_Object arg1
)
4367 Lisp_Object args
[3];
4368 args
[0] = build_string (string1
);
4371 return Fformat (3, args
);
4374 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
4375 doc
: /* Return t if two characters match, optionally ignoring case.
4376 Both arguments must be characters (i.e. integers).
4377 Case is ignored if `case-fold-search' is non-nil in the current buffer. */)
4378 (register Lisp_Object c1
, Lisp_Object c2
)
4381 /* Check they're chars, not just integers, otherwise we could get array
4382 bounds violations in downcase. */
4383 CHECK_CHARACTER (c1
);
4384 CHECK_CHARACTER (c2
);
4386 if (XINT (c1
) == XINT (c2
))
4388 if (NILP (BVAR (current_buffer
, case_fold_search
)))
4392 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
))
4393 && ! ASCII_CHAR_P (i1
))
4395 MAKE_CHAR_MULTIBYTE (i1
);
4398 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
))
4399 && ! ASCII_CHAR_P (i2
))
4401 MAKE_CHAR_MULTIBYTE (i2
);
4403 return (downcase (i1
) == downcase (i2
) ? Qt
: Qnil
);
4406 /* Transpose the markers in two regions of the current buffer, and
4407 adjust the ones between them if necessary (i.e.: if the regions
4410 START1, END1 are the character positions of the first region.
4411 START1_BYTE, END1_BYTE are the byte positions.
4412 START2, END2 are the character positions of the second region.
4413 START2_BYTE, END2_BYTE are the byte positions.
4415 Traverses the entire marker list of the buffer to do so, adding an
4416 appropriate amount to some, subtracting from some, and leaving the
4417 rest untouched. Most of this is copied from adjust_markers in insdel.c.
4419 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
4422 transpose_markers (ptrdiff_t start1
, ptrdiff_t end1
,
4423 ptrdiff_t start2
, ptrdiff_t end2
,
4424 ptrdiff_t start1_byte
, ptrdiff_t end1_byte
,
4425 ptrdiff_t start2_byte
, ptrdiff_t end2_byte
)
4427 register ptrdiff_t amt1
, amt1_byte
, amt2
, amt2_byte
, diff
, diff_byte
, mpos
;
4428 register struct Lisp_Marker
*marker
;
4430 /* Update point as if it were a marker. */
4434 TEMP_SET_PT_BOTH (PT
+ (end2
- end1
),
4435 PT_BYTE
+ (end2_byte
- end1_byte
));
4436 else if (PT
< start2
)
4437 TEMP_SET_PT_BOTH (PT
+ (end2
- start2
) - (end1
- start1
),
4438 (PT_BYTE
+ (end2_byte
- start2_byte
)
4439 - (end1_byte
- start1_byte
)));
4441 TEMP_SET_PT_BOTH (PT
- (start2
- start1
),
4442 PT_BYTE
- (start2_byte
- start1_byte
));
4444 /* We used to adjust the endpoints here to account for the gap, but that
4445 isn't good enough. Even if we assume the caller has tried to move the
4446 gap out of our way, it might still be at start1 exactly, for example;
4447 and that places it `inside' the interval, for our purposes. The amount
4448 of adjustment is nontrivial if there's a `denormalized' marker whose
4449 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
4450 the dirty work to Fmarker_position, below. */
4452 /* The difference between the region's lengths */
4453 diff
= (end2
- start2
) - (end1
- start1
);
4454 diff_byte
= (end2_byte
- start2_byte
) - (end1_byte
- start1_byte
);
4456 /* For shifting each marker in a region by the length of the other
4457 region plus the distance between the regions. */
4458 amt1
= (end2
- start2
) + (start2
- end1
);
4459 amt2
= (end1
- start1
) + (start2
- end1
);
4460 amt1_byte
= (end2_byte
- start2_byte
) + (start2_byte
- end1_byte
);
4461 amt2_byte
= (end1_byte
- start1_byte
) + (start2_byte
- end1_byte
);
4463 for (marker
= BUF_MARKERS (current_buffer
); marker
; marker
= marker
->next
)
4465 mpos
= marker
->bytepos
;
4466 if (mpos
>= start1_byte
&& mpos
< end2_byte
)
4468 if (mpos
< end1_byte
)
4470 else if (mpos
< start2_byte
)
4474 marker
->bytepos
= mpos
;
4476 mpos
= marker
->charpos
;
4477 if (mpos
>= start1
&& mpos
< end2
)
4481 else if (mpos
< start2
)
4486 marker
->charpos
= mpos
;
4490 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
4491 doc
: /* Transpose region STARTR1 to ENDR1 with STARTR2 to ENDR2.
4492 The regions should not be overlapping, because the size of the buffer is
4493 never changed in a transposition.
4495 Optional fifth arg LEAVE-MARKERS, if non-nil, means don't update
4496 any markers that happen to be located in the regions.
4498 Transposing beyond buffer boundaries is an error. */)
4499 (Lisp_Object startr1
, Lisp_Object endr1
, Lisp_Object startr2
, Lisp_Object endr2
, Lisp_Object leave_markers
)
4501 register ptrdiff_t start1
, end1
, start2
, end2
;
4502 ptrdiff_t start1_byte
, start2_byte
, len1_byte
, len2_byte
;
4503 ptrdiff_t gap
, len1
, len_mid
, len2
;
4504 unsigned char *start1_addr
, *start2_addr
, *temp
;
4506 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
, tmp_interval3
;
4509 XSETBUFFER (buf
, current_buffer
);
4510 cur_intv
= BUF_INTERVALS (current_buffer
);
4512 validate_region (&startr1
, &endr1
);
4513 validate_region (&startr2
, &endr2
);
4515 start1
= XFASTINT (startr1
);
4516 end1
= XFASTINT (endr1
);
4517 start2
= XFASTINT (startr2
);
4518 end2
= XFASTINT (endr2
);
4521 /* Swap the regions if they're reversed. */
4524 register ptrdiff_t glumph
= start1
;
4532 len1
= end1
- start1
;
4533 len2
= end2
- start2
;
4536 error ("Transposed regions overlap");
4537 /* Nothing to change for adjacent regions with one being empty */
4538 else if ((start1
== end1
|| start2
== end2
) && end1
== start2
)
4541 /* The possibilities are:
4542 1. Adjacent (contiguous) regions, or separate but equal regions
4543 (no, really equal, in this case!), or
4544 2. Separate regions of unequal size.
4546 The worst case is usually No. 2. It means that (aside from
4547 potential need for getting the gap out of the way), there also
4548 needs to be a shifting of the text between the two regions. So
4549 if they are spread far apart, we are that much slower... sigh. */
4551 /* It must be pointed out that the really studly thing to do would
4552 be not to move the gap at all, but to leave it in place and work
4553 around it if necessary. This would be extremely efficient,
4554 especially considering that people are likely to do
4555 transpositions near where they are working interactively, which
4556 is exactly where the gap would be found. However, such code
4557 would be much harder to write and to read. So, if you are
4558 reading this comment and are feeling squirrely, by all means have
4559 a go! I just didn't feel like doing it, so I will simply move
4560 the gap the minimum distance to get it out of the way, and then
4561 deal with an unbroken array. */
4563 /* Make sure the gap won't interfere, by moving it out of the text
4564 we will operate on. */
4565 if (start1
< gap
&& gap
< end2
)
4567 if (gap
- start1
< end2
- gap
)
4573 start1_byte
= CHAR_TO_BYTE (start1
);
4574 start2_byte
= CHAR_TO_BYTE (start2
);
4575 len1_byte
= CHAR_TO_BYTE (end1
) - start1_byte
;
4576 len2_byte
= CHAR_TO_BYTE (end2
) - start2_byte
;
4578 #ifdef BYTE_COMBINING_DEBUG
4581 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4582 len2_byte
, start1
, start1_byte
)
4583 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4584 len1_byte
, end2
, start2_byte
+ len2_byte
)
4585 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4586 len1_byte
, end2
, start2_byte
+ len2_byte
))
4591 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4592 len2_byte
, start1
, start1_byte
)
4593 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4594 len1_byte
, start2
, start2_byte
)
4595 || count_combining_after (BYTE_POS_ADDR (start2_byte
),
4596 len2_byte
, end1
, start1_byte
+ len1_byte
)
4597 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4598 len1_byte
, end2
, start2_byte
+ len2_byte
))
4603 /* Hmmm... how about checking to see if the gap is large
4604 enough to use as the temporary storage? That would avoid an
4605 allocation... interesting. Later, don't fool with it now. */
4607 /* Working without memmove, for portability (sigh), so must be
4608 careful of overlapping subsections of the array... */
4610 if (end1
== start2
) /* adjacent regions */
4612 modify_region (current_buffer
, start1
, end2
, 0);
4613 record_change (start1
, len1
+ len2
);
4615 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4616 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4617 /* Don't use Fset_text_properties: that can cause GC, which can
4618 clobber objects stored in the tmp_intervals. */
4619 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4620 if (!NULL_INTERVAL_P (tmp_interval3
))
4621 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4623 /* First region smaller than second. */
4624 if (len1_byte
< len2_byte
)
4628 SAFE_ALLOCA (temp
, unsigned char *, len2_byte
);
4630 /* Don't precompute these addresses. We have to compute them
4631 at the last minute, because the relocating allocator might
4632 have moved the buffer around during the xmalloc. */
4633 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4634 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4636 memcpy (temp
, start2_addr
, len2_byte
);
4637 memcpy (start1_addr
+ len2_byte
, start1_addr
, len1_byte
);
4638 memcpy (start1_addr
, temp
, len2_byte
);
4642 /* First region not smaller than second. */
4646 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4647 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4648 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4649 memcpy (temp
, start1_addr
, len1_byte
);
4650 memcpy (start1_addr
, start2_addr
, len2_byte
);
4651 memcpy (start1_addr
+ len2_byte
, temp
, len1_byte
);
4654 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
4655 len1
, current_buffer
, 0);
4656 graft_intervals_into_buffer (tmp_interval2
, start1
,
4657 len2
, current_buffer
, 0);
4658 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4659 update_compositions (start1
+ len2
, end2
, CHECK_TAIL
);
4661 /* Non-adjacent regions, because end1 != start2, bleagh... */
4664 len_mid
= start2_byte
- (start1_byte
+ len1_byte
);
4666 if (len1_byte
== len2_byte
)
4667 /* Regions are same size, though, how nice. */
4671 modify_region (current_buffer
, start1
, end1
, 0);
4672 modify_region (current_buffer
, start2
, end2
, 0);
4673 record_change (start1
, len1
);
4674 record_change (start2
, len2
);
4675 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4676 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4678 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr1
, 0);
4679 if (!NULL_INTERVAL_P (tmp_interval3
))
4680 set_text_properties_1 (startr1
, endr1
, Qnil
, buf
, tmp_interval3
);
4682 tmp_interval3
= validate_interval_range (buf
, &startr2
, &endr2
, 0);
4683 if (!NULL_INTERVAL_P (tmp_interval3
))
4684 set_text_properties_1 (startr2
, endr2
, Qnil
, buf
, tmp_interval3
);
4686 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4687 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4688 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4689 memcpy (temp
, start1_addr
, len1_byte
);
4690 memcpy (start1_addr
, start2_addr
, len2_byte
);
4691 memcpy (start2_addr
, temp
, len1_byte
);
4694 graft_intervals_into_buffer (tmp_interval1
, start2
,
4695 len1
, current_buffer
, 0);
4696 graft_intervals_into_buffer (tmp_interval2
, start1
,
4697 len2
, current_buffer
, 0);
4700 else if (len1_byte
< len2_byte
) /* Second region larger than first */
4701 /* Non-adjacent & unequal size, area between must also be shifted. */
4705 modify_region (current_buffer
, start1
, end2
, 0);
4706 record_change (start1
, (end2
- start1
));
4707 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4708 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4709 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4711 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4712 if (!NULL_INTERVAL_P (tmp_interval3
))
4713 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4715 /* holds region 2 */
4716 SAFE_ALLOCA (temp
, unsigned char *, len2_byte
);
4717 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4718 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4719 memcpy (temp
, start2_addr
, len2_byte
);
4720 memcpy (start1_addr
+ len_mid
+ len2_byte
, start1_addr
, len1_byte
);
4721 memmove (start1_addr
+ len2_byte
, start1_addr
+ len1_byte
, len_mid
);
4722 memcpy (start1_addr
, temp
, len2_byte
);
4725 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4726 len1
, current_buffer
, 0);
4727 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4728 len_mid
, current_buffer
, 0);
4729 graft_intervals_into_buffer (tmp_interval2
, start1
,
4730 len2
, current_buffer
, 0);
4733 /* Second region smaller than first. */
4737 record_change (start1
, (end2
- start1
));
4738 modify_region (current_buffer
, start1
, end2
, 0);
4740 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4741 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4742 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4744 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4745 if (!NULL_INTERVAL_P (tmp_interval3
))
4746 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4748 /* holds region 1 */
4749 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4750 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4751 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4752 memcpy (temp
, start1_addr
, len1_byte
);
4753 memcpy (start1_addr
, start2_addr
, len2_byte
);
4754 memcpy (start1_addr
+ len2_byte
, start1_addr
+ len1_byte
, len_mid
);
4755 memcpy (start1_addr
+ len2_byte
+ len_mid
, temp
, len1_byte
);
4758 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4759 len1
, current_buffer
, 0);
4760 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4761 len_mid
, current_buffer
, 0);
4762 graft_intervals_into_buffer (tmp_interval2
, start1
,
4763 len2
, current_buffer
, 0);
4766 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4767 update_compositions (end2
- len1
, end2
, CHECK_BORDER
);
4770 /* When doing multiple transpositions, it might be nice
4771 to optimize this. Perhaps the markers in any one buffer
4772 should be organized in some sorted data tree. */
4773 if (NILP (leave_markers
))
4775 transpose_markers (start1
, end1
, start2
, end2
,
4776 start1_byte
, start1_byte
+ len1_byte
,
4777 start2_byte
, start2_byte
+ len2_byte
);
4778 fix_start_end_in_overlays (start1
, end2
);
4781 signal_after_change (start1
, end2
- start1
, end2
- start1
);
4787 syms_of_editfns (void)
4792 DEFSYM (Qbuffer_access_fontify_functions
, "buffer-access-fontify-functions");
4794 DEFVAR_LISP ("inhibit-field-text-motion", Vinhibit_field_text_motion
,
4795 doc
: /* Non-nil means text motion commands don't notice fields. */);
4796 Vinhibit_field_text_motion
= Qnil
;
4798 DEFVAR_LISP ("buffer-access-fontify-functions",
4799 Vbuffer_access_fontify_functions
,
4800 doc
: /* List of functions called by `buffer-substring' to fontify if necessary.
4801 Each function is called with two arguments which specify the range
4802 of the buffer being accessed. */);
4803 Vbuffer_access_fontify_functions
= Qnil
;
4807 obuf
= Fcurrent_buffer ();
4808 /* Do this here, because init_buffer_once is too early--it won't work. */
4809 Fset_buffer (Vprin1_to_string_buffer
);
4810 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
4811 Fset (Fmake_local_variable (intern_c_string ("buffer-access-fontify-functions")),
4816 DEFVAR_LISP ("buffer-access-fontified-property",
4817 Vbuffer_access_fontified_property
,
4818 doc
: /* Property which (if non-nil) indicates text has been fontified.
4819 `buffer-substring' need not call the `buffer-access-fontify-functions'
4820 functions if all the text being accessed has this property. */);
4821 Vbuffer_access_fontified_property
= Qnil
;
4823 DEFVAR_LISP ("system-name", Vsystem_name
,
4824 doc
: /* The host name of the machine Emacs is running on. */);
4826 DEFVAR_LISP ("user-full-name", Vuser_full_name
,
4827 doc
: /* The full name of the user logged in. */);
4829 DEFVAR_LISP ("user-login-name", Vuser_login_name
,
4830 doc
: /* The user's name, taken from environment variables if possible. */);
4832 DEFVAR_LISP ("user-real-login-name", Vuser_real_login_name
,
4833 doc
: /* The user's name, based upon the real uid only. */);
4835 DEFVAR_LISP ("operating-system-release", Voperating_system_release
,
4836 doc
: /* The release of the operating system Emacs is running on. */);
4838 defsubr (&Spropertize
);
4839 defsubr (&Schar_equal
);
4840 defsubr (&Sgoto_char
);
4841 defsubr (&Sstring_to_char
);
4842 defsubr (&Schar_to_string
);
4843 defsubr (&Sbyte_to_string
);
4844 defsubr (&Sbuffer_substring
);
4845 defsubr (&Sbuffer_substring_no_properties
);
4846 defsubr (&Sbuffer_string
);
4848 defsubr (&Spoint_marker
);
4849 defsubr (&Smark_marker
);
4851 defsubr (&Sregion_beginning
);
4852 defsubr (&Sregion_end
);
4854 DEFSYM (Qfield
, "field");
4855 DEFSYM (Qboundary
, "boundary");
4856 defsubr (&Sfield_beginning
);
4857 defsubr (&Sfield_end
);
4858 defsubr (&Sfield_string
);
4859 defsubr (&Sfield_string_no_properties
);
4860 defsubr (&Sdelete_field
);
4861 defsubr (&Sconstrain_to_field
);
4863 defsubr (&Sline_beginning_position
);
4864 defsubr (&Sline_end_position
);
4866 /* defsubr (&Smark); */
4867 /* defsubr (&Sset_mark); */
4868 defsubr (&Ssave_excursion
);
4869 defsubr (&Ssave_current_buffer
);
4871 defsubr (&Sbufsize
);
4872 defsubr (&Spoint_max
);
4873 defsubr (&Spoint_min
);
4874 defsubr (&Spoint_min_marker
);
4875 defsubr (&Spoint_max_marker
);
4876 defsubr (&Sgap_position
);
4877 defsubr (&Sgap_size
);
4878 defsubr (&Sposition_bytes
);
4879 defsubr (&Sbyte_to_position
);
4885 defsubr (&Sfollowing_char
);
4886 defsubr (&Sprevious_char
);
4887 defsubr (&Schar_after
);
4888 defsubr (&Schar_before
);
4890 defsubr (&Sinsert_before_markers
);
4891 defsubr (&Sinsert_and_inherit
);
4892 defsubr (&Sinsert_and_inherit_before_markers
);
4893 defsubr (&Sinsert_char
);
4894 defsubr (&Sinsert_byte
);
4896 defsubr (&Suser_login_name
);
4897 defsubr (&Suser_real_login_name
);
4898 defsubr (&Suser_uid
);
4899 defsubr (&Suser_real_uid
);
4900 defsubr (&Suser_full_name
);
4901 defsubr (&Semacs_pid
);
4902 defsubr (&Scurrent_time
);
4903 defsubr (&Sget_internal_run_time
);
4904 defsubr (&Sformat_time_string
);
4905 defsubr (&Sfloat_time
);
4906 defsubr (&Sdecode_time
);
4907 defsubr (&Sencode_time
);
4908 defsubr (&Scurrent_time_string
);
4909 defsubr (&Scurrent_time_zone
);
4910 defsubr (&Sset_time_zone_rule
);
4911 defsubr (&Ssystem_name
);
4912 defsubr (&Smessage
);
4913 defsubr (&Smessage_box
);
4914 defsubr (&Smessage_or_box
);
4915 defsubr (&Scurrent_message
);
4918 defsubr (&Sinsert_buffer_substring
);
4919 defsubr (&Scompare_buffer_substrings
);
4920 defsubr (&Ssubst_char_in_region
);
4921 defsubr (&Stranslate_region_internal
);
4922 defsubr (&Sdelete_region
);
4923 defsubr (&Sdelete_and_extract_region
);
4925 defsubr (&Snarrow_to_region
);
4926 defsubr (&Ssave_restriction
);
4927 defsubr (&Stranspose_regions
);