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. */)
1411 return make_lisp_time (current_emacs_time ());
1414 DEFUN ("get-internal-run-time", Fget_internal_run_time
, Sget_internal_run_time
,
1416 doc
: /* Return the current run time used by Emacs.
1417 The time is returned as a list (HIGH LOW USEC PSEC), using the same
1418 style as (current-time).
1420 On systems that can't determine the run time, `get-internal-run-time'
1421 does the same thing as `current-time'. */)
1424 #ifdef HAVE_GETRUSAGE
1425 struct rusage usage
;
1429 if (getrusage (RUSAGE_SELF
, &usage
) < 0)
1430 /* This shouldn't happen. What action is appropriate? */
1433 /* Sum up user time and system time. */
1434 secs
= usage
.ru_utime
.tv_sec
+ usage
.ru_stime
.tv_sec
;
1435 usecs
= usage
.ru_utime
.tv_usec
+ usage
.ru_stime
.tv_usec
;
1436 if (usecs
>= 1000000)
1441 return make_lisp_time (make_emacs_time (secs
, usecs
* 1000));
1442 #else /* ! HAVE_GETRUSAGE */
1444 return w32_get_internal_run_time ();
1445 #else /* ! WINDOWSNT */
1446 return Fcurrent_time ();
1447 #endif /* WINDOWSNT */
1448 #endif /* HAVE_GETRUSAGE */
1452 /* Make a Lisp list that represents the time T with fraction TAIL. */
1454 make_time_tail (time_t t
, Lisp_Object tail
)
1456 return Fcons (make_number (hi_time (t
)),
1457 Fcons (make_number (lo_time (t
)), tail
));
1460 /* Make a Lisp list that represents the system time T. */
1462 make_time (time_t t
)
1464 return make_time_tail (t
, Qnil
);
1467 /* Make a Lisp list that represents the Emacs time T. T may be an
1468 invalid time, with a slightly negative tv_nsec value such as
1469 UNKNOWN_MODTIME_NSECS; in that case, the Lisp list contains a
1470 correspondingly negative picosecond count. */
1472 make_lisp_time (EMACS_TIME t
)
1474 int ns
= EMACS_NSECS (t
);
1475 return make_time_tail (EMACS_SECS (t
),
1476 list2 (make_number (ns
/ 1000),
1477 make_number (ns
% 1000 * 1000)));
1480 /* Decode a Lisp list SPECIFIED_TIME that represents a time.
1481 Set *PHIGH, *PLOW, *PUSEC, *PPSEC to its parts; do not check their values.
1482 Return nonzero if successful. */
1484 disassemble_lisp_time (Lisp_Object specified_time
, Lisp_Object
*phigh
,
1485 Lisp_Object
*plow
, Lisp_Object
*pusec
,
1488 if (CONSP (specified_time
))
1490 Lisp_Object low
= XCDR (specified_time
);
1491 Lisp_Object usec
= make_number (0);
1492 Lisp_Object psec
= make_number (0);
1495 Lisp_Object low_tail
= XCDR (low
);
1497 if (CONSP (low_tail
))
1499 usec
= XCAR (low_tail
);
1500 low_tail
= XCDR (low_tail
);
1501 if (CONSP (low_tail
))
1502 psec
= XCAR (low_tail
);
1504 else if (!NILP (low_tail
))
1508 *phigh
= XCAR (specified_time
);
1518 /* From the time components HIGH, LOW, USEC and PSEC taken from a Lisp
1519 list, generate the corresponding time value.
1521 If RESULT is not null, store into *RESULT the converted time;
1522 this can fail if the converted time does not fit into EMACS_TIME.
1523 If *DRESULT is not null, store into *DRESULT the number of
1524 seconds since the start of the POSIX Epoch.
1526 Return nonzero if successful. */
1528 decode_time_components (Lisp_Object high
, Lisp_Object low
, Lisp_Object usec
,
1530 EMACS_TIME
*result
, double *dresult
)
1532 EMACS_INT hi
, lo
, us
, ps
;
1533 if (! (INTEGERP (high
) && INTEGERP (low
)
1534 && INTEGERP (usec
) && INTEGERP (psec
)))
1541 /* Normalize out-of-range lower-order components by carrying
1542 each overflow into the next higher-order component. */
1543 us
+= ps
/ 1000000 - (ps
% 1000000 < 0);
1544 lo
+= us
/ 1000000 - (us
% 1000000 < 0);
1546 ps
= ps
% 1000000 + 1000000 * (ps
% 1000000 < 0);
1547 us
= us
% 1000000 + 1000000 * (us
% 1000000 < 0);
1548 lo
&= (1 << 16) - 1;
1552 if ((TYPE_SIGNED (time_t) ? TIME_T_MIN
>> 16 <= hi
: 0 <= hi
)
1553 && hi
<= TIME_T_MAX
>> 16)
1555 /* Return the greatest representable time that is not greater
1556 than the requested time. */
1558 *result
= make_emacs_time ((sec
<< 16) + lo
, us
* 1000 + ps
/ 1000);
1562 /* Overflow in the highest-order component. */
1568 *dresult
= (us
* 1e6
+ ps
) / 1e12
+ lo
+ hi
* 65536.0;
1573 /* Decode a Lisp list SPECIFIED_TIME that represents a time.
1574 If SPECIFIED_TIME is nil, use the current time.
1576 Round the time down to the nearest EMACS_TIME value.
1577 Return seconds since the Epoch.
1578 Signal an error if unsuccessful. */
1580 lisp_time_argument (Lisp_Object specified_time
)
1583 if (NILP (specified_time
))
1584 t
= current_emacs_time ();
1587 Lisp_Object high
, low
, usec
, psec
;
1588 if (! (disassemble_lisp_time (specified_time
, &high
, &low
, &usec
, &psec
)
1589 && decode_time_components (high
, low
, usec
, psec
, &t
, 0)))
1590 error ("Invalid time specification");
1595 /* Like lisp_time_argument, except decode only the seconds part,
1596 do not allow out-of-range time stamps, do not check the subseconds part,
1597 and always round down. */
1599 lisp_seconds_argument (Lisp_Object specified_time
)
1601 if (NILP (specified_time
))
1605 Lisp_Object high
, low
, usec
, psec
;
1607 if (! (disassemble_lisp_time (specified_time
, &high
, &low
, &usec
, &psec
)
1608 && decode_time_components (high
, low
, make_number (0),
1609 make_number (0), &t
, 0)))
1610 error ("Invalid time specification");
1611 return EMACS_SECS (t
);
1615 DEFUN ("float-time", Ffloat_time
, Sfloat_time
, 0, 1, 0,
1616 doc
: /* Return the current time, as a float number of seconds since the epoch.
1617 If SPECIFIED-TIME is given, it is the time to convert to float
1618 instead of the current time. The argument should have the form
1619 (HIGH LOW) or (HIGH LOW USEC) or (HIGH LOW USEC PSEC). Thus,
1620 you can use times from `current-time' and from `file-attributes'.
1621 SPECIFIED-TIME can also have the form (HIGH . LOW), but this is
1622 considered obsolete.
1624 WARNING: Since the result is floating point, it may not be exact.
1625 If precise time stamps are required, use either `current-time',
1626 or (if you need time as a string) `format-time-string'. */)
1627 (Lisp_Object specified_time
)
1630 if (NILP (specified_time
))
1632 EMACS_TIME now
= current_emacs_time ();
1633 t
= EMACS_SECS (now
) + EMACS_NSECS (now
) / 1e9
;
1637 Lisp_Object high
, low
, usec
, psec
;
1638 if (! (disassemble_lisp_time (specified_time
, &high
, &low
, &usec
, &psec
)
1639 && decode_time_components (high
, low
, usec
, psec
, 0, &t
)))
1640 error ("Invalid time specification");
1642 return make_float (t
);
1645 /* Write information into buffer S of size MAXSIZE, according to the
1646 FORMAT of length FORMAT_LEN, using time information taken from *TP.
1647 Default to Universal Time if UT is nonzero, local time otherwise.
1648 Use NS as the number of nanoseconds in the %N directive.
1649 Return the number of bytes written, not including the terminating
1650 '\0'. If S is NULL, nothing will be written anywhere; so to
1651 determine how many bytes would be written, use NULL for S and
1652 ((size_t) -1) for MAXSIZE.
1654 This function behaves like nstrftime, except it allows null
1655 bytes in FORMAT and it does not support nanoseconds. */
1657 emacs_nmemftime (char *s
, size_t maxsize
, const char *format
,
1658 size_t format_len
, const struct tm
*tp
, int ut
, int ns
)
1662 /* Loop through all the null-terminated strings in the format
1663 argument. Normally there's just one null-terminated string, but
1664 there can be arbitrarily many, concatenated together, if the
1665 format contains '\0' bytes. nstrftime stops at the first
1666 '\0' byte so we must invoke it separately for each such string. */
1675 result
= nstrftime (s
, maxsize
, format
, tp
, ut
, ns
);
1679 if (result
== 0 && s
[0] != '\0')
1684 maxsize
-= result
+ 1;
1686 len
= strlen (format
);
1687 if (len
== format_len
)
1691 format_len
-= len
+ 1;
1695 DEFUN ("format-time-string", Fformat_time_string
, Sformat_time_string
, 1, 3, 0,
1696 doc
: /* Use FORMAT-STRING to format the time TIME, or now if omitted.
1697 TIME is specified as (HIGH LOW USEC PSEC), as returned by
1698 `current-time' or `file-attributes'. The obsolete form (HIGH . LOW)
1699 is also still accepted.
1700 The third, optional, argument UNIVERSAL, if non-nil, means describe TIME
1701 as Universal Time; nil means describe TIME in the local time zone.
1702 The value is a copy of FORMAT-STRING, but with certain constructs replaced
1703 by text that describes the specified date and time in TIME:
1705 %Y is the year, %y within the century, %C the century.
1706 %G is the year corresponding to the ISO week, %g within the century.
1707 %m is the numeric month.
1708 %b and %h are the locale's abbreviated month name, %B the full name.
1709 %d is the day of the month, zero-padded, %e is blank-padded.
1710 %u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.
1711 %a is the locale's abbreviated name of the day of week, %A the full name.
1712 %U is the week number starting on Sunday, %W starting on Monday,
1713 %V according to ISO 8601.
1714 %j is the day of the year.
1716 %H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H
1717 only blank-padded, %l is like %I blank-padded.
1718 %p is the locale's equivalent of either AM or PM.
1721 %N is the nanosecond, %6N the microsecond, %3N the millisecond, etc.
1722 %Z is the time zone name, %z is the numeric form.
1723 %s is the number of seconds since 1970-01-01 00:00:00 +0000.
1725 %c is the locale's date and time format.
1726 %x is the locale's "preferred" date format.
1727 %D is like "%m/%d/%y".
1729 %R is like "%H:%M", %T is like "%H:%M:%S", %r is like "%I:%M:%S %p".
1730 %X is the locale's "preferred" time format.
1732 Finally, %n is a newline, %t is a tab, %% is a literal %.
1734 Certain flags and modifiers are available with some format controls.
1735 The flags are `_', `-', `^' and `#'. For certain characters X,
1736 %_X is like %X, but padded with blanks; %-X is like %X,
1737 but without padding. %^X is like %X, but with all textual
1738 characters up-cased; %#X is like %X, but with letter-case of
1739 all textual characters reversed.
1740 %NX (where N stands for an integer) is like %X,
1741 but takes up at least N (a number) positions.
1742 The modifiers are `E' and `O'. For certain characters X,
1743 %EX is a locale's alternative version of %X;
1744 %OX is like %X, but uses the locale's number symbols.
1746 For example, to produce full ISO 8601 format, use "%Y-%m-%dT%T%z".
1748 usage: (format-time-string FORMAT-STRING &optional TIME UNIVERSAL) */)
1749 (Lisp_Object format_string
, Lisp_Object timeval
, Lisp_Object universal
)
1751 EMACS_TIME t
= lisp_time_argument (timeval
);
1754 CHECK_STRING (format_string
);
1755 format_string
= code_convert_string_norecord (format_string
,
1756 Vlocale_coding_system
, 1);
1757 return format_time_string (SSDATA (format_string
), SBYTES (format_string
),
1758 t
, ! NILP (universal
), &tm
);
1762 format_time_string (char const *format
, ptrdiff_t formatlen
,
1763 EMACS_TIME t
, int ut
, struct tm
*tmp
)
1767 ptrdiff_t size
= sizeof buffer
;
1769 Lisp_Object bufstring
;
1770 int ns
= EMACS_NSECS (t
);
1776 time_t *taddr
= emacs_secs_addr (&t
);
1779 synchronize_system_time_locale ();
1781 tm
= ut
? gmtime (taddr
) : localtime (taddr
);
1790 len
= emacs_nmemftime (buf
, size
, format
, formatlen
, tm
, ut
, ns
);
1791 if ((0 < len
&& len
< size
) || (len
== 0 && buf
[0] == '\0'))
1794 /* Buffer was too small, so make it bigger and try again. */
1795 len
= emacs_nmemftime (NULL
, SIZE_MAX
, format
, formatlen
, tm
, ut
, ns
);
1797 if (STRING_BYTES_BOUND
<= len
)
1800 SAFE_ALLOCA (buf
, char *, size
);
1804 bufstring
= make_unibyte_string (buf
, len
);
1806 return code_convert_string_norecord (bufstring
, Vlocale_coding_system
, 0);
1809 DEFUN ("decode-time", Fdecode_time
, Sdecode_time
, 0, 1, 0,
1810 doc
: /* Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST ZONE).
1811 The optional SPECIFIED-TIME should be a list of (HIGH LOW . IGNORED),
1812 as from `current-time' and `file-attributes', or nil to use the
1813 current time. The obsolete form (HIGH . LOW) is also still accepted.
1814 The list has the following nine members: SEC is an integer between 0
1815 and 60; SEC is 60 for a leap second, which only some operating systems
1816 support. MINUTE is an integer between 0 and 59. HOUR is an integer
1817 between 0 and 23. DAY is an integer between 1 and 31. MONTH is an
1818 integer between 1 and 12. YEAR is an integer indicating the
1819 four-digit year. DOW is the day of week, an integer between 0 and 6,
1820 where 0 is Sunday. DST is t if daylight saving time is in effect,
1821 otherwise nil. ZONE is an integer indicating the number of seconds
1822 east of Greenwich. (Note that Common Lisp has different meanings for
1824 (Lisp_Object specified_time
)
1826 time_t time_spec
= lisp_seconds_argument (specified_time
);
1828 struct tm
*decoded_time
;
1829 Lisp_Object list_args
[9];
1832 decoded_time
= localtime (&time_spec
);
1834 save_tm
= *decoded_time
;
1837 && MOST_NEGATIVE_FIXNUM
- TM_YEAR_BASE
<= save_tm
.tm_year
1838 && save_tm
.tm_year
<= MOST_POSITIVE_FIXNUM
- TM_YEAR_BASE
))
1840 XSETFASTINT (list_args
[0], save_tm
.tm_sec
);
1841 XSETFASTINT (list_args
[1], save_tm
.tm_min
);
1842 XSETFASTINT (list_args
[2], save_tm
.tm_hour
);
1843 XSETFASTINT (list_args
[3], save_tm
.tm_mday
);
1844 XSETFASTINT (list_args
[4], save_tm
.tm_mon
+ 1);
1845 /* On 64-bit machines an int is narrower than EMACS_INT, thus the
1846 cast below avoids overflow in int arithmetics. */
1847 XSETINT (list_args
[5], TM_YEAR_BASE
+ (EMACS_INT
) save_tm
.tm_year
);
1848 XSETFASTINT (list_args
[6], save_tm
.tm_wday
);
1849 list_args
[7] = save_tm
.tm_isdst
? Qt
: Qnil
;
1852 decoded_time
= gmtime (&time_spec
);
1853 if (decoded_time
== 0)
1854 list_args
[8] = Qnil
;
1856 XSETINT (list_args
[8], tm_diff (&save_tm
, decoded_time
));
1858 return Flist (9, list_args
);
1861 /* Return OBJ - OFFSET, checking that OBJ is a valid fixnum and that
1862 the result is representable as an int. Assume OFFSET is small and
1865 check_tm_member (Lisp_Object obj
, int offset
)
1870 if (! (INT_MIN
+ offset
<= n
&& n
- offset
<= INT_MAX
))
1875 DEFUN ("encode-time", Fencode_time
, Sencode_time
, 6, MANY
, 0,
1876 doc
: /* Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.
1877 This is the reverse operation of `decode-time', which see.
1878 ZONE defaults to the current time zone rule. This can
1879 be a string or t (as from `set-time-zone-rule'), or it can be a list
1880 \(as from `current-time-zone') or an integer (as from `decode-time')
1881 applied without consideration for daylight saving time.
1883 You can pass more than 7 arguments; then the first six arguments
1884 are used as SECOND through YEAR, and the *last* argument is used as ZONE.
1885 The intervening arguments are ignored.
1886 This feature lets (apply 'encode-time (decode-time ...)) work.
1888 Out-of-range values for SECOND, MINUTE, HOUR, DAY, or MONTH are allowed;
1889 for example, a DAY of 0 means the day preceding the given month.
1890 Year numbers less than 100 are treated just like other year numbers.
1891 If you want them to stand for years in this century, you must do that yourself.
1893 Years before 1970 are not guaranteed to work. On some systems,
1894 year values as low as 1901 do work.
1896 usage: (encode-time SECOND MINUTE HOUR DAY MONTH YEAR &optional ZONE) */)
1897 (ptrdiff_t nargs
, Lisp_Object
*args
)
1901 Lisp_Object zone
= (nargs
> 6 ? args
[nargs
- 1] : Qnil
);
1903 tm
.tm_sec
= check_tm_member (args
[0], 0);
1904 tm
.tm_min
= check_tm_member (args
[1], 0);
1905 tm
.tm_hour
= check_tm_member (args
[2], 0);
1906 tm
.tm_mday
= check_tm_member (args
[3], 0);
1907 tm
.tm_mon
= check_tm_member (args
[4], 1);
1908 tm
.tm_year
= check_tm_member (args
[5], TM_YEAR_BASE
);
1916 value
= mktime (&tm
);
1922 const char *tzstring
;
1923 char **oldenv
= environ
, **newenv
;
1927 else if (STRINGP (zone
))
1928 tzstring
= SSDATA (zone
);
1929 else if (INTEGERP (zone
))
1931 EMACS_INT abszone
= eabs (XINT (zone
));
1932 EMACS_INT zone_hr
= abszone
/ (60*60);
1933 int zone_min
= (abszone
/60) % 60;
1934 int zone_sec
= abszone
% 60;
1935 sprintf (tzbuf
, "XXX%s%"pI
"d:%02d:%02d", "-" + (XINT (zone
) < 0),
1936 zone_hr
, zone_min
, zone_sec
);
1940 error ("Invalid time zone specification");
1944 /* Set TZ before calling mktime; merely adjusting mktime's returned
1945 value doesn't suffice, since that would mishandle leap seconds. */
1946 set_time_zone_rule (tzstring
);
1948 value
= mktime (&tm
);
1950 /* Restore TZ to previous value. */
1953 #ifdef LOCALTIME_CACHE
1961 if (value
== (time_t) -1)
1964 return make_time (value
);
1967 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
, 0, 1, 0,
1968 doc
: /* Return the current local time, as a human-readable string.
1969 Programs can use this function to decode a time,
1970 since the number of columns in each field is fixed
1971 if the year is in the range 1000-9999.
1972 The format is `Sun Sep 16 01:03:52 1973'.
1973 However, see also the functions `decode-time' and `format-time-string'
1974 which provide a much more powerful and general facility.
1976 If SPECIFIED-TIME is given, it is a time to format instead of the
1977 current time. The argument should have the form (HIGH LOW . IGNORED).
1978 Thus, you can use times obtained from `current-time' and from
1979 `file-attributes'. SPECIFIED-TIME can also have the form (HIGH . LOW),
1980 but this is considered obsolete. */)
1981 (Lisp_Object specified_time
)
1983 time_t value
= lisp_seconds_argument (specified_time
);
1985 char buf
[sizeof "Mon Apr 30 12:49:17 " + INT_STRLEN_BOUND (int) + 1];
1986 int len
IF_LINT (= 0);
1988 /* Convert to a string in ctime format, except without the trailing
1989 newline, and without the 4-digit year limit. Don't use asctime
1990 or ctime, as they might dump core if the year is outside the
1991 range -999 .. 9999. */
1993 tm
= localtime (&value
);
1996 static char const wday_name
[][4] =
1997 { "Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat" };
1998 static char const mon_name
[][4] =
1999 { "Jan", "Feb", "Mar", "Apr", "May", "Jun",
2000 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" };
2001 printmax_t year_base
= TM_YEAR_BASE
;
2003 len
= sprintf (buf
, "%s %s%3d %02d:%02d:%02d %"pMd
,
2004 wday_name
[tm
->tm_wday
], mon_name
[tm
->tm_mon
], tm
->tm_mday
,
2005 tm
->tm_hour
, tm
->tm_min
, tm
->tm_sec
,
2006 tm
->tm_year
+ year_base
);
2012 return make_unibyte_string (buf
, len
);
2015 /* Yield A - B, measured in seconds.
2016 This function is copied from the GNU C Library. */
2018 tm_diff (struct tm
*a
, struct tm
*b
)
2020 /* Compute intervening leap days correctly even if year is negative.
2021 Take care to avoid int overflow in leap day calculations,
2022 but it's OK to assume that A and B are close to each other. */
2023 int a4
= (a
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (a
->tm_year
& 3);
2024 int b4
= (b
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (b
->tm_year
& 3);
2025 int a100
= a4
/ 25 - (a4
% 25 < 0);
2026 int b100
= b4
/ 25 - (b4
% 25 < 0);
2027 int a400
= a100
>> 2;
2028 int b400
= b100
>> 2;
2029 int intervening_leap_days
= (a4
- b4
) - (a100
- b100
) + (a400
- b400
);
2030 int years
= a
->tm_year
- b
->tm_year
;
2031 int days
= (365 * years
+ intervening_leap_days
2032 + (a
->tm_yday
- b
->tm_yday
));
2033 return (60 * (60 * (24 * days
+ (a
->tm_hour
- b
->tm_hour
))
2034 + (a
->tm_min
- b
->tm_min
))
2035 + (a
->tm_sec
- b
->tm_sec
));
2038 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 1, 0,
2039 doc
: /* Return the offset and name for the local time zone.
2040 This returns a list of the form (OFFSET NAME).
2041 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).
2042 A negative value means west of Greenwich.
2043 NAME is a string giving the name of the time zone.
2044 If SPECIFIED-TIME is given, the time zone offset is determined from it
2045 instead of using the current time. The argument should have the form
2046 (HIGH LOW . IGNORED). Thus, you can use times obtained from
2047 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
2048 have the form (HIGH . LOW), but this is considered obsolete.
2050 Some operating systems cannot provide all this information to Emacs;
2051 in this case, `current-time-zone' returns a list containing nil for
2052 the data it can't find. */)
2053 (Lisp_Object specified_time
)
2059 Lisp_Object zone_offset
, zone_name
;
2062 value
= make_emacs_time (lisp_seconds_argument (specified_time
), 0);
2063 zone_name
= format_time_string ("%Z", sizeof "%Z" - 1, value
, 0, &localtm
);
2065 t
= gmtime (emacs_secs_addr (&value
));
2067 offset
= tm_diff (&localtm
, t
);
2072 zone_offset
= make_number (offset
);
2073 if (SCHARS (zone_name
) == 0)
2075 /* No local time zone name is available; use "+-NNNN" instead. */
2076 int m
= offset
/ 60;
2077 int am
= offset
< 0 ? - m
: m
;
2078 char buf
[sizeof "+00" + INT_STRLEN_BOUND (int)];
2079 zone_name
= make_formatted_string (buf
, "%c%02d%02d",
2080 (offset
< 0 ? '-' : '+'),
2085 return list2 (zone_offset
, zone_name
);
2088 /* This holds the value of `environ' produced by the previous
2089 call to Fset_time_zone_rule, or 0 if Fset_time_zone_rule
2090 has never been called. */
2091 static char **environbuf
;
2093 /* This holds the startup value of the TZ environment variable so it
2094 can be restored if the user calls set-time-zone-rule with a nil
2096 static char *initial_tz
;
2098 DEFUN ("set-time-zone-rule", Fset_time_zone_rule
, Sset_time_zone_rule
, 1, 1, 0,
2099 doc
: /* Set the local time zone using TZ, a string specifying a time zone rule.
2100 If TZ is nil, use implementation-defined default time zone information.
2101 If TZ is t, use Universal Time.
2103 Instead of calling this function, you typically want (setenv "TZ" TZ).
2104 That changes both the environment of the Emacs process and the
2105 variable `process-environment', whereas `set-time-zone-rule' affects
2106 only the former. */)
2109 const char *tzstring
;
2110 char **old_environbuf
;
2112 if (! (NILP (tz
) || EQ (tz
, Qt
)))
2117 /* When called for the first time, save the original TZ. */
2118 old_environbuf
= environbuf
;
2119 if (!old_environbuf
)
2120 initial_tz
= (char *) getenv ("TZ");
2123 tzstring
= initial_tz
;
2124 else if (EQ (tz
, Qt
))
2127 tzstring
= SSDATA (tz
);
2129 set_time_zone_rule (tzstring
);
2130 environbuf
= environ
;
2134 xfree (old_environbuf
);
2138 #ifdef LOCALTIME_CACHE
2140 /* These two values are known to load tz files in buggy implementations,
2141 i.e. Solaris 1 executables running under either Solaris 1 or Solaris 2.
2142 Their values shouldn't matter in non-buggy implementations.
2143 We don't use string literals for these strings,
2144 since if a string in the environment is in readonly
2145 storage, it runs afoul of bugs in SVR4 and Solaris 2.3.
2146 See Sun bugs 1113095 and 1114114, ``Timezone routines
2147 improperly modify environment''. */
2149 static char set_time_zone_rule_tz1
[] = "TZ=GMT+0";
2150 static char set_time_zone_rule_tz2
[] = "TZ=GMT+1";
2154 /* Set the local time zone rule to TZSTRING.
2155 This allocates memory into `environ', which it is the caller's
2156 responsibility to free. */
2159 set_time_zone_rule (const char *tzstring
)
2162 char **from
, **to
, **newenv
;
2164 /* Make the ENVIRON vector longer with room for TZSTRING. */
2165 for (from
= environ
; *from
; from
++)
2167 envptrs
= from
- environ
+ 2;
2168 newenv
= to
= xmalloc (envptrs
* sizeof *newenv
2169 + (tzstring
? strlen (tzstring
) + 4 : 0));
2171 /* Add TZSTRING to the end of environ, as a value for TZ. */
2174 char *t
= (char *) (to
+ envptrs
);
2176 strcat (t
, tzstring
);
2180 /* Copy the old environ vector elements into NEWENV,
2181 but don't copy the TZ variable.
2182 So we have only one definition of TZ, which came from TZSTRING. */
2183 for (from
= environ
; *from
; from
++)
2184 if (strncmp (*from
, "TZ=", 3) != 0)
2190 /* If we do have a TZSTRING, NEWENV points to the vector slot where
2191 the TZ variable is stored. If we do not have a TZSTRING,
2192 TO points to the vector slot which has the terminating null. */
2194 #ifdef LOCALTIME_CACHE
2196 /* In SunOS 4.1.3_U1 and 4.1.4, if TZ has a value like
2197 "US/Pacific" that loads a tz file, then changes to a value like
2198 "XXX0" that does not load a tz file, and then changes back to
2199 its original value, the last change is (incorrectly) ignored.
2200 Also, if TZ changes twice in succession to values that do
2201 not load a tz file, tzset can dump core (see Sun bug#1225179).
2202 The following code works around these bugs. */
2206 /* Temporarily set TZ to a value that loads a tz file
2207 and that differs from tzstring. */
2209 *newenv
= (strcmp (tzstring
, set_time_zone_rule_tz1
+ 3) == 0
2210 ? set_time_zone_rule_tz2
: set_time_zone_rule_tz1
);
2216 /* The implied tzstring is unknown, so temporarily set TZ to
2217 two different values that each load a tz file. */
2218 *to
= set_time_zone_rule_tz1
;
2221 *to
= set_time_zone_rule_tz2
;
2226 /* Now TZ has the desired value, and tzset can be invoked safely. */
2233 /* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC
2234 (if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a
2235 type of object is Lisp_String). INHERIT is passed to
2236 INSERT_FROM_STRING_FUNC as the last argument. */
2239 general_insert_function (void (*insert_func
)
2240 (const char *, ptrdiff_t),
2241 void (*insert_from_string_func
)
2242 (Lisp_Object
, ptrdiff_t, ptrdiff_t,
2243 ptrdiff_t, ptrdiff_t, int),
2244 int inherit
, ptrdiff_t nargs
, Lisp_Object
*args
)
2247 register Lisp_Object val
;
2249 for (argnum
= 0; argnum
< nargs
; argnum
++)
2252 if (CHARACTERP (val
))
2254 int c
= XFASTINT (val
);
2255 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2258 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2259 len
= CHAR_STRING (c
, str
);
2262 str
[0] = ASCII_CHAR_P (c
) ? c
: multibyte_char_to_unibyte (c
);
2265 (*insert_func
) ((char *) str
, len
);
2267 else if (STRINGP (val
))
2269 (*insert_from_string_func
) (val
, 0, 0,
2275 wrong_type_argument (Qchar_or_string_p
, val
);
2280 insert1 (Lisp_Object arg
)
2286 /* Callers passing one argument to Finsert need not gcpro the
2287 argument "array", since the only element of the array will
2288 not be used after calling insert or insert_from_string, so
2289 we don't care if it gets trashed. */
2291 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
2292 doc
: /* Insert the arguments, either strings or characters, at point.
2293 Point and before-insertion markers move forward to end up
2294 after the inserted text.
2295 Any other markers at the point of insertion remain before the text.
2297 If the current buffer is multibyte, unibyte strings are converted
2298 to multibyte for insertion (see `string-make-multibyte').
2299 If the current buffer is unibyte, multibyte strings are converted
2300 to unibyte for insertion (see `string-make-unibyte').
2302 When operating on binary data, it may be necessary to preserve the
2303 original bytes of a unibyte string when inserting it into a multibyte
2304 buffer; to accomplish this, apply `string-as-multibyte' to the string
2305 and insert the result.
2307 usage: (insert &rest ARGS) */)
2308 (ptrdiff_t nargs
, Lisp_Object
*args
)
2310 general_insert_function (insert
, insert_from_string
, 0, nargs
, args
);
2314 DEFUN ("insert-and-inherit", Finsert_and_inherit
, Sinsert_and_inherit
,
2316 doc
: /* Insert the arguments at point, inheriting properties from adjoining text.
2317 Point and before-insertion markers move forward to end up
2318 after the inserted text.
2319 Any other markers at the point of insertion remain before the text.
2321 If the current buffer is multibyte, unibyte strings are converted
2322 to multibyte for insertion (see `unibyte-char-to-multibyte').
2323 If the current buffer is unibyte, multibyte strings are converted
2324 to unibyte for insertion.
2326 usage: (insert-and-inherit &rest ARGS) */)
2327 (ptrdiff_t nargs
, Lisp_Object
*args
)
2329 general_insert_function (insert_and_inherit
, insert_from_string
, 1,
2334 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
2335 doc
: /* Insert strings or characters at point, relocating markers after the text.
2336 Point and markers move forward to end up after the inserted text.
2338 If the current buffer is multibyte, unibyte strings are converted
2339 to multibyte for insertion (see `unibyte-char-to-multibyte').
2340 If the current buffer is unibyte, multibyte strings are converted
2341 to unibyte for insertion.
2343 usage: (insert-before-markers &rest ARGS) */)
2344 (ptrdiff_t nargs
, Lisp_Object
*args
)
2346 general_insert_function (insert_before_markers
,
2347 insert_from_string_before_markers
, 0,
2352 DEFUN ("insert-before-markers-and-inherit", Finsert_and_inherit_before_markers
,
2353 Sinsert_and_inherit_before_markers
, 0, MANY
, 0,
2354 doc
: /* Insert text at point, relocating markers and inheriting properties.
2355 Point and markers move forward to end up after the inserted text.
2357 If the current buffer is multibyte, unibyte strings are converted
2358 to multibyte for insertion (see `unibyte-char-to-multibyte').
2359 If the current buffer is unibyte, multibyte strings are converted
2360 to unibyte for insertion.
2362 usage: (insert-before-markers-and-inherit &rest ARGS) */)
2363 (ptrdiff_t nargs
, Lisp_Object
*args
)
2365 general_insert_function (insert_before_markers_and_inherit
,
2366 insert_from_string_before_markers
, 1,
2371 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 1, 3,
2372 "(list (read-char-by-name \"Unicode (name or hex): \")\
2373 (prefix-numeric-value current-prefix-arg)\
2375 doc
: /* Insert COUNT copies of CHARACTER.
2376 Interactively, prompts for a Unicode character name or a hex number
2377 using `read-char-by-name'.
2379 You can type a few of the first letters of the Unicode name and
2380 use completion. If you type a substring of the Unicode name
2381 preceded by an asterisk `*' and use completion, it will show all
2382 the characters whose names include that substring, not necessarily
2383 at the beginning of the name.
2385 This function also accepts a hexadecimal number of Unicode code
2386 point or a number in hash notation, e.g. #o21430 for octal,
2387 #x2318 for hex, or #10r8984 for decimal.
2389 Point, and before-insertion markers, are relocated as in the function `insert'.
2390 The optional third arg INHERIT, if non-nil, says to inherit text properties
2391 from adjoining text, if those properties are sticky. If called
2392 interactively, INHERIT is t. */)
2393 (Lisp_Object character
, Lisp_Object count
, Lisp_Object inherit
)
2396 register ptrdiff_t n
;
2398 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2401 CHECK_CHARACTER (character
);
2403 XSETFASTINT (count
, 1);
2404 CHECK_NUMBER (count
);
2405 c
= XFASTINT (character
);
2407 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2408 len
= CHAR_STRING (c
, str
);
2410 str
[0] = c
, len
= 1;
2411 if (XINT (count
) <= 0)
2413 if (BUF_BYTES_MAX
/ len
< XINT (count
))
2415 n
= XINT (count
) * len
;
2416 stringlen
= min (n
, sizeof string
- sizeof string
% len
);
2417 for (i
= 0; i
< stringlen
; i
++)
2418 string
[i
] = str
[i
% len
];
2419 while (n
> stringlen
)
2422 if (!NILP (inherit
))
2423 insert_and_inherit (string
, stringlen
);
2425 insert (string
, stringlen
);
2428 if (!NILP (inherit
))
2429 insert_and_inherit (string
, n
);
2435 DEFUN ("insert-byte", Finsert_byte
, Sinsert_byte
, 2, 3, 0,
2436 doc
: /* Insert COUNT (second arg) copies of BYTE (first arg).
2437 Both arguments are required.
2438 BYTE is a number of the range 0..255.
2440 If BYTE is 128..255 and the current buffer is multibyte, the
2441 corresponding eight-bit character is inserted.
2443 Point, and before-insertion markers, are relocated as in the function `insert'.
2444 The optional third arg INHERIT, if non-nil, says to inherit text properties
2445 from adjoining text, if those properties are sticky. */)
2446 (Lisp_Object byte
, Lisp_Object count
, Lisp_Object inherit
)
2448 CHECK_NUMBER (byte
);
2449 if (XINT (byte
) < 0 || XINT (byte
) > 255)
2450 args_out_of_range_3 (byte
, make_number (0), make_number (255));
2451 if (XINT (byte
) >= 128
2452 && ! NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2453 XSETFASTINT (byte
, BYTE8_TO_CHAR (XINT (byte
)));
2454 return Finsert_char (byte
, count
, inherit
);
2458 /* Making strings from buffer contents. */
2460 /* Return a Lisp_String containing the text of the current buffer from
2461 START to END. If text properties are in use and the current buffer
2462 has properties in the range specified, the resulting string will also
2463 have them, if PROPS is nonzero.
2465 We don't want to use plain old make_string here, because it calls
2466 make_uninit_string, which can cause the buffer arena to be
2467 compacted. make_string has no way of knowing that the data has
2468 been moved, and thus copies the wrong data into the string. This
2469 doesn't effect most of the other users of make_string, so it should
2470 be left as is. But we should use this function when conjuring
2471 buffer substrings. */
2474 make_buffer_string (ptrdiff_t start
, ptrdiff_t end
, int props
)
2476 ptrdiff_t start_byte
= CHAR_TO_BYTE (start
);
2477 ptrdiff_t end_byte
= CHAR_TO_BYTE (end
);
2479 return make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
);
2482 /* Return a Lisp_String containing the text of the current buffer from
2483 START / START_BYTE to END / END_BYTE.
2485 If text properties are in use and the current buffer
2486 has properties in the range specified, the resulting string will also
2487 have them, if PROPS is nonzero.
2489 We don't want to use plain old make_string here, because it calls
2490 make_uninit_string, which can cause the buffer arena to be
2491 compacted. make_string has no way of knowing that the data has
2492 been moved, and thus copies the wrong data into the string. This
2493 doesn't effect most of the other users of make_string, so it should
2494 be left as is. But we should use this function when conjuring
2495 buffer substrings. */
2498 make_buffer_string_both (ptrdiff_t start
, ptrdiff_t start_byte
,
2499 ptrdiff_t end
, ptrdiff_t end_byte
, int props
)
2501 Lisp_Object result
, tem
, tem1
;
2503 if (start
< GPT
&& GPT
< end
)
2506 if (! NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2507 result
= make_uninit_multibyte_string (end
- start
, end_byte
- start_byte
);
2509 result
= make_uninit_string (end
- start
);
2510 memcpy (SDATA (result
), BYTE_POS_ADDR (start_byte
), end_byte
- start_byte
);
2512 /* If desired, update and copy the text properties. */
2515 update_buffer_properties (start
, end
);
2517 tem
= Fnext_property_change (make_number (start
), Qnil
, make_number (end
));
2518 tem1
= Ftext_properties_at (make_number (start
), Qnil
);
2520 if (XINT (tem
) != end
|| !NILP (tem1
))
2521 copy_intervals_to_string (result
, current_buffer
, start
,
2528 /* Call Vbuffer_access_fontify_functions for the range START ... END
2529 in the current buffer, if necessary. */
2532 update_buffer_properties (ptrdiff_t start
, ptrdiff_t end
)
2534 /* If this buffer has some access functions,
2535 call them, specifying the range of the buffer being accessed. */
2536 if (!NILP (Vbuffer_access_fontify_functions
))
2538 Lisp_Object args
[3];
2541 args
[0] = Qbuffer_access_fontify_functions
;
2542 XSETINT (args
[1], start
);
2543 XSETINT (args
[2], end
);
2545 /* But don't call them if we can tell that the work
2546 has already been done. */
2547 if (!NILP (Vbuffer_access_fontified_property
))
2549 tem
= Ftext_property_any (args
[1], args
[2],
2550 Vbuffer_access_fontified_property
,
2553 Frun_hook_with_args (3, args
);
2556 Frun_hook_with_args (3, args
);
2560 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
2561 doc
: /* Return the contents of part of the current buffer as a string.
2562 The two arguments START and END are character positions;
2563 they can be in either order.
2564 The string returned is multibyte if the buffer is multibyte.
2566 This function copies the text properties of that part of the buffer
2567 into the result string; if you don't want the text properties,
2568 use `buffer-substring-no-properties' instead. */)
2569 (Lisp_Object start
, Lisp_Object end
)
2571 register ptrdiff_t b
, e
;
2573 validate_region (&start
, &end
);
2577 return make_buffer_string (b
, e
, 1);
2580 DEFUN ("buffer-substring-no-properties", Fbuffer_substring_no_properties
,
2581 Sbuffer_substring_no_properties
, 2, 2, 0,
2582 doc
: /* Return the characters of part of the buffer, without the text properties.
2583 The two arguments START and END are character positions;
2584 they can be in either order. */)
2585 (Lisp_Object start
, Lisp_Object end
)
2587 register ptrdiff_t b
, e
;
2589 validate_region (&start
, &end
);
2593 return make_buffer_string (b
, e
, 0);
2596 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
2597 doc
: /* Return the contents of the current buffer as a string.
2598 If narrowing is in effect, this function returns only the visible part
2602 return make_buffer_string (BEGV
, ZV
, 1);
2605 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
2607 doc
: /* Insert before point a substring of the contents of BUFFER.
2608 BUFFER may be a buffer or a buffer name.
2609 Arguments START and END are character positions specifying the substring.
2610 They default to the values of (point-min) and (point-max) in BUFFER. */)
2611 (Lisp_Object buffer
, Lisp_Object start
, Lisp_Object end
)
2613 register EMACS_INT b
, e
, temp
;
2614 register struct buffer
*bp
, *obuf
;
2617 buf
= Fget_buffer (buffer
);
2621 if (NILP (BVAR (bp
, name
)))
2622 error ("Selecting deleted buffer");
2628 CHECK_NUMBER_COERCE_MARKER (start
);
2635 CHECK_NUMBER_COERCE_MARKER (end
);
2640 temp
= b
, b
= e
, e
= temp
;
2642 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
2643 args_out_of_range (start
, end
);
2645 obuf
= current_buffer
;
2646 set_buffer_internal_1 (bp
);
2647 update_buffer_properties (b
, e
);
2648 set_buffer_internal_1 (obuf
);
2650 insert_from_buffer (bp
, b
, e
- b
, 0);
2654 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
2656 doc
: /* Compare two substrings of two buffers; return result as number.
2657 the value is -N if first string is less after N-1 chars,
2658 +N if first string is greater after N-1 chars, or 0 if strings match.
2659 Each substring is represented as three arguments: BUFFER, START and END.
2660 That makes six args in all, three for each substring.
2662 The value of `case-fold-search' in the current buffer
2663 determines whether case is significant or ignored. */)
2664 (Lisp_Object buffer1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object buffer2
, Lisp_Object start2
, Lisp_Object end2
)
2666 register EMACS_INT begp1
, endp1
, begp2
, endp2
, temp
;
2667 register struct buffer
*bp1
, *bp2
;
2668 register Lisp_Object trt
2669 = (!NILP (BVAR (current_buffer
, case_fold_search
))
2670 ? BVAR (current_buffer
, case_canon_table
) : Qnil
);
2671 ptrdiff_t chars
= 0;
2672 ptrdiff_t i1
, i2
, i1_byte
, i2_byte
;
2674 /* Find the first buffer and its substring. */
2677 bp1
= current_buffer
;
2681 buf1
= Fget_buffer (buffer1
);
2684 bp1
= XBUFFER (buf1
);
2685 if (NILP (BVAR (bp1
, name
)))
2686 error ("Selecting deleted buffer");
2690 begp1
= BUF_BEGV (bp1
);
2693 CHECK_NUMBER_COERCE_MARKER (start1
);
2694 begp1
= XINT (start1
);
2697 endp1
= BUF_ZV (bp1
);
2700 CHECK_NUMBER_COERCE_MARKER (end1
);
2701 endp1
= XINT (end1
);
2705 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
2707 if (!(BUF_BEGV (bp1
) <= begp1
2709 && endp1
<= BUF_ZV (bp1
)))
2710 args_out_of_range (start1
, end1
);
2712 /* Likewise for second substring. */
2715 bp2
= current_buffer
;
2719 buf2
= Fget_buffer (buffer2
);
2722 bp2
= XBUFFER (buf2
);
2723 if (NILP (BVAR (bp2
, name
)))
2724 error ("Selecting deleted buffer");
2728 begp2
= BUF_BEGV (bp2
);
2731 CHECK_NUMBER_COERCE_MARKER (start2
);
2732 begp2
= XINT (start2
);
2735 endp2
= BUF_ZV (bp2
);
2738 CHECK_NUMBER_COERCE_MARKER (end2
);
2739 endp2
= XINT (end2
);
2743 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
2745 if (!(BUF_BEGV (bp2
) <= begp2
2747 && endp2
<= BUF_ZV (bp2
)))
2748 args_out_of_range (start2
, end2
);
2752 i1_byte
= buf_charpos_to_bytepos (bp1
, i1
);
2753 i2_byte
= buf_charpos_to_bytepos (bp2
, i2
);
2755 while (i1
< endp1
&& i2
< endp2
)
2757 /* When we find a mismatch, we must compare the
2758 characters, not just the bytes. */
2763 if (! NILP (BVAR (bp1
, enable_multibyte_characters
)))
2765 c1
= BUF_FETCH_MULTIBYTE_CHAR (bp1
, i1_byte
);
2766 BUF_INC_POS (bp1
, i1_byte
);
2771 c1
= BUF_FETCH_BYTE (bp1
, i1
);
2772 MAKE_CHAR_MULTIBYTE (c1
);
2776 if (! NILP (BVAR (bp2
, enable_multibyte_characters
)))
2778 c2
= BUF_FETCH_MULTIBYTE_CHAR (bp2
, i2_byte
);
2779 BUF_INC_POS (bp2
, i2_byte
);
2784 c2
= BUF_FETCH_BYTE (bp2
, i2
);
2785 MAKE_CHAR_MULTIBYTE (c2
);
2791 c1
= CHAR_TABLE_TRANSLATE (trt
, c1
);
2792 c2
= CHAR_TABLE_TRANSLATE (trt
, c2
);
2795 return make_number (- 1 - chars
);
2797 return make_number (chars
+ 1);
2802 /* The strings match as far as they go.
2803 If one is shorter, that one is less. */
2804 if (chars
< endp1
- begp1
)
2805 return make_number (chars
+ 1);
2806 else if (chars
< endp2
- begp2
)
2807 return make_number (- chars
- 1);
2809 /* Same length too => they are equal. */
2810 return make_number (0);
2814 subst_char_in_region_unwind (Lisp_Object arg
)
2816 return BVAR (current_buffer
, undo_list
) = arg
;
2820 subst_char_in_region_unwind_1 (Lisp_Object arg
)
2822 return BVAR (current_buffer
, filename
) = arg
;
2825 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
2826 Ssubst_char_in_region
, 4, 5, 0,
2827 doc
: /* From START to END, replace FROMCHAR with TOCHAR each time it occurs.
2828 If optional arg NOUNDO is non-nil, don't record this change for undo
2829 and don't mark the buffer as really changed.
2830 Both characters must have the same length of multi-byte form. */)
2831 (Lisp_Object start
, Lisp_Object end
, Lisp_Object fromchar
, Lisp_Object tochar
, Lisp_Object noundo
)
2833 register ptrdiff_t pos
, pos_byte
, stop
, i
, len
, end_byte
;
2834 /* Keep track of the first change in the buffer:
2835 if 0 we haven't found it yet.
2836 if < 0 we've found it and we've run the before-change-function.
2837 if > 0 we've actually performed it and the value is its position. */
2838 ptrdiff_t changed
= 0;
2839 unsigned char fromstr
[MAX_MULTIBYTE_LENGTH
], tostr
[MAX_MULTIBYTE_LENGTH
];
2841 ptrdiff_t count
= SPECPDL_INDEX ();
2842 #define COMBINING_NO 0
2843 #define COMBINING_BEFORE 1
2844 #define COMBINING_AFTER 2
2845 #define COMBINING_BOTH (COMBINING_BEFORE | COMBINING_AFTER)
2846 int maybe_byte_combining
= COMBINING_NO
;
2847 ptrdiff_t last_changed
= 0;
2848 int multibyte_p
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
2853 validate_region (&start
, &end
);
2854 CHECK_CHARACTER (fromchar
);
2855 CHECK_CHARACTER (tochar
);
2856 fromc
= XFASTINT (fromchar
);
2857 toc
= XFASTINT (tochar
);
2861 len
= CHAR_STRING (fromc
, fromstr
);
2862 if (CHAR_STRING (toc
, tostr
) != len
)
2863 error ("Characters in `subst-char-in-region' have different byte-lengths");
2864 if (!ASCII_BYTE_P (*tostr
))
2866 /* If *TOSTR is in the range 0x80..0x9F and TOCHAR is not a
2867 complete multibyte character, it may be combined with the
2868 after bytes. If it is in the range 0xA0..0xFF, it may be
2869 combined with the before and after bytes. */
2870 if (!CHAR_HEAD_P (*tostr
))
2871 maybe_byte_combining
= COMBINING_BOTH
;
2872 else if (BYTES_BY_CHAR_HEAD (*tostr
) > len
)
2873 maybe_byte_combining
= COMBINING_AFTER
;
2884 pos_byte
= CHAR_TO_BYTE (pos
);
2885 stop
= CHAR_TO_BYTE (XINT (end
));
2888 /* If we don't want undo, turn off putting stuff on the list.
2889 That's faster than getting rid of things,
2890 and it prevents even the entry for a first change.
2891 Also inhibit locking the file. */
2892 if (!changed
&& !NILP (noundo
))
2894 record_unwind_protect (subst_char_in_region_unwind
,
2895 BVAR (current_buffer
, undo_list
));
2896 BVAR (current_buffer
, undo_list
) = Qt
;
2897 /* Don't do file-locking. */
2898 record_unwind_protect (subst_char_in_region_unwind_1
,
2899 BVAR (current_buffer
, filename
));
2900 BVAR (current_buffer
, filename
) = Qnil
;
2903 if (pos_byte
< GPT_BYTE
)
2904 stop
= min (stop
, GPT_BYTE
);
2907 ptrdiff_t pos_byte_next
= pos_byte
;
2909 if (pos_byte
>= stop
)
2911 if (pos_byte
>= end_byte
) break;
2914 p
= BYTE_POS_ADDR (pos_byte
);
2916 INC_POS (pos_byte_next
);
2919 if (pos_byte_next
- pos_byte
== len
2920 && p
[0] == fromstr
[0]
2922 || (p
[1] == fromstr
[1]
2923 && (len
== 2 || (p
[2] == fromstr
[2]
2924 && (len
== 3 || p
[3] == fromstr
[3]))))))
2927 /* We've already seen this and run the before-change-function;
2928 this time we only need to record the actual position. */
2933 modify_region (current_buffer
, pos
, XINT (end
), 0);
2935 if (! NILP (noundo
))
2937 if (MODIFF
- 1 == SAVE_MODIFF
)
2939 if (MODIFF
- 1 == BUF_AUTOSAVE_MODIFF (current_buffer
))
2940 BUF_AUTOSAVE_MODIFF (current_buffer
)++;
2943 /* The before-change-function may have moved the gap
2944 or even modified the buffer so we should start over. */
2948 /* Take care of the case where the new character
2949 combines with neighboring bytes. */
2950 if (maybe_byte_combining
2951 && (maybe_byte_combining
== COMBINING_AFTER
2952 ? (pos_byte_next
< Z_BYTE
2953 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2954 : ((pos_byte_next
< Z_BYTE
2955 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2956 || (pos_byte
> BEG_BYTE
2957 && ! ASCII_BYTE_P (FETCH_BYTE (pos_byte
- 1))))))
2959 Lisp_Object tem
, string
;
2961 struct gcpro gcpro1
;
2963 tem
= BVAR (current_buffer
, undo_list
);
2966 /* Make a multibyte string containing this single character. */
2967 string
= make_multibyte_string ((char *) tostr
, 1, len
);
2968 /* replace_range is less efficient, because it moves the gap,
2969 but it handles combining correctly. */
2970 replace_range (pos
, pos
+ 1, string
,
2972 pos_byte_next
= CHAR_TO_BYTE (pos
);
2973 if (pos_byte_next
> pos_byte
)
2974 /* Before combining happened. We should not increment
2975 POS. So, to cancel the later increment of POS,
2979 INC_POS (pos_byte_next
);
2981 if (! NILP (noundo
))
2982 BVAR (current_buffer
, undo_list
) = tem
;
2989 record_change (pos
, 1);
2990 for (i
= 0; i
< len
; i
++) *p
++ = tostr
[i
];
2992 last_changed
= pos
+ 1;
2994 pos_byte
= pos_byte_next
;
3000 signal_after_change (changed
,
3001 last_changed
- changed
, last_changed
- changed
);
3002 update_compositions (changed
, last_changed
, CHECK_ALL
);
3005 unbind_to (count
, Qnil
);
3010 static Lisp_Object
check_translation (ptrdiff_t, ptrdiff_t, ptrdiff_t,
3013 /* Helper function for Ftranslate_region_internal.
3015 Check if a character sequence at POS (POS_BYTE) matches an element
3016 of VAL. VAL is a list (([FROM-CHAR ...] . TO) ...). If a matching
3017 element is found, return it. Otherwise return Qnil. */
3020 check_translation (ptrdiff_t pos
, ptrdiff_t pos_byte
, ptrdiff_t end
,
3023 int buf_size
= 16, buf_used
= 0;
3024 int *buf
= alloca (sizeof (int) * buf_size
);
3026 for (; CONSP (val
); val
= XCDR (val
))
3035 if (! VECTORP (elt
))
3038 if (len
<= end
- pos
)
3040 for (i
= 0; i
< len
; i
++)
3044 unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
3047 if (buf_used
== buf_size
)
3052 newbuf
= alloca (sizeof (int) * buf_size
);
3053 memcpy (newbuf
, buf
, sizeof (int) * buf_used
);
3056 buf
[buf_used
++] = STRING_CHAR_AND_LENGTH (p
, len1
);
3059 if (XINT (AREF (elt
, i
)) != buf
[i
])
3070 DEFUN ("translate-region-internal", Ftranslate_region_internal
,
3071 Stranslate_region_internal
, 3, 3, 0,
3072 doc
: /* Internal use only.
3073 From START to END, translate characters according to TABLE.
3074 TABLE is a string or a char-table; the Nth character in it is the
3075 mapping for the character with code N.
3076 It returns the number of characters changed. */)
3077 (Lisp_Object start
, Lisp_Object end
, register Lisp_Object table
)
3079 register unsigned char *tt
; /* Trans table. */
3080 register int nc
; /* New character. */
3081 int cnt
; /* Number of changes made. */
3082 ptrdiff_t size
; /* Size of translate table. */
3083 ptrdiff_t pos
, pos_byte
, end_pos
;
3084 int multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3085 int string_multibyte
IF_LINT (= 0);
3087 validate_region (&start
, &end
);
3088 if (CHAR_TABLE_P (table
))
3090 if (! EQ (XCHAR_TABLE (table
)->purpose
, Qtranslation_table
))
3091 error ("Not a translation table");
3097 CHECK_STRING (table
);
3099 if (! multibyte
&& (SCHARS (table
) < SBYTES (table
)))
3100 table
= string_make_unibyte (table
);
3101 string_multibyte
= SCHARS (table
) < SBYTES (table
);
3102 size
= SBYTES (table
);
3107 pos_byte
= CHAR_TO_BYTE (pos
);
3108 end_pos
= XINT (end
);
3109 modify_region (current_buffer
, pos
, end_pos
, 0);
3112 for (; pos
< end_pos
; )
3114 register unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
3115 unsigned char *str
, buf
[MAX_MULTIBYTE_LENGTH
];
3121 oc
= STRING_CHAR_AND_LENGTH (p
, len
);
3128 /* Reload as signal_after_change in last iteration may GC. */
3130 if (string_multibyte
)
3132 str
= tt
+ string_char_to_byte (table
, oc
);
3133 nc
= STRING_CHAR_AND_LENGTH (str
, str_len
);
3138 if (! ASCII_BYTE_P (nc
) && multibyte
)
3140 str_len
= BYTE8_STRING (nc
, buf
);
3153 val
= CHAR_TABLE_REF (table
, oc
);
3154 if (CHARACTERP (val
))
3156 nc
= XFASTINT (val
);
3157 str_len
= CHAR_STRING (nc
, buf
);
3160 else if (VECTORP (val
) || (CONSP (val
)))
3162 /* VAL is [TO_CHAR ...] or (([FROM-CHAR ...] . TO) ...)
3163 where TO is TO-CHAR or [TO-CHAR ...]. */
3168 if (nc
!= oc
&& nc
>= 0)
3170 /* Simple one char to one char translation. */
3175 /* This is less efficient, because it moves the gap,
3176 but it should handle multibyte characters correctly. */
3177 string
= make_multibyte_string ((char *) str
, 1, str_len
);
3178 replace_range (pos
, pos
+ 1, string
, 1, 0, 1);
3183 record_change (pos
, 1);
3184 while (str_len
-- > 0)
3186 signal_after_change (pos
, 1, 1);
3187 update_compositions (pos
, pos
+ 1, CHECK_BORDER
);
3197 val
= check_translation (pos
, pos_byte
, end_pos
, val
);
3204 /* VAL is ([FROM-CHAR ...] . TO). */
3205 len
= ASIZE (XCAR (val
));
3213 string
= Fconcat (1, &val
);
3217 string
= Fmake_string (make_number (1), val
);
3219 replace_range (pos
, pos
+ len
, string
, 1, 0, 1);
3220 pos_byte
+= SBYTES (string
);
3221 pos
+= SCHARS (string
);
3222 cnt
+= SCHARS (string
);
3223 end_pos
+= SCHARS (string
) - len
;
3231 return make_number (cnt
);
3234 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
3235 doc
: /* Delete the text between START and END.
3236 If called interactively, delete the region between point and mark.
3237 This command deletes buffer text without modifying the kill ring. */)
3238 (Lisp_Object start
, Lisp_Object end
)
3240 validate_region (&start
, &end
);
3241 del_range (XINT (start
), XINT (end
));
3245 DEFUN ("delete-and-extract-region", Fdelete_and_extract_region
,
3246 Sdelete_and_extract_region
, 2, 2, 0,
3247 doc
: /* Delete the text between START and END and return it. */)
3248 (Lisp_Object start
, Lisp_Object end
)
3250 validate_region (&start
, &end
);
3251 if (XINT (start
) == XINT (end
))
3252 return empty_unibyte_string
;
3253 return del_range_1 (XINT (start
), XINT (end
), 1, 1);
3256 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
3257 doc
: /* Remove restrictions (narrowing) from current buffer.
3258 This allows the buffer's full text to be seen and edited. */)
3261 if (BEG
!= BEGV
|| Z
!= ZV
)
3262 current_buffer
->clip_changed
= 1;
3264 BEGV_BYTE
= BEG_BYTE
;
3265 SET_BUF_ZV_BOTH (current_buffer
, Z
, Z_BYTE
);
3266 /* Changing the buffer bounds invalidates any recorded current column. */
3267 invalidate_current_column ();
3271 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
3272 doc
: /* Restrict editing in this buffer to the current region.
3273 The rest of the text becomes temporarily invisible and untouchable
3274 but is not deleted; if you save the buffer in a file, the invisible
3275 text is included in the file. \\[widen] makes all visible again.
3276 See also `save-restriction'.
3278 When calling from a program, pass two arguments; positions (integers
3279 or markers) bounding the text that should remain visible. */)
3280 (register Lisp_Object start
, Lisp_Object end
)
3282 CHECK_NUMBER_COERCE_MARKER (start
);
3283 CHECK_NUMBER_COERCE_MARKER (end
);
3285 if (XINT (start
) > XINT (end
))
3288 tem
= start
; start
= end
; end
= tem
;
3291 if (!(BEG
<= XINT (start
) && XINT (start
) <= XINT (end
) && XINT (end
) <= Z
))
3292 args_out_of_range (start
, end
);
3294 if (BEGV
!= XFASTINT (start
) || ZV
!= XFASTINT (end
))
3295 current_buffer
->clip_changed
= 1;
3297 SET_BUF_BEGV (current_buffer
, XFASTINT (start
));
3298 SET_BUF_ZV (current_buffer
, XFASTINT (end
));
3299 if (PT
< XFASTINT (start
))
3300 SET_PT (XFASTINT (start
));
3301 if (PT
> XFASTINT (end
))
3302 SET_PT (XFASTINT (end
));
3303 /* Changing the buffer bounds invalidates any recorded current column. */
3304 invalidate_current_column ();
3309 save_restriction_save (void)
3311 if (BEGV
== BEG
&& ZV
== Z
)
3312 /* The common case that the buffer isn't narrowed.
3313 We return just the buffer object, which save_restriction_restore
3314 recognizes as meaning `no restriction'. */
3315 return Fcurrent_buffer ();
3317 /* We have to save a restriction, so return a pair of markers, one
3318 for the beginning and one for the end. */
3320 Lisp_Object beg
, end
;
3322 beg
= build_marker (current_buffer
, BEGV
, BEGV_BYTE
);
3323 end
= build_marker (current_buffer
, ZV
, ZV_BYTE
);
3325 /* END must move forward if text is inserted at its exact location. */
3326 XMARKER (end
)->insertion_type
= 1;
3328 return Fcons (beg
, end
);
3333 save_restriction_restore (Lisp_Object data
)
3335 struct buffer
*cur
= NULL
;
3336 struct buffer
*buf
= (CONSP (data
)
3337 ? XMARKER (XCAR (data
))->buffer
3340 if (buf
&& buf
!= current_buffer
&& !NILP (BVAR (buf
, pt_marker
)))
3341 { /* If `buf' uses markers to keep track of PT, BEGV, and ZV (as
3342 is the case if it is or has an indirect buffer), then make
3343 sure it is current before we update BEGV, so
3344 set_buffer_internal takes care of managing those markers. */
3345 cur
= current_buffer
;
3346 set_buffer_internal (buf
);
3350 /* A pair of marks bounding a saved restriction. */
3352 struct Lisp_Marker
*beg
= XMARKER (XCAR (data
));
3353 struct Lisp_Marker
*end
= XMARKER (XCDR (data
));
3354 eassert (buf
== end
->buffer
);
3356 if (buf
/* Verify marker still points to a buffer. */
3357 && (beg
->charpos
!= BUF_BEGV (buf
) || end
->charpos
!= BUF_ZV (buf
)))
3358 /* The restriction has changed from the saved one, so restore
3359 the saved restriction. */
3361 ptrdiff_t pt
= BUF_PT (buf
);
3363 SET_BUF_BEGV_BOTH (buf
, beg
->charpos
, beg
->bytepos
);
3364 SET_BUF_ZV_BOTH (buf
, end
->charpos
, end
->bytepos
);
3366 if (pt
< beg
->charpos
|| pt
> end
->charpos
)
3367 /* The point is outside the new visible range, move it inside. */
3368 SET_BUF_PT_BOTH (buf
,
3369 clip_to_bounds (beg
->charpos
, pt
, end
->charpos
),
3370 clip_to_bounds (beg
->bytepos
, BUF_PT_BYTE (buf
),
3373 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3377 /* A buffer, which means that there was no old restriction. */
3379 if (buf
/* Verify marker still points to a buffer. */
3380 && (BUF_BEGV (buf
) != BUF_BEG (buf
) || BUF_ZV (buf
) != BUF_Z (buf
)))
3381 /* The buffer has been narrowed, get rid of the narrowing. */
3383 SET_BUF_BEGV_BOTH (buf
, BUF_BEG (buf
), BUF_BEG_BYTE (buf
));
3384 SET_BUF_ZV_BOTH (buf
, BUF_Z (buf
), BUF_Z_BYTE (buf
));
3386 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3390 /* Changing the buffer bounds invalidates any recorded current column. */
3391 invalidate_current_column ();
3394 set_buffer_internal (cur
);
3399 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
3400 doc
: /* Execute BODY, saving and restoring current buffer's restrictions.
3401 The buffer's restrictions make parts of the beginning and end invisible.
3402 \(They are set up with `narrow-to-region' and eliminated with `widen'.)
3403 This special form, `save-restriction', saves the current buffer's restrictions
3404 when it is entered, and restores them when it is exited.
3405 So any `narrow-to-region' within BODY lasts only until the end of the form.
3406 The old restrictions settings are restored
3407 even in case of abnormal exit (throw or error).
3409 The value returned is the value of the last form in BODY.
3411 Note: if you are using both `save-excursion' and `save-restriction',
3412 use `save-excursion' outermost:
3413 (save-excursion (save-restriction ...))
3415 usage: (save-restriction &rest BODY) */)
3418 register Lisp_Object val
;
3419 ptrdiff_t count
= SPECPDL_INDEX ();
3421 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
3422 val
= Fprogn (body
);
3423 return unbind_to (count
, val
);
3426 /* Buffer for the most recent text displayed by Fmessage_box. */
3427 static char *message_text
;
3429 /* Allocated length of that buffer. */
3430 static ptrdiff_t message_length
;
3432 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
3433 doc
: /* Display a message at the bottom of the screen.
3434 The message also goes into the `*Messages*' buffer.
3435 \(In keyboard macros, that's all it does.)
3438 The first argument is a format control string, and the rest are data
3439 to be formatted under control of the string. See `format' for details.
3441 Note: Use (message "%s" VALUE) to print the value of expressions and
3442 variables to avoid accidentally interpreting `%' as format specifiers.
3444 If the first argument is nil or the empty string, the function clears
3445 any existing message; this lets the minibuffer contents show. See
3446 also `current-message'.
3448 usage: (message FORMAT-STRING &rest ARGS) */)
3449 (ptrdiff_t nargs
, Lisp_Object
*args
)
3452 || (STRINGP (args
[0])
3453 && SBYTES (args
[0]) == 0))
3460 register Lisp_Object val
;
3461 val
= Fformat (nargs
, args
);
3462 message3 (val
, SBYTES (val
), STRING_MULTIBYTE (val
));
3467 DEFUN ("message-box", Fmessage_box
, Smessage_box
, 1, MANY
, 0,
3468 doc
: /* Display a message, in a dialog box if possible.
3469 If a dialog box is not available, use the echo area.
3470 The first argument is a format control string, and the rest are data
3471 to be formatted under control of the string. See `format' for details.
3473 If the first argument is nil or the empty string, clear any existing
3474 message; let the minibuffer contents show.
3476 usage: (message-box FORMAT-STRING &rest ARGS) */)
3477 (ptrdiff_t nargs
, Lisp_Object
*args
)
3486 register Lisp_Object val
;
3487 val
= Fformat (nargs
, args
);
3489 /* The MS-DOS frames support popup menus even though they are
3490 not FRAME_WINDOW_P. */
3491 if (FRAME_WINDOW_P (XFRAME (selected_frame
))
3492 || FRAME_MSDOS_P (XFRAME (selected_frame
)))
3494 Lisp_Object pane
, menu
;
3495 struct gcpro gcpro1
;
3496 pane
= Fcons (Fcons (build_string ("OK"), Qt
), Qnil
);
3498 menu
= Fcons (val
, pane
);
3499 Fx_popup_dialog (Qt
, menu
, Qt
);
3503 #endif /* HAVE_MENUS */
3504 /* Copy the data so that it won't move when we GC. */
3505 if (SBYTES (val
) > message_length
)
3507 ptrdiff_t new_length
= SBYTES (val
) + 80;
3508 message_text
= xrealloc (message_text
, new_length
);
3509 message_length
= new_length
;
3511 memcpy (message_text
, SDATA (val
), SBYTES (val
));
3512 message2 (message_text
, SBYTES (val
),
3513 STRING_MULTIBYTE (val
));
3518 DEFUN ("message-or-box", Fmessage_or_box
, Smessage_or_box
, 1, MANY
, 0,
3519 doc
: /* Display a message in a dialog box or in the echo area.
3520 If this command was invoked with the mouse, use a dialog box if
3521 `use-dialog-box' is non-nil.
3522 Otherwise, use the echo area.
3523 The first argument is a format control string, and the rest are data
3524 to be formatted under control of the string. See `format' for details.
3526 If the first argument is nil or the empty string, clear any existing
3527 message; let the minibuffer contents show.
3529 usage: (message-or-box FORMAT-STRING &rest ARGS) */)
3530 (ptrdiff_t nargs
, Lisp_Object
*args
)
3533 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3535 return Fmessage_box (nargs
, args
);
3537 return Fmessage (nargs
, args
);
3540 DEFUN ("current-message", Fcurrent_message
, Scurrent_message
, 0, 0, 0,
3541 doc
: /* Return the string currently displayed in the echo area, or nil if none. */)
3544 return current_message ();
3548 DEFUN ("propertize", Fpropertize
, Spropertize
, 1, MANY
, 0,
3549 doc
: /* Return a copy of STRING with text properties added.
3550 First argument is the string to copy.
3551 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
3552 properties to add to the result.
3553 usage: (propertize STRING &rest PROPERTIES) */)
3554 (ptrdiff_t nargs
, Lisp_Object
*args
)
3556 Lisp_Object properties
, string
;
3557 struct gcpro gcpro1
, gcpro2
;
3560 /* Number of args must be odd. */
3561 if ((nargs
& 1) == 0)
3562 error ("Wrong number of arguments");
3564 properties
= string
= Qnil
;
3565 GCPRO2 (properties
, string
);
3567 /* First argument must be a string. */
3568 CHECK_STRING (args
[0]);
3569 string
= Fcopy_sequence (args
[0]);
3571 for (i
= 1; i
< nargs
; i
+= 2)
3572 properties
= Fcons (args
[i
], Fcons (args
[i
+ 1], properties
));
3574 Fadd_text_properties (make_number (0),
3575 make_number (SCHARS (string
)),
3576 properties
, string
);
3577 RETURN_UNGCPRO (string
);
3580 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
3581 doc
: /* Format a string out of a format-string and arguments.
3582 The first argument is a format control string.
3583 The other arguments are substituted into it to make the result, a string.
3585 The format control string may contain %-sequences meaning to substitute
3586 the next available argument:
3588 %s means print a string argument. Actually, prints any object, with `princ'.
3589 %d means print as number in decimal (%o octal, %x hex).
3590 %X is like %x, but uses upper case.
3591 %e means print a number in exponential notation.
3592 %f means print a number in decimal-point notation.
3593 %g means print a number in exponential notation
3594 or decimal-point notation, whichever uses fewer characters.
3595 %c means print a number as a single character.
3596 %S means print any object as an s-expression (using `prin1').
3598 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.
3599 Use %% to put a single % into the output.
3601 A %-sequence may contain optional flag, width, and precision
3602 specifiers, as follows:
3604 %<flags><width><precision>character
3606 where flags is [+ #-0]+, width is [0-9]+, and precision is .[0-9]+
3608 The + flag character inserts a + before any positive number, while a
3609 space inserts a space before any positive number; these flags only
3610 affect %d, %e, %f, and %g sequences, and the + flag takes precedence.
3611 The # flag means to use an alternate display form for %o, %x, %X, %e,
3612 %f, and %g sequences. The - and 0 flags affect the width specifier,
3615 The width specifier supplies a lower limit for the length of the
3616 printed representation. The padding, if any, normally goes on the
3617 left, but it goes on the right if the - flag is present. The padding
3618 character is normally a space, but it is 0 if the 0 flag is present.
3619 The 0 flag is ignored if the - flag is present, or the format sequence
3620 is something other than %d, %e, %f, and %g.
3622 For %e, %f, and %g sequences, the number after the "." in the
3623 precision specifier says how many decimal places to show; if zero, the
3624 decimal point itself is omitted. For %s and %S, the precision
3625 specifier truncates the string to the given width.
3627 usage: (format STRING &rest OBJECTS) */)
3628 (ptrdiff_t nargs
, Lisp_Object
*args
)
3630 ptrdiff_t n
; /* The number of the next arg to substitute */
3631 char initial_buffer
[4000];
3632 char *buf
= initial_buffer
;
3633 ptrdiff_t bufsize
= sizeof initial_buffer
;
3634 ptrdiff_t max_bufsize
= STRING_BYTES_BOUND
+ 1;
3636 Lisp_Object buf_save_value
IF_LINT (= {0});
3637 register char *format
, *end
, *format_start
;
3638 ptrdiff_t formatlen
, nchars
;
3639 /* Nonzero if the format is multibyte. */
3640 int multibyte_format
= 0;
3641 /* Nonzero if the output should be a multibyte string,
3642 which is true if any of the inputs is one. */
3644 /* When we make a multibyte string, we must pay attention to the
3645 byte combining problem, i.e., a byte may be combined with a
3646 multibyte character of the previous string. This flag tells if we
3647 must consider such a situation or not. */
3648 int maybe_combine_byte
;
3650 int arg_intervals
= 0;
3653 /* discarded[I] is 1 if byte I of the format
3654 string was not copied into the output.
3655 It is 2 if byte I was not the first byte of its character. */
3658 /* Each element records, for one argument,
3659 the start and end bytepos in the output string,
3660 whether the argument has been converted to string (e.g., due to "%S"),
3661 and whether the argument is a string with intervals.
3662 info[0] is unused. Unused elements have -1 for start. */
3665 ptrdiff_t start
, end
;
3666 int converted_to_string
;
3670 /* It should not be necessary to GCPRO ARGS, because
3671 the caller in the interpreter should take care of that. */
3673 CHECK_STRING (args
[0]);
3674 format_start
= SSDATA (args
[0]);
3675 formatlen
= SBYTES (args
[0]);
3677 /* Allocate the info and discarded tables. */
3680 if ((SIZE_MAX
- formatlen
) / sizeof (struct info
) <= nargs
)
3681 memory_full (SIZE_MAX
);
3682 SAFE_ALLOCA (info
, struct info
*, (nargs
+ 1) * sizeof *info
+ formatlen
);
3683 discarded
= (char *) &info
[nargs
+ 1];
3684 for (i
= 0; i
< nargs
+ 1; i
++)
3687 info
[i
].intervals
= info
[i
].converted_to_string
= 0;
3689 memset (discarded
, 0, formatlen
);
3692 /* Try to determine whether the result should be multibyte.
3693 This is not always right; sometimes the result needs to be multibyte
3694 because of an object that we will pass through prin1,
3695 and in that case, we won't know it here. */
3696 multibyte_format
= STRING_MULTIBYTE (args
[0]);
3697 multibyte
= multibyte_format
;
3698 for (n
= 1; !multibyte
&& n
< nargs
; n
++)
3699 if (STRINGP (args
[n
]) && STRING_MULTIBYTE (args
[n
]))
3702 /* If we start out planning a unibyte result,
3703 then discover it has to be multibyte, we jump back to retry. */
3710 /* Scan the format and store result in BUF. */
3711 format
= format_start
;
3712 end
= format
+ formatlen
;
3713 maybe_combine_byte
= 0;
3715 while (format
!= end
)
3717 /* The values of N and FORMAT when the loop body is entered. */
3719 char *format0
= format
;
3721 /* Bytes needed to represent the output of this conversion. */
3722 ptrdiff_t convbytes
;
3726 /* General format specifications look like
3728 '%' [flags] [field-width] [precision] format
3733 field-width ::= [0-9]+
3734 precision ::= '.' [0-9]*
3736 If a field-width is specified, it specifies to which width
3737 the output should be padded with blanks, if the output
3738 string is shorter than field-width.
3740 If precision is specified, it specifies the number of
3741 digits to print after the '.' for floats, or the max.
3742 number of chars to print from a string. */
3749 ptrdiff_t field_width
;
3750 int precision_given
;
3751 uintmax_t precision
= UINTMAX_MAX
;
3759 case '-': minus_flag
= 1; continue;
3760 case '+': plus_flag
= 1; continue;
3761 case ' ': space_flag
= 1; continue;
3762 case '#': sharp_flag
= 1; continue;
3763 case '0': zero_flag
= 1; continue;
3768 /* Ignore flags when sprintf ignores them. */
3769 space_flag
&= ~ plus_flag
;
3770 zero_flag
&= ~ minus_flag
;
3773 uintmax_t w
= strtoumax (format
, &num_end
, 10);
3774 if (max_bufsize
<= w
)
3778 precision_given
= *num_end
== '.';
3779 if (precision_given
)
3780 precision
= strtoumax (num_end
+ 1, &num_end
, 10);
3784 error ("Format string ends in middle of format specifier");
3786 memset (&discarded
[format0
- format_start
], 1, format
- format0
);
3787 conversion
= *format
;
3788 if (conversion
== '%')
3790 discarded
[format
- format_start
] = 1;
3795 error ("Not enough arguments for format string");
3797 /* For 'S', prin1 the argument, and then treat like 's'.
3798 For 's', princ any argument that is not a string or
3799 symbol. But don't do this conversion twice, which might
3800 happen after retrying. */
3801 if ((conversion
== 'S'
3802 || (conversion
== 's'
3803 && ! STRINGP (args
[n
]) && ! SYMBOLP (args
[n
]))))
3805 if (! info
[n
].converted_to_string
)
3807 Lisp_Object noescape
= conversion
== 'S' ? Qnil
: Qt
;
3808 args
[n
] = Fprin1_to_string (args
[n
], noescape
);
3809 info
[n
].converted_to_string
= 1;
3810 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
3818 else if (conversion
== 'c')
3820 if (FLOATP (args
[n
]))
3822 double d
= XFLOAT_DATA (args
[n
]);
3823 args
[n
] = make_number (FIXNUM_OVERFLOW_P (d
) ? -1 : d
);
3826 if (INTEGERP (args
[n
]) && ! ASCII_CHAR_P (XINT (args
[n
])))
3833 args
[n
] = Fchar_to_string (args
[n
]);
3834 info
[n
].converted_to_string
= 1;
3837 if (info
[n
].converted_to_string
)
3842 if (SYMBOLP (args
[n
]))
3844 args
[n
] = SYMBOL_NAME (args
[n
]);
3845 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
3852 if (conversion
== 's')
3854 /* handle case (precision[n] >= 0) */
3856 ptrdiff_t width
, padding
, nbytes
;
3857 ptrdiff_t nchars_string
;
3859 ptrdiff_t prec
= -1;
3860 if (precision_given
&& precision
<= TYPE_MAXIMUM (ptrdiff_t))
3863 /* lisp_string_width ignores a precision of 0, but GNU
3864 libc functions print 0 characters when the precision
3865 is 0. Imitate libc behavior here. Changing
3866 lisp_string_width is the right thing, and will be
3867 done, but meanwhile we work with it. */
3870 width
= nchars_string
= nbytes
= 0;
3874 width
= lisp_string_width (args
[n
], prec
, &nch
, &nby
);
3877 nchars_string
= SCHARS (args
[n
]);
3878 nbytes
= SBYTES (args
[n
]);
3882 nchars_string
= nch
;
3888 if (convbytes
&& multibyte
&& ! STRING_MULTIBYTE (args
[n
]))
3889 convbytes
= count_size_as_multibyte (SDATA (args
[n
]), nbytes
);
3891 padding
= width
< field_width
? field_width
- width
: 0;
3893 if (max_bufsize
- padding
<= convbytes
)
3895 convbytes
+= padding
;
3896 if (convbytes
<= buf
+ bufsize
- p
)
3900 memset (p
, ' ', padding
);
3907 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3908 && STRING_MULTIBYTE (args
[n
])
3909 && !CHAR_HEAD_P (SREF (args
[n
], 0)))
3910 maybe_combine_byte
= 1;
3912 p
+= copy_text (SDATA (args
[n
]), (unsigned char *) p
,
3914 STRING_MULTIBYTE (args
[n
]), multibyte
);
3916 info
[n
].start
= nchars
;
3917 nchars
+= nchars_string
;
3918 info
[n
].end
= nchars
;
3922 memset (p
, ' ', padding
);
3927 /* If this argument has text properties, record where
3928 in the result string it appears. */
3929 if (STRING_INTERVALS (args
[n
]))
3930 info
[n
].intervals
= arg_intervals
= 1;
3935 else if (! (conversion
== 'c' || conversion
== 'd'
3936 || conversion
== 'e' || conversion
== 'f'
3937 || conversion
== 'g' || conversion
== 'i'
3938 || conversion
== 'o' || conversion
== 'x'
3939 || conversion
== 'X'))
3940 error ("Invalid format operation %%%c",
3941 STRING_CHAR ((unsigned char *) format
- 1));
3942 else if (! (INTEGERP (args
[n
]) || FLOATP (args
[n
])))
3943 error ("Format specifier doesn't match argument type");
3948 /* Maximum precision for a %f conversion such that the
3949 trailing output digit might be nonzero. Any precision
3950 larger than this will not yield useful information. */
3951 USEFUL_PRECISION_MAX
=
3953 * (FLT_RADIX
== 2 || FLT_RADIX
== 10 ? 1
3954 : FLT_RADIX
== 16 ? 4
3957 /* Maximum number of bytes generated by any format, if
3958 precision is no more than USEFUL_PRECISION_MAX.
3959 On all practical hosts, %f is the worst case. */
3961 sizeof "-." + (DBL_MAX_10_EXP
+ 1) + USEFUL_PRECISION_MAX
,
3963 /* Length of pM (that is, of pMd without the
3965 pMlen
= sizeof pMd
- 2
3967 verify (0 < USEFUL_PRECISION_MAX
);
3970 ptrdiff_t padding
, sprintf_bytes
;
3971 uintmax_t excess_precision
, numwidth
;
3972 uintmax_t leading_zeros
= 0, trailing_zeros
= 0;
3974 char sprintf_buf
[SPRINTF_BUFSIZE
];
3976 /* Copy of conversion specification, modified somewhat.
3977 At most three flags F can be specified at once. */
3978 char convspec
[sizeof "%FFF.*d" + pMlen
];
3980 /* Avoid undefined behavior in underlying sprintf. */
3981 if (conversion
== 'd' || conversion
== 'i')
3984 /* Create the copy of the conversion specification, with
3985 any width and precision removed, with ".*" inserted,
3986 and with pM inserted for integer formats. */
3990 *f
= '-'; f
+= minus_flag
;
3991 *f
= '+'; f
+= plus_flag
;
3992 *f
= ' '; f
+= space_flag
;
3993 *f
= '#'; f
+= sharp_flag
;
3994 *f
= '0'; f
+= zero_flag
;
3997 if (conversion
== 'd' || conversion
== 'i'
3998 || conversion
== 'o' || conversion
== 'x'
3999 || conversion
== 'X')
4001 memcpy (f
, pMd
, pMlen
);
4003 zero_flag
&= ~ precision_given
;
4010 if (precision_given
)
4011 prec
= min (precision
, USEFUL_PRECISION_MAX
);
4013 /* Use sprintf to format this number into sprintf_buf. Omit
4014 padding and excess precision, though, because sprintf limits
4015 output length to INT_MAX.
4017 There are four types of conversion: double, unsigned
4018 char (passed as int), wide signed int, and wide
4019 unsigned int. Treat them separately because the
4020 sprintf ABI is sensitive to which type is passed. Be
4021 careful about integer overflow, NaNs, infinities, and
4022 conversions; for example, the min and max macros are
4023 not suitable here. */
4024 if (conversion
== 'e' || conversion
== 'f' || conversion
== 'g')
4026 double x
= (INTEGERP (args
[n
])
4028 : XFLOAT_DATA (args
[n
]));
4029 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4031 else if (conversion
== 'c')
4033 /* Don't use sprintf here, as it might mishandle prec. */
4034 sprintf_buf
[0] = XINT (args
[n
]);
4035 sprintf_bytes
= prec
!= 0;
4037 else if (conversion
== 'd')
4039 /* For float, maybe we should use "%1.0f"
4040 instead so it also works for values outside
4041 the integer range. */
4043 if (INTEGERP (args
[n
]))
4047 double d
= XFLOAT_DATA (args
[n
]);
4050 x
= TYPE_MINIMUM (printmax_t
);
4056 x
= TYPE_MAXIMUM (printmax_t
);
4061 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4065 /* Don't sign-extend for octal or hex printing. */
4067 if (INTEGERP (args
[n
]))
4068 x
= XUINT (args
[n
]);
4071 double d
= XFLOAT_DATA (args
[n
]);
4076 x
= TYPE_MAXIMUM (uprintmax_t
);
4081 sprintf_bytes
= sprintf (sprintf_buf
, convspec
, prec
, x
);
4084 /* Now the length of the formatted item is known, except it omits
4085 padding and excess precision. Deal with excess precision
4086 first. This happens only when the format specifies
4087 ridiculously large precision. */
4088 excess_precision
= precision
- prec
;
4089 if (excess_precision
)
4091 if (conversion
== 'e' || conversion
== 'f'
4092 || conversion
== 'g')
4094 if ((conversion
== 'g' && ! sharp_flag
)
4095 || ! ('0' <= sprintf_buf
[sprintf_bytes
- 1]
4096 && sprintf_buf
[sprintf_bytes
- 1] <= '9'))
4097 excess_precision
= 0;
4100 if (conversion
== 'g')
4102 char *dot
= strchr (sprintf_buf
, '.');
4104 excess_precision
= 0;
4107 trailing_zeros
= excess_precision
;
4110 leading_zeros
= excess_precision
;
4113 /* Compute the total bytes needed for this item, including
4114 excess precision and padding. */
4115 numwidth
= sprintf_bytes
+ excess_precision
;
4116 padding
= numwidth
< field_width
? field_width
- numwidth
: 0;
4117 if (max_bufsize
- sprintf_bytes
<= excess_precision
4118 || max_bufsize
- padding
<= numwidth
)
4120 convbytes
= numwidth
+ padding
;
4122 if (convbytes
<= buf
+ bufsize
- p
)
4124 /* Copy the formatted item from sprintf_buf into buf,
4125 inserting padding and excess-precision zeros. */
4127 char *src
= sprintf_buf
;
4129 int exponent_bytes
= 0;
4130 int signedp
= src0
== '-' || src0
== '+' || src0
== ' ';
4131 int significand_bytes
;
4133 && ((src
[signedp
] >= '0' && src
[signedp
] <= '9')
4134 || (src
[signedp
] >= 'a' && src
[signedp
] <= 'f')
4135 || (src
[signedp
] >= 'A' && src
[signedp
] <= 'F')))
4137 leading_zeros
+= padding
;
4141 if (excess_precision
4142 && (conversion
== 'e' || conversion
== 'g'))
4144 char *e
= strchr (src
, 'e');
4146 exponent_bytes
= src
+ sprintf_bytes
- e
;
4151 memset (p
, ' ', padding
);
4159 memset (p
, '0', leading_zeros
);
4161 significand_bytes
= sprintf_bytes
- signedp
- exponent_bytes
;
4162 memcpy (p
, src
, significand_bytes
);
4163 p
+= significand_bytes
;
4164 src
+= significand_bytes
;
4165 memset (p
, '0', trailing_zeros
);
4166 p
+= trailing_zeros
;
4167 memcpy (p
, src
, exponent_bytes
);
4168 p
+= exponent_bytes
;
4170 info
[n
].start
= nchars
;
4171 nchars
+= leading_zeros
+ sprintf_bytes
+ trailing_zeros
;
4172 info
[n
].end
= nchars
;
4176 memset (p
, ' ', padding
);
4188 /* Copy a single character from format to buf. */
4191 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
4193 if (multibyte_format
)
4195 /* Copy a whole multibyte character. */
4197 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
4198 && !CHAR_HEAD_P (*format
))
4199 maybe_combine_byte
= 1;
4203 while (! CHAR_HEAD_P (*format
));
4205 convbytes
= format
- src
;
4206 memset (&discarded
[src
+ 1 - format_start
], 2, convbytes
- 1);
4210 unsigned char uc
= *format
++;
4211 if (! multibyte
|| ASCII_BYTE_P (uc
))
4215 int c
= BYTE8_TO_CHAR (uc
);
4216 convbytes
= CHAR_STRING (c
, str
);
4221 if (convbytes
<= buf
+ bufsize
- p
)
4223 memcpy (p
, src
, convbytes
);
4230 /* There wasn't enough room to store this conversion or single
4231 character. CONVBYTES says how much room is needed. Allocate
4232 enough room (and then some) and do it again. */
4234 ptrdiff_t used
= p
- buf
;
4236 if (max_bufsize
- used
< convbytes
)
4238 bufsize
= used
+ convbytes
;
4239 bufsize
= bufsize
< max_bufsize
/ 2 ? bufsize
* 2 : max_bufsize
;
4241 if (buf
== initial_buffer
)
4243 buf
= xmalloc (bufsize
);
4245 buf_save_value
= make_save_value (buf
, 0);
4246 record_unwind_protect (safe_alloca_unwind
, buf_save_value
);
4247 memcpy (buf
, initial_buffer
, used
);
4250 XSAVE_VALUE (buf_save_value
)->pointer
= buf
= xrealloc (buf
, bufsize
);
4259 if (bufsize
< p
- buf
)
4262 if (maybe_combine_byte
)
4263 nchars
= multibyte_chars_in_text ((unsigned char *) buf
, p
- buf
);
4264 val
= make_specified_string (buf
, nchars
, p
- buf
, multibyte
);
4266 /* If we allocated BUF with malloc, free it too. */
4269 /* If the format string has text properties, or any of the string
4270 arguments has text properties, set up text properties of the
4273 if (STRING_INTERVALS (args
[0]) || arg_intervals
)
4275 Lisp_Object len
, new_len
, props
;
4276 struct gcpro gcpro1
;
4278 /* Add text properties from the format string. */
4279 len
= make_number (SCHARS (args
[0]));
4280 props
= text_property_list (args
[0], make_number (0), len
, Qnil
);
4285 ptrdiff_t bytepos
= 0, position
= 0, translated
= 0;
4289 /* Adjust the bounds of each text property
4290 to the proper start and end in the output string. */
4292 /* Put the positions in PROPS in increasing order, so that
4293 we can do (effectively) one scan through the position
4294 space of the format string. */
4295 props
= Fnreverse (props
);
4297 /* BYTEPOS is the byte position in the format string,
4298 POSITION is the untranslated char position in it,
4299 TRANSLATED is the translated char position in BUF,
4300 and ARGN is the number of the next arg we will come to. */
4301 for (list
= props
; CONSP (list
); list
= XCDR (list
))
4308 /* First adjust the property start position. */
4309 pos
= XINT (XCAR (item
));
4311 /* Advance BYTEPOS, POSITION, TRANSLATED and ARGN
4312 up to this position. */
4313 for (; position
< pos
; bytepos
++)
4315 if (! discarded
[bytepos
])
4316 position
++, translated
++;
4317 else if (discarded
[bytepos
] == 1)
4320 if (translated
== info
[argn
].start
)
4322 translated
+= info
[argn
].end
- info
[argn
].start
;
4328 XSETCAR (item
, make_number (translated
));
4330 /* Likewise adjust the property end position. */
4331 pos
= XINT (XCAR (XCDR (item
)));
4333 for (; position
< pos
; bytepos
++)
4335 if (! discarded
[bytepos
])
4336 position
++, translated
++;
4337 else if (discarded
[bytepos
] == 1)
4340 if (translated
== info
[argn
].start
)
4342 translated
+= info
[argn
].end
- info
[argn
].start
;
4348 XSETCAR (XCDR (item
), make_number (translated
));
4351 add_text_properties_from_list (val
, props
, make_number (0));
4354 /* Add text properties from arguments. */
4356 for (n
= 1; n
< nargs
; ++n
)
4357 if (info
[n
].intervals
)
4359 len
= make_number (SCHARS (args
[n
]));
4360 new_len
= make_number (info
[n
].end
- info
[n
].start
);
4361 props
= text_property_list (args
[n
], make_number (0), len
, Qnil
);
4362 props
= extend_property_ranges (props
, new_len
);
4363 /* If successive arguments have properties, be sure that
4364 the value of `composition' property be the copy. */
4365 if (n
> 1 && info
[n
- 1].end
)
4366 make_composition_value_copy (props
);
4367 add_text_properties_from_list (val
, props
,
4368 make_number (info
[n
].start
));
4378 format2 (const char *string1
, Lisp_Object arg0
, Lisp_Object arg1
)
4380 Lisp_Object args
[3];
4381 args
[0] = build_string (string1
);
4384 return Fformat (3, args
);
4387 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
4388 doc
: /* Return t if two characters match, optionally ignoring case.
4389 Both arguments must be characters (i.e. integers).
4390 Case is ignored if `case-fold-search' is non-nil in the current buffer. */)
4391 (register Lisp_Object c1
, Lisp_Object c2
)
4394 /* Check they're chars, not just integers, otherwise we could get array
4395 bounds violations in downcase. */
4396 CHECK_CHARACTER (c1
);
4397 CHECK_CHARACTER (c2
);
4399 if (XINT (c1
) == XINT (c2
))
4401 if (NILP (BVAR (current_buffer
, case_fold_search
)))
4405 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
))
4406 && ! ASCII_CHAR_P (i1
))
4408 MAKE_CHAR_MULTIBYTE (i1
);
4411 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
))
4412 && ! ASCII_CHAR_P (i2
))
4414 MAKE_CHAR_MULTIBYTE (i2
);
4416 return (downcase (i1
) == downcase (i2
) ? Qt
: Qnil
);
4419 /* Transpose the markers in two regions of the current buffer, and
4420 adjust the ones between them if necessary (i.e.: if the regions
4423 START1, END1 are the character positions of the first region.
4424 START1_BYTE, END1_BYTE are the byte positions.
4425 START2, END2 are the character positions of the second region.
4426 START2_BYTE, END2_BYTE are the byte positions.
4428 Traverses the entire marker list of the buffer to do so, adding an
4429 appropriate amount to some, subtracting from some, and leaving the
4430 rest untouched. Most of this is copied from adjust_markers in insdel.c.
4432 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
4435 transpose_markers (ptrdiff_t start1
, ptrdiff_t end1
,
4436 ptrdiff_t start2
, ptrdiff_t end2
,
4437 ptrdiff_t start1_byte
, ptrdiff_t end1_byte
,
4438 ptrdiff_t start2_byte
, ptrdiff_t end2_byte
)
4440 register ptrdiff_t amt1
, amt1_byte
, amt2
, amt2_byte
, diff
, diff_byte
, mpos
;
4441 register struct Lisp_Marker
*marker
;
4443 /* Update point as if it were a marker. */
4447 TEMP_SET_PT_BOTH (PT
+ (end2
- end1
),
4448 PT_BYTE
+ (end2_byte
- end1_byte
));
4449 else if (PT
< start2
)
4450 TEMP_SET_PT_BOTH (PT
+ (end2
- start2
) - (end1
- start1
),
4451 (PT_BYTE
+ (end2_byte
- start2_byte
)
4452 - (end1_byte
- start1_byte
)));
4454 TEMP_SET_PT_BOTH (PT
- (start2
- start1
),
4455 PT_BYTE
- (start2_byte
- start1_byte
));
4457 /* We used to adjust the endpoints here to account for the gap, but that
4458 isn't good enough. Even if we assume the caller has tried to move the
4459 gap out of our way, it might still be at start1 exactly, for example;
4460 and that places it `inside' the interval, for our purposes. The amount
4461 of adjustment is nontrivial if there's a `denormalized' marker whose
4462 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
4463 the dirty work to Fmarker_position, below. */
4465 /* The difference between the region's lengths */
4466 diff
= (end2
- start2
) - (end1
- start1
);
4467 diff_byte
= (end2_byte
- start2_byte
) - (end1_byte
- start1_byte
);
4469 /* For shifting each marker in a region by the length of the other
4470 region plus the distance between the regions. */
4471 amt1
= (end2
- start2
) + (start2
- end1
);
4472 amt2
= (end1
- start1
) + (start2
- end1
);
4473 amt1_byte
= (end2_byte
- start2_byte
) + (start2_byte
- end1_byte
);
4474 amt2_byte
= (end1_byte
- start1_byte
) + (start2_byte
- end1_byte
);
4476 for (marker
= BUF_MARKERS (current_buffer
); marker
; marker
= marker
->next
)
4478 mpos
= marker
->bytepos
;
4479 if (mpos
>= start1_byte
&& mpos
< end2_byte
)
4481 if (mpos
< end1_byte
)
4483 else if (mpos
< start2_byte
)
4487 marker
->bytepos
= mpos
;
4489 mpos
= marker
->charpos
;
4490 if (mpos
>= start1
&& mpos
< end2
)
4494 else if (mpos
< start2
)
4499 marker
->charpos
= mpos
;
4503 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
4504 doc
: /* Transpose region STARTR1 to ENDR1 with STARTR2 to ENDR2.
4505 The regions should not be overlapping, because the size of the buffer is
4506 never changed in a transposition.
4508 Optional fifth arg LEAVE-MARKERS, if non-nil, means don't update
4509 any markers that happen to be located in the regions.
4511 Transposing beyond buffer boundaries is an error. */)
4512 (Lisp_Object startr1
, Lisp_Object endr1
, Lisp_Object startr2
, Lisp_Object endr2
, Lisp_Object leave_markers
)
4514 register ptrdiff_t start1
, end1
, start2
, end2
;
4515 ptrdiff_t start1_byte
, start2_byte
, len1_byte
, len2_byte
;
4516 ptrdiff_t gap
, len1
, len_mid
, len2
;
4517 unsigned char *start1_addr
, *start2_addr
, *temp
;
4519 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
, tmp_interval3
;
4522 XSETBUFFER (buf
, current_buffer
);
4523 cur_intv
= BUF_INTERVALS (current_buffer
);
4525 validate_region (&startr1
, &endr1
);
4526 validate_region (&startr2
, &endr2
);
4528 start1
= XFASTINT (startr1
);
4529 end1
= XFASTINT (endr1
);
4530 start2
= XFASTINT (startr2
);
4531 end2
= XFASTINT (endr2
);
4534 /* Swap the regions if they're reversed. */
4537 register ptrdiff_t glumph
= start1
;
4545 len1
= end1
- start1
;
4546 len2
= end2
- start2
;
4549 error ("Transposed regions overlap");
4550 /* Nothing to change for adjacent regions with one being empty */
4551 else if ((start1
== end1
|| start2
== end2
) && end1
== start2
)
4554 /* The possibilities are:
4555 1. Adjacent (contiguous) regions, or separate but equal regions
4556 (no, really equal, in this case!), or
4557 2. Separate regions of unequal size.
4559 The worst case is usually No. 2. It means that (aside from
4560 potential need for getting the gap out of the way), there also
4561 needs to be a shifting of the text between the two regions. So
4562 if they are spread far apart, we are that much slower... sigh. */
4564 /* It must be pointed out that the really studly thing to do would
4565 be not to move the gap at all, but to leave it in place and work
4566 around it if necessary. This would be extremely efficient,
4567 especially considering that people are likely to do
4568 transpositions near where they are working interactively, which
4569 is exactly where the gap would be found. However, such code
4570 would be much harder to write and to read. So, if you are
4571 reading this comment and are feeling squirrely, by all means have
4572 a go! I just didn't feel like doing it, so I will simply move
4573 the gap the minimum distance to get it out of the way, and then
4574 deal with an unbroken array. */
4576 /* Make sure the gap won't interfere, by moving it out of the text
4577 we will operate on. */
4578 if (start1
< gap
&& gap
< end2
)
4580 if (gap
- start1
< end2
- gap
)
4586 start1_byte
= CHAR_TO_BYTE (start1
);
4587 start2_byte
= CHAR_TO_BYTE (start2
);
4588 len1_byte
= CHAR_TO_BYTE (end1
) - start1_byte
;
4589 len2_byte
= CHAR_TO_BYTE (end2
) - start2_byte
;
4591 #ifdef BYTE_COMBINING_DEBUG
4594 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4595 len2_byte
, start1
, start1_byte
)
4596 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4597 len1_byte
, end2
, start2_byte
+ len2_byte
)
4598 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4599 len1_byte
, end2
, start2_byte
+ len2_byte
))
4604 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4605 len2_byte
, start1
, start1_byte
)
4606 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4607 len1_byte
, start2
, start2_byte
)
4608 || count_combining_after (BYTE_POS_ADDR (start2_byte
),
4609 len2_byte
, end1
, start1_byte
+ len1_byte
)
4610 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4611 len1_byte
, end2
, start2_byte
+ len2_byte
))
4616 /* Hmmm... how about checking to see if the gap is large
4617 enough to use as the temporary storage? That would avoid an
4618 allocation... interesting. Later, don't fool with it now. */
4620 /* Working without memmove, for portability (sigh), so must be
4621 careful of overlapping subsections of the array... */
4623 if (end1
== start2
) /* adjacent regions */
4625 modify_region (current_buffer
, start1
, end2
, 0);
4626 record_change (start1
, len1
+ len2
);
4628 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4629 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4630 /* Don't use Fset_text_properties: that can cause GC, which can
4631 clobber objects stored in the tmp_intervals. */
4632 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4633 if (!NULL_INTERVAL_P (tmp_interval3
))
4634 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4636 /* First region smaller than second. */
4637 if (len1_byte
< len2_byte
)
4641 SAFE_ALLOCA (temp
, unsigned char *, len2_byte
);
4643 /* Don't precompute these addresses. We have to compute them
4644 at the last minute, because the relocating allocator might
4645 have moved the buffer around during the xmalloc. */
4646 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4647 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4649 memcpy (temp
, start2_addr
, len2_byte
);
4650 memcpy (start1_addr
+ len2_byte
, start1_addr
, len1_byte
);
4651 memcpy (start1_addr
, temp
, len2_byte
);
4655 /* First region not smaller than second. */
4659 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4660 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4661 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4662 memcpy (temp
, start1_addr
, len1_byte
);
4663 memcpy (start1_addr
, start2_addr
, len2_byte
);
4664 memcpy (start1_addr
+ len2_byte
, temp
, len1_byte
);
4667 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
4668 len1
, current_buffer
, 0);
4669 graft_intervals_into_buffer (tmp_interval2
, start1
,
4670 len2
, current_buffer
, 0);
4671 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4672 update_compositions (start1
+ len2
, end2
, CHECK_TAIL
);
4674 /* Non-adjacent regions, because end1 != start2, bleagh... */
4677 len_mid
= start2_byte
- (start1_byte
+ len1_byte
);
4679 if (len1_byte
== len2_byte
)
4680 /* Regions are same size, though, how nice. */
4684 modify_region (current_buffer
, start1
, end1
, 0);
4685 modify_region (current_buffer
, start2
, end2
, 0);
4686 record_change (start1
, len1
);
4687 record_change (start2
, len2
);
4688 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4689 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4691 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr1
, 0);
4692 if (!NULL_INTERVAL_P (tmp_interval3
))
4693 set_text_properties_1 (startr1
, endr1
, Qnil
, buf
, tmp_interval3
);
4695 tmp_interval3
= validate_interval_range (buf
, &startr2
, &endr2
, 0);
4696 if (!NULL_INTERVAL_P (tmp_interval3
))
4697 set_text_properties_1 (startr2
, endr2
, Qnil
, buf
, tmp_interval3
);
4699 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4700 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4701 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4702 memcpy (temp
, start1_addr
, len1_byte
);
4703 memcpy (start1_addr
, start2_addr
, len2_byte
);
4704 memcpy (start2_addr
, temp
, len1_byte
);
4707 graft_intervals_into_buffer (tmp_interval1
, start2
,
4708 len1
, current_buffer
, 0);
4709 graft_intervals_into_buffer (tmp_interval2
, start1
,
4710 len2
, current_buffer
, 0);
4713 else if (len1_byte
< len2_byte
) /* Second region larger than first */
4714 /* Non-adjacent & unequal size, area between must also be shifted. */
4718 modify_region (current_buffer
, start1
, end2
, 0);
4719 record_change (start1
, (end2
- start1
));
4720 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4721 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4722 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4724 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4725 if (!NULL_INTERVAL_P (tmp_interval3
))
4726 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4728 /* holds region 2 */
4729 SAFE_ALLOCA (temp
, unsigned char *, len2_byte
);
4730 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4731 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4732 memcpy (temp
, start2_addr
, len2_byte
);
4733 memcpy (start1_addr
+ len_mid
+ len2_byte
, start1_addr
, len1_byte
);
4734 memmove (start1_addr
+ len2_byte
, start1_addr
+ len1_byte
, len_mid
);
4735 memcpy (start1_addr
, temp
, len2_byte
);
4738 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4739 len1
, current_buffer
, 0);
4740 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4741 len_mid
, current_buffer
, 0);
4742 graft_intervals_into_buffer (tmp_interval2
, start1
,
4743 len2
, current_buffer
, 0);
4746 /* Second region smaller than first. */
4750 record_change (start1
, (end2
- start1
));
4751 modify_region (current_buffer
, start1
, end2
, 0);
4753 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4754 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4755 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4757 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4758 if (!NULL_INTERVAL_P (tmp_interval3
))
4759 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4761 /* holds region 1 */
4762 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4763 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4764 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4765 memcpy (temp
, start1_addr
, len1_byte
);
4766 memcpy (start1_addr
, start2_addr
, len2_byte
);
4767 memcpy (start1_addr
+ len2_byte
, start1_addr
+ len1_byte
, len_mid
);
4768 memcpy (start1_addr
+ len2_byte
+ len_mid
, temp
, len1_byte
);
4771 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4772 len1
, current_buffer
, 0);
4773 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4774 len_mid
, current_buffer
, 0);
4775 graft_intervals_into_buffer (tmp_interval2
, start1
,
4776 len2
, current_buffer
, 0);
4779 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4780 update_compositions (end2
- len1
, end2
, CHECK_BORDER
);
4783 /* When doing multiple transpositions, it might be nice
4784 to optimize this. Perhaps the markers in any one buffer
4785 should be organized in some sorted data tree. */
4786 if (NILP (leave_markers
))
4788 transpose_markers (start1
, end1
, start2
, end2
,
4789 start1_byte
, start1_byte
+ len1_byte
,
4790 start2_byte
, start2_byte
+ len2_byte
);
4791 fix_start_end_in_overlays (start1
, end2
);
4794 signal_after_change (start1
, end2
- start1
, end2
- start1
);
4800 syms_of_editfns (void)
4805 DEFSYM (Qbuffer_access_fontify_functions
, "buffer-access-fontify-functions");
4807 DEFVAR_LISP ("inhibit-field-text-motion", Vinhibit_field_text_motion
,
4808 doc
: /* Non-nil means text motion commands don't notice fields. */);
4809 Vinhibit_field_text_motion
= Qnil
;
4811 DEFVAR_LISP ("buffer-access-fontify-functions",
4812 Vbuffer_access_fontify_functions
,
4813 doc
: /* List of functions called by `buffer-substring' to fontify if necessary.
4814 Each function is called with two arguments which specify the range
4815 of the buffer being accessed. */);
4816 Vbuffer_access_fontify_functions
= Qnil
;
4820 obuf
= Fcurrent_buffer ();
4821 /* Do this here, because init_buffer_once is too early--it won't work. */
4822 Fset_buffer (Vprin1_to_string_buffer
);
4823 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
4824 Fset (Fmake_local_variable (intern_c_string ("buffer-access-fontify-functions")),
4829 DEFVAR_LISP ("buffer-access-fontified-property",
4830 Vbuffer_access_fontified_property
,
4831 doc
: /* Property which (if non-nil) indicates text has been fontified.
4832 `buffer-substring' need not call the `buffer-access-fontify-functions'
4833 functions if all the text being accessed has this property. */);
4834 Vbuffer_access_fontified_property
= Qnil
;
4836 DEFVAR_LISP ("system-name", Vsystem_name
,
4837 doc
: /* The host name of the machine Emacs is running on. */);
4839 DEFVAR_LISP ("user-full-name", Vuser_full_name
,
4840 doc
: /* The full name of the user logged in. */);
4842 DEFVAR_LISP ("user-login-name", Vuser_login_name
,
4843 doc
: /* The user's name, taken from environment variables if possible. */);
4845 DEFVAR_LISP ("user-real-login-name", Vuser_real_login_name
,
4846 doc
: /* The user's name, based upon the real uid only. */);
4848 DEFVAR_LISP ("operating-system-release", Voperating_system_release
,
4849 doc
: /* The release of the operating system Emacs is running on. */);
4851 defsubr (&Spropertize
);
4852 defsubr (&Schar_equal
);
4853 defsubr (&Sgoto_char
);
4854 defsubr (&Sstring_to_char
);
4855 defsubr (&Schar_to_string
);
4856 defsubr (&Sbyte_to_string
);
4857 defsubr (&Sbuffer_substring
);
4858 defsubr (&Sbuffer_substring_no_properties
);
4859 defsubr (&Sbuffer_string
);
4861 defsubr (&Spoint_marker
);
4862 defsubr (&Smark_marker
);
4864 defsubr (&Sregion_beginning
);
4865 defsubr (&Sregion_end
);
4867 DEFSYM (Qfield
, "field");
4868 DEFSYM (Qboundary
, "boundary");
4869 defsubr (&Sfield_beginning
);
4870 defsubr (&Sfield_end
);
4871 defsubr (&Sfield_string
);
4872 defsubr (&Sfield_string_no_properties
);
4873 defsubr (&Sdelete_field
);
4874 defsubr (&Sconstrain_to_field
);
4876 defsubr (&Sline_beginning_position
);
4877 defsubr (&Sline_end_position
);
4879 /* defsubr (&Smark); */
4880 /* defsubr (&Sset_mark); */
4881 defsubr (&Ssave_excursion
);
4882 defsubr (&Ssave_current_buffer
);
4884 defsubr (&Sbufsize
);
4885 defsubr (&Spoint_max
);
4886 defsubr (&Spoint_min
);
4887 defsubr (&Spoint_min_marker
);
4888 defsubr (&Spoint_max_marker
);
4889 defsubr (&Sgap_position
);
4890 defsubr (&Sgap_size
);
4891 defsubr (&Sposition_bytes
);
4892 defsubr (&Sbyte_to_position
);
4898 defsubr (&Sfollowing_char
);
4899 defsubr (&Sprevious_char
);
4900 defsubr (&Schar_after
);
4901 defsubr (&Schar_before
);
4903 defsubr (&Sinsert_before_markers
);
4904 defsubr (&Sinsert_and_inherit
);
4905 defsubr (&Sinsert_and_inherit_before_markers
);
4906 defsubr (&Sinsert_char
);
4907 defsubr (&Sinsert_byte
);
4909 defsubr (&Suser_login_name
);
4910 defsubr (&Suser_real_login_name
);
4911 defsubr (&Suser_uid
);
4912 defsubr (&Suser_real_uid
);
4913 defsubr (&Suser_full_name
);
4914 defsubr (&Semacs_pid
);
4915 defsubr (&Scurrent_time
);
4916 defsubr (&Sget_internal_run_time
);
4917 defsubr (&Sformat_time_string
);
4918 defsubr (&Sfloat_time
);
4919 defsubr (&Sdecode_time
);
4920 defsubr (&Sencode_time
);
4921 defsubr (&Scurrent_time_string
);
4922 defsubr (&Scurrent_time_zone
);
4923 defsubr (&Sset_time_zone_rule
);
4924 defsubr (&Ssystem_name
);
4925 defsubr (&Smessage
);
4926 defsubr (&Smessage_box
);
4927 defsubr (&Smessage_or_box
);
4928 defsubr (&Scurrent_message
);
4931 defsubr (&Sinsert_buffer_substring
);
4932 defsubr (&Scompare_buffer_substrings
);
4933 defsubr (&Ssubst_char_in_region
);
4934 defsubr (&Stranslate_region_internal
);
4935 defsubr (&Sdelete_region
);
4936 defsubr (&Sdelete_and_extract_region
);
4938 defsubr (&Snarrow_to_region
);
4939 defsubr (&Ssave_restriction
);
4940 defsubr (&Stranspose_regions
);