1 /* Lisp functions pertaining to editing.
3 Copyright (C) 1985-1987, 1989, 1993-2011 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>
52 #include "intervals.h"
54 #include "character.h"
58 #include "blockinput.h"
62 #define MAX_10_EXP DBL_MAX_10_EXP
64 #define MAX_10_EXP 310
71 #ifndef USER_FULL_NAME
72 #define USER_FULL_NAME pw->pw_gecos
76 extern char **environ
;
79 #define TM_YEAR_BASE 1900
81 /* Nonzero if TM_YEAR is a struct tm's tm_year value that causes
82 asctime to have well-defined behavior. */
83 #ifndef TM_YEAR_IN_ASCTIME_RANGE
84 # define TM_YEAR_IN_ASCTIME_RANGE(tm_year) \
85 (1000 - TM_YEAR_BASE <= (tm_year) && (tm_year) <= 9999 - TM_YEAR_BASE)
89 extern Lisp_Object
w32_get_internal_run_time (void);
92 static void time_overflow (void) NO_RETURN
;
93 static int tm_diff (struct tm
*, struct tm
*);
94 static void find_field (Lisp_Object
, Lisp_Object
, Lisp_Object
,
95 EMACS_INT
*, Lisp_Object
, EMACS_INT
*);
96 static void update_buffer_properties (EMACS_INT
, EMACS_INT
);
97 static Lisp_Object
region_limit (int);
98 static size_t emacs_nmemftime (char *, size_t, const char *,
99 size_t, const struct tm
*, int, int);
100 static void general_insert_function (void (*) (const char *, EMACS_INT
),
101 void (*) (Lisp_Object
, EMACS_INT
,
102 EMACS_INT
, EMACS_INT
,
104 int, int, Lisp_Object
*);
105 static Lisp_Object
subst_char_in_region_unwind (Lisp_Object
);
106 static Lisp_Object
subst_char_in_region_unwind_1 (Lisp_Object
);
107 static void transpose_markers (EMACS_INT
, EMACS_INT
, EMACS_INT
, EMACS_INT
,
108 EMACS_INT
, EMACS_INT
, EMACS_INT
, EMACS_INT
);
110 Lisp_Object Qbuffer_access_fontify_functions
;
111 Lisp_Object
Fuser_full_name (Lisp_Object
);
113 /* Symbol for the text property used to mark fields. */
117 /* A special value for Qfield properties. */
119 Lisp_Object Qboundary
;
125 const char *user_name
;
127 struct passwd
*pw
; /* password entry for the current user */
130 /* Set up system_name even when dumping. */
134 /* Don't bother with this on initial start when just dumping out */
137 #endif /* not CANNOT_DUMP */
139 pw
= getpwuid (getuid ());
141 /* We let the real user name default to "root" because that's quite
142 accurate on MSDOG and because it lets Emacs find the init file.
143 (The DVX libraries override the Djgpp libraries here.) */
144 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "root");
146 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "unknown");
149 /* Get the effective user name, by consulting environment variables,
150 or the effective uid if those are unset. */
151 user_name
= getenv ("LOGNAME");
154 user_name
= getenv ("USERNAME"); /* it's USERNAME on NT */
155 #else /* WINDOWSNT */
156 user_name
= getenv ("USER");
157 #endif /* WINDOWSNT */
160 pw
= getpwuid (geteuid ());
161 user_name
= pw
? pw
->pw_name
: "unknown";
163 Vuser_login_name
= build_string (user_name
);
165 /* If the user name claimed in the environment vars differs from
166 the real uid, use the claimed name to find the full name. */
167 tem
= Fstring_equal (Vuser_login_name
, Vuser_real_login_name
);
168 Vuser_full_name
= Fuser_full_name (NILP (tem
)? make_number (geteuid())
173 Vuser_full_name
= build_string (p
);
174 else if (NILP (Vuser_full_name
))
175 Vuser_full_name
= build_string ("unknown");
177 #ifdef HAVE_SYS_UTSNAME_H
181 Voperating_system_release
= build_string (uts
.release
);
184 Voperating_system_release
= Qnil
;
188 DEFUN ("char-to-string", Fchar_to_string
, Schar_to_string
, 1, 1, 0,
189 doc
: /* Convert arg CHAR to a string containing that character.
190 usage: (char-to-string CHAR) */)
191 (Lisp_Object character
)
194 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
196 CHECK_CHARACTER (character
);
198 len
= CHAR_STRING (XFASTINT (character
), str
);
199 return make_string_from_bytes ((char *) str
, 1, len
);
202 DEFUN ("byte-to-string", Fbyte_to_string
, Sbyte_to_string
, 1, 1, 0,
203 doc
: /* Convert arg BYTE to a unibyte string containing that byte. */)
208 if (XINT (byte
) < 0 || XINT (byte
) > 255)
209 error ("Invalid byte");
211 return make_string_from_bytes ((char *) &b
, 1, 1);
214 DEFUN ("string-to-char", Fstring_to_char
, Sstring_to_char
, 1, 1, 0,
215 doc
: /* Convert arg STRING to a character, the first character of that string.
216 A multibyte character is handled correctly. */)
217 (register Lisp_Object string
)
219 register Lisp_Object val
;
220 CHECK_STRING (string
);
223 if (STRING_MULTIBYTE (string
))
224 XSETFASTINT (val
, STRING_CHAR (SDATA (string
)));
226 XSETFASTINT (val
, SREF (string
, 0));
229 XSETFASTINT (val
, 0);
234 buildmark (EMACS_INT charpos
, EMACS_INT bytepos
)
236 register Lisp_Object mark
;
237 mark
= Fmake_marker ();
238 set_marker_both (mark
, Qnil
, charpos
, bytepos
);
242 DEFUN ("point", Fpoint
, Spoint
, 0, 0, 0,
243 doc
: /* Return value of point, as an integer.
244 Beginning of buffer is position (point-min). */)
248 XSETFASTINT (temp
, PT
);
252 DEFUN ("point-marker", Fpoint_marker
, Spoint_marker
, 0, 0, 0,
253 doc
: /* Return value of point, as a marker object. */)
256 return buildmark (PT
, PT_BYTE
);
260 clip_to_bounds (EMACS_INT lower
, EMACS_INT num
, EMACS_INT upper
)
264 else if (num
> upper
)
270 DEFUN ("goto-char", Fgoto_char
, Sgoto_char
, 1, 1, "NGoto char: ",
271 doc
: /* Set point to POSITION, a number or marker.
272 Beginning of buffer is position (point-min), end is (point-max).
274 The return value is POSITION. */)
275 (register Lisp_Object position
)
279 if (MARKERP (position
)
280 && current_buffer
== XMARKER (position
)->buffer
)
282 pos
= marker_position (position
);
284 SET_PT_BOTH (BEGV
, BEGV_BYTE
);
286 SET_PT_BOTH (ZV
, ZV_BYTE
);
288 SET_PT_BOTH (pos
, marker_byte_position (position
));
293 CHECK_NUMBER_COERCE_MARKER (position
);
295 pos
= clip_to_bounds (BEGV
, XINT (position
), ZV
);
301 /* Return the start or end position of the region.
302 BEGINNINGP non-zero means return the start.
303 If there is no region active, signal an error. */
306 region_limit (int beginningp
)
310 if (!NILP (Vtransient_mark_mode
)
311 && NILP (Vmark_even_if_inactive
)
312 && NILP (BVAR (current_buffer
, mark_active
)))
313 xsignal0 (Qmark_inactive
);
315 m
= Fmarker_position (BVAR (current_buffer
, mark
));
317 error ("The mark is not set now, so there is no region");
319 if ((PT
< XFASTINT (m
)) == (beginningp
!= 0))
320 m
= make_number (PT
);
324 DEFUN ("region-beginning", Fregion_beginning
, Sregion_beginning
, 0, 0, 0,
325 doc
: /* Return the integer value of point or mark, whichever is smaller. */)
328 return region_limit (1);
331 DEFUN ("region-end", Fregion_end
, Sregion_end
, 0, 0, 0,
332 doc
: /* Return the integer value of point or mark, whichever is larger. */)
335 return region_limit (0);
338 DEFUN ("mark-marker", Fmark_marker
, Smark_marker
, 0, 0, 0,
339 doc
: /* Return this buffer's mark, as a marker object.
340 Watch out! Moving this marker changes the mark position.
341 If you set the marker not to point anywhere, the buffer will have no mark. */)
344 return BVAR (current_buffer
, mark
);
348 /* Find all the overlays in the current buffer that touch position POS.
349 Return the number found, and store them in a vector in VEC
353 overlays_around (EMACS_INT pos
, Lisp_Object
*vec
, int len
)
355 Lisp_Object overlay
, start
, end
;
356 struct Lisp_Overlay
*tail
;
357 EMACS_INT startpos
, endpos
;
360 for (tail
= current_buffer
->overlays_before
; tail
; tail
= tail
->next
)
362 XSETMISC (overlay
, tail
);
364 end
= OVERLAY_END (overlay
);
365 endpos
= OVERLAY_POSITION (end
);
368 start
= OVERLAY_START (overlay
);
369 startpos
= OVERLAY_POSITION (start
);
374 /* Keep counting overlays even if we can't return them all. */
379 for (tail
= current_buffer
->overlays_after
; tail
; tail
= tail
->next
)
381 XSETMISC (overlay
, tail
);
383 start
= OVERLAY_START (overlay
);
384 startpos
= OVERLAY_POSITION (start
);
387 end
= OVERLAY_END (overlay
);
388 endpos
= OVERLAY_POSITION (end
);
400 /* Return the value of property PROP, in OBJECT at POSITION.
401 It's the value of PROP that a char inserted at POSITION would get.
402 OBJECT is optional and defaults to the current buffer.
403 If OBJECT is a buffer, then overlay properties are considered as well as
405 If OBJECT is a window, then that window's buffer is used, but
406 window-specific overlays are considered only if they are associated
409 get_pos_property (Lisp_Object position
, register Lisp_Object prop
, Lisp_Object object
)
411 CHECK_NUMBER_COERCE_MARKER (position
);
414 XSETBUFFER (object
, current_buffer
);
415 else if (WINDOWP (object
))
416 object
= XWINDOW (object
)->buffer
;
418 if (!BUFFERP (object
))
419 /* pos-property only makes sense in buffers right now, since strings
420 have no overlays and no notion of insertion for which stickiness
422 return Fget_text_property (position
, prop
, object
);
425 EMACS_INT posn
= XINT (position
);
427 Lisp_Object
*overlay_vec
, tem
;
428 struct buffer
*obuf
= current_buffer
;
430 set_buffer_temp (XBUFFER (object
));
432 /* First try with room for 40 overlays. */
434 overlay_vec
= (Lisp_Object
*) alloca (noverlays
* sizeof (Lisp_Object
));
435 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
437 /* If there are more than 40,
438 make enough space for all, and try again. */
441 overlay_vec
= (Lisp_Object
*) alloca (noverlays
* sizeof (Lisp_Object
));
442 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
444 noverlays
= sort_overlays (overlay_vec
, noverlays
, NULL
);
446 set_buffer_temp (obuf
);
448 /* Now check the overlays in order of decreasing priority. */
449 while (--noverlays
>= 0)
451 Lisp_Object ol
= overlay_vec
[noverlays
];
452 tem
= Foverlay_get (ol
, prop
);
455 /* Check the overlay is indeed active at point. */
456 Lisp_Object start
= OVERLAY_START (ol
), finish
= OVERLAY_END (ol
);
457 if ((OVERLAY_POSITION (start
) == posn
458 && XMARKER (start
)->insertion_type
== 1)
459 || (OVERLAY_POSITION (finish
) == posn
460 && XMARKER (finish
)->insertion_type
== 0))
461 ; /* The overlay will not cover a char inserted at point. */
469 { /* Now check the text properties. */
470 int stickiness
= text_property_stickiness (prop
, position
, object
);
472 return Fget_text_property (position
, prop
, object
);
473 else if (stickiness
< 0
474 && XINT (position
) > BUF_BEGV (XBUFFER (object
)))
475 return Fget_text_property (make_number (XINT (position
) - 1),
483 /* Find the field surrounding POS in *BEG and *END. If POS is nil,
484 the value of point is used instead. If BEG or END is null,
485 means don't store the beginning or end of the field.
487 BEG_LIMIT and END_LIMIT serve to limit the ranged of the returned
488 results; they do not effect boundary behavior.
490 If MERGE_AT_BOUNDARY is nonzero, then if POS is at the very first
491 position of a field, then the beginning of the previous field is
492 returned instead of the beginning of POS's field (since the end of a
493 field is actually also the beginning of the next input field, this
494 behavior is sometimes useful). Additionally in the MERGE_AT_BOUNDARY
495 true case, if two fields are separated by a field with the special
496 value `boundary', and POS lies within it, then the two separated
497 fields are considered to be adjacent, and POS between them, when
498 finding the beginning and ending of the "merged" field.
500 Either BEG or END may be 0, in which case the corresponding value
504 find_field (Lisp_Object pos
, Lisp_Object merge_at_boundary
,
505 Lisp_Object beg_limit
,
506 EMACS_INT
*beg
, Lisp_Object end_limit
, EMACS_INT
*end
)
508 /* Fields right before and after the point. */
509 Lisp_Object before_field
, after_field
;
510 /* 1 if POS counts as the start of a field. */
511 int at_field_start
= 0;
512 /* 1 if POS counts as the end of a field. */
513 int at_field_end
= 0;
516 XSETFASTINT (pos
, PT
);
518 CHECK_NUMBER_COERCE_MARKER (pos
);
521 = get_char_property_and_overlay (pos
, Qfield
, Qnil
, NULL
);
523 = (XFASTINT (pos
) > BEGV
524 ? get_char_property_and_overlay (make_number (XINT (pos
) - 1),
526 /* Using nil here would be a more obvious choice, but it would
527 fail when the buffer starts with a non-sticky field. */
530 /* See if we need to handle the case where MERGE_AT_BOUNDARY is nil
531 and POS is at beginning of a field, which can also be interpreted
532 as the end of the previous field. Note that the case where if
533 MERGE_AT_BOUNDARY is non-nil (see function comment) is actually the
534 more natural one; then we avoid treating the beginning of a field
536 if (NILP (merge_at_boundary
))
538 Lisp_Object field
= get_pos_property (pos
, Qfield
, Qnil
);
539 if (!EQ (field
, after_field
))
541 if (!EQ (field
, before_field
))
543 if (NILP (field
) && at_field_start
&& at_field_end
)
544 /* If an inserted char would have a nil field while the surrounding
545 text is non-nil, we're probably not looking at a
546 zero-length field, but instead at a non-nil field that's
547 not intended for editing (such as comint's prompts). */
548 at_field_end
= at_field_start
= 0;
551 /* Note about special `boundary' fields:
553 Consider the case where the point (`.') is between the fields `x' and `y':
557 In this situation, if merge_at_boundary is true, we consider the
558 `x' and `y' fields as forming one big merged field, and so the end
559 of the field is the end of `y'.
561 However, if `x' and `y' are separated by a special `boundary' field
562 (a field with a `field' char-property of 'boundary), then we ignore
563 this special field when merging adjacent fields. Here's the same
564 situation, but with a `boundary' field between the `x' and `y' fields:
568 Here, if point is at the end of `x', the beginning of `y', or
569 anywhere in-between (within the `boundary' field), we merge all
570 three fields and consider the beginning as being the beginning of
571 the `x' field, and the end as being the end of the `y' field. */
576 /* POS is at the edge of a field, and we should consider it as
577 the beginning of the following field. */
578 *beg
= XFASTINT (pos
);
580 /* Find the previous field boundary. */
583 if (!NILP (merge_at_boundary
) && EQ (before_field
, Qboundary
))
584 /* Skip a `boundary' field. */
585 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
588 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
590 *beg
= NILP (p
) ? BEGV
: XFASTINT (p
);
597 /* POS is at the edge of a field, and we should consider it as
598 the end of the previous field. */
599 *end
= XFASTINT (pos
);
601 /* Find the next field boundary. */
603 if (!NILP (merge_at_boundary
) && EQ (after_field
, Qboundary
))
604 /* Skip a `boundary' field. */
605 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
608 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
610 *end
= NILP (pos
) ? ZV
: XFASTINT (pos
);
616 DEFUN ("delete-field", Fdelete_field
, Sdelete_field
, 0, 1, 0,
617 doc
: /* Delete the field surrounding POS.
618 A field is a region of text with the same `field' property.
619 If POS is nil, the value of point is used for POS. */)
623 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
625 del_range (beg
, end
);
629 DEFUN ("field-string", Ffield_string
, Sfield_string
, 0, 1, 0,
630 doc
: /* Return the contents of the field surrounding POS as a string.
631 A field is a region of text with the same `field' property.
632 If POS is nil, the value of point is used for POS. */)
636 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
637 return make_buffer_string (beg
, end
, 1);
640 DEFUN ("field-string-no-properties", Ffield_string_no_properties
, Sfield_string_no_properties
, 0, 1, 0,
641 doc
: /* Return the contents of the field around POS, without text properties.
642 A field is a region of text with the same `field' property.
643 If POS is nil, the value of point is used for POS. */)
647 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
648 return make_buffer_string (beg
, end
, 0);
651 DEFUN ("field-beginning", Ffield_beginning
, Sfield_beginning
, 0, 3, 0,
652 doc
: /* Return the beginning of the field surrounding POS.
653 A field is a region of text with the same `field' property.
654 If POS is nil, the value of point is used for POS.
655 If ESCAPE-FROM-EDGE is non-nil and POS is at the beginning of its
656 field, then the beginning of the *previous* field is returned.
657 If LIMIT is non-nil, it is a buffer position; if the beginning of the field
658 is before LIMIT, then LIMIT will be returned instead. */)
659 (Lisp_Object pos
, Lisp_Object escape_from_edge
, Lisp_Object limit
)
662 find_field (pos
, escape_from_edge
, limit
, &beg
, Qnil
, 0);
663 return make_number (beg
);
666 DEFUN ("field-end", Ffield_end
, Sfield_end
, 0, 3, 0,
667 doc
: /* Return the end of the field surrounding POS.
668 A field is a region of text with the same `field' property.
669 If POS is nil, the value of point is used for POS.
670 If ESCAPE-FROM-EDGE is non-nil and POS is at the end of its field,
671 then the end of the *following* field is returned.
672 If LIMIT is non-nil, it is a buffer position; if the end of the field
673 is after LIMIT, then LIMIT will be returned instead. */)
674 (Lisp_Object pos
, Lisp_Object escape_from_edge
, Lisp_Object limit
)
677 find_field (pos
, escape_from_edge
, Qnil
, 0, limit
, &end
);
678 return make_number (end
);
681 DEFUN ("constrain-to-field", Fconstrain_to_field
, Sconstrain_to_field
, 2, 5, 0,
682 doc
: /* Return the position closest to NEW-POS that is in the same field as OLD-POS.
684 A field is a region of text with the same `field' property.
685 If NEW-POS is nil, then the current point is used instead, and set to the
686 constrained position if that is different.
688 If OLD-POS is at the boundary of two fields, then the allowable
689 positions for NEW-POS depends on the value of the optional argument
690 ESCAPE-FROM-EDGE: If ESCAPE-FROM-EDGE is nil, then NEW-POS is
691 constrained to the field that has the same `field' char-property
692 as any new characters inserted at OLD-POS, whereas if ESCAPE-FROM-EDGE
693 is non-nil, NEW-POS is constrained to the union of the two adjacent
694 fields. Additionally, if two fields are separated by another field with
695 the special value `boundary', then any point within this special field is
696 also considered to be `on the boundary'.
698 If the optional argument ONLY-IN-LINE is non-nil and constraining
699 NEW-POS would move it to a different line, NEW-POS is returned
700 unconstrained. This useful for commands that move by line, like
701 \\[next-line] or \\[beginning-of-line], which should generally respect field boundaries
702 only in the case where they can still move to the right line.
704 If the optional argument INHIBIT-CAPTURE-PROPERTY is non-nil, and OLD-POS has
705 a non-nil property of that name, then any field boundaries are ignored.
707 Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */)
708 (Lisp_Object new_pos
, Lisp_Object old_pos
, Lisp_Object escape_from_edge
, Lisp_Object only_in_line
, Lisp_Object inhibit_capture_property
)
710 /* If non-zero, then the original point, before re-positioning. */
711 EMACS_INT orig_point
= 0;
713 Lisp_Object prev_old
, prev_new
;
716 /* Use the current point, and afterwards, set it. */
719 XSETFASTINT (new_pos
, PT
);
722 CHECK_NUMBER_COERCE_MARKER (new_pos
);
723 CHECK_NUMBER_COERCE_MARKER (old_pos
);
725 fwd
= (XFASTINT (new_pos
) > XFASTINT (old_pos
));
727 prev_old
= make_number (XFASTINT (old_pos
) - 1);
728 prev_new
= make_number (XFASTINT (new_pos
) - 1);
730 if (NILP (Vinhibit_field_text_motion
)
731 && !EQ (new_pos
, old_pos
)
732 && (!NILP (Fget_char_property (new_pos
, Qfield
, Qnil
))
733 || !NILP (Fget_char_property (old_pos
, Qfield
, Qnil
))
734 /* To recognize field boundaries, we must also look at the
735 previous positions; we could use `get_pos_property'
736 instead, but in itself that would fail inside non-sticky
737 fields (like comint prompts). */
738 || (XFASTINT (new_pos
) > BEGV
739 && !NILP (Fget_char_property (prev_new
, Qfield
, Qnil
)))
740 || (XFASTINT (old_pos
) > BEGV
741 && !NILP (Fget_char_property (prev_old
, Qfield
, Qnil
))))
742 && (NILP (inhibit_capture_property
)
743 /* Field boundaries are again a problem; but now we must
744 decide the case exactly, so we need to call
745 `get_pos_property' as well. */
746 || (NILP (get_pos_property (old_pos
, inhibit_capture_property
, Qnil
))
747 && (XFASTINT (old_pos
) <= BEGV
748 || NILP (Fget_char_property (old_pos
, inhibit_capture_property
, Qnil
))
749 || NILP (Fget_char_property (prev_old
, inhibit_capture_property
, Qnil
))))))
750 /* It is possible that NEW_POS is not within the same field as
751 OLD_POS; try to move NEW_POS so that it is. */
754 Lisp_Object field_bound
;
757 field_bound
= Ffield_end (old_pos
, escape_from_edge
, new_pos
);
759 field_bound
= Ffield_beginning (old_pos
, escape_from_edge
, new_pos
);
761 if (/* See if ESCAPE_FROM_EDGE caused FIELD_BOUND to jump to the
762 other side of NEW_POS, which would mean that NEW_POS is
763 already acceptable, and it's not necessary to constrain it
765 ((XFASTINT (field_bound
) < XFASTINT (new_pos
)) ? fwd
: !fwd
)
766 /* NEW_POS should be constrained, but only if either
767 ONLY_IN_LINE is nil (in which case any constraint is OK),
768 or NEW_POS and FIELD_BOUND are on the same line (in which
769 case the constraint is OK even if ONLY_IN_LINE is non-nil). */
770 && (NILP (only_in_line
)
771 /* This is the ONLY_IN_LINE case, check that NEW_POS and
772 FIELD_BOUND are on the same line by seeing whether
773 there's an intervening newline or not. */
774 || (scan_buffer ('\n',
775 XFASTINT (new_pos
), XFASTINT (field_bound
),
776 fwd
? -1 : 1, &shortage
, 1),
778 /* Constrain NEW_POS to FIELD_BOUND. */
779 new_pos
= field_bound
;
781 if (orig_point
&& XFASTINT (new_pos
) != orig_point
)
782 /* The NEW_POS argument was originally nil, so automatically set PT. */
783 SET_PT (XFASTINT (new_pos
));
790 DEFUN ("line-beginning-position",
791 Fline_beginning_position
, Sline_beginning_position
, 0, 1, 0,
792 doc
: /* Return the character position of the first character on the current line.
793 With argument N not nil or 1, move forward N - 1 lines first.
794 If scan reaches end of buffer, return that position.
796 The returned position is of the first character in the logical order,
797 i.e. the one that has the smallest character position.
799 This function constrains the returned position to the current field
800 unless that would be on a different line than the original,
801 unconstrained result. If N is nil or 1, and a front-sticky field
802 starts at point, the scan stops as soon as it starts. To ignore field
803 boundaries bind `inhibit-field-text-motion' to t.
805 This function does not move point. */)
808 EMACS_INT orig
, orig_byte
, end
;
809 int count
= SPECPDL_INDEX ();
810 specbind (Qinhibit_point_motion_hooks
, Qt
);
819 Fforward_line (make_number (XINT (n
) - 1));
822 SET_PT_BOTH (orig
, orig_byte
);
824 unbind_to (count
, Qnil
);
826 /* Return END constrained to the current input field. */
827 return Fconstrain_to_field (make_number (end
), make_number (orig
),
828 XINT (n
) != 1 ? Qt
: Qnil
,
832 DEFUN ("line-end-position", Fline_end_position
, Sline_end_position
, 0, 1, 0,
833 doc
: /* Return the character position of the last character on the current line.
834 With argument N not nil or 1, move forward N - 1 lines first.
835 If scan reaches end of buffer, return that position.
837 The returned position is of the last character in the logical order,
838 i.e. the character whose buffer position is the largest one.
840 This function constrains the returned position to the current field
841 unless that would be on a different line than the original,
842 unconstrained result. If N is nil or 1, and a rear-sticky field ends
843 at point, the scan stops as soon as it starts. To ignore field
844 boundaries bind `inhibit-field-text-motion' to t.
846 This function does not move point. */)
857 end_pos
= find_before_next_newline (orig
, 0, XINT (n
) - (XINT (n
) <= 0));
859 /* Return END_POS constrained to the current input field. */
860 return Fconstrain_to_field (make_number (end_pos
), make_number (orig
),
866 save_excursion_save (void)
868 int visible
= (XBUFFER (XWINDOW (selected_window
)->buffer
)
871 return Fcons (Fpoint_marker (),
872 Fcons (Fcopy_marker (BVAR (current_buffer
, mark
), Qnil
),
873 Fcons (visible
? Qt
: Qnil
,
874 Fcons (BVAR (current_buffer
, mark_active
),
879 save_excursion_restore (Lisp_Object info
)
881 Lisp_Object tem
, tem1
, omark
, nmark
;
882 struct gcpro gcpro1
, gcpro2
, gcpro3
;
885 tem
= Fmarker_buffer (XCAR (info
));
886 /* If buffer being returned to is now deleted, avoid error */
887 /* Otherwise could get error here while unwinding to top level
889 /* In that case, Fmarker_buffer returns nil now. */
893 omark
= nmark
= Qnil
;
894 GCPRO3 (info
, omark
, nmark
);
901 unchain_marker (XMARKER (tem
));
906 omark
= Fmarker_position (BVAR (current_buffer
, mark
));
907 Fset_marker (BVAR (current_buffer
, mark
), tem
, Fcurrent_buffer ());
908 nmark
= Fmarker_position (tem
);
909 unchain_marker (XMARKER (tem
));
913 visible_p
= !NILP (XCAR (info
));
915 #if 0 /* We used to make the current buffer visible in the selected window
916 if that was true previously. That avoids some anomalies.
917 But it creates others, and it wasn't documented, and it is simpler
918 and cleaner never to alter the window/buffer connections. */
921 && current_buffer
!= XBUFFER (XWINDOW (selected_window
)->buffer
))
922 Fswitch_to_buffer (Fcurrent_buffer (), Qnil
);
928 tem1
= BVAR (current_buffer
, mark_active
);
929 BVAR (current_buffer
, mark_active
) = tem
;
931 if (!NILP (Vrun_hooks
))
933 /* If mark is active now, and either was not active
934 or was at a different place, run the activate hook. */
935 if (! NILP (BVAR (current_buffer
, mark_active
)))
937 if (! EQ (omark
, nmark
))
938 call1 (Vrun_hooks
, intern ("activate-mark-hook"));
940 /* If mark has ceased to be active, run deactivate hook. */
941 else if (! NILP (tem1
))
942 call1 (Vrun_hooks
, intern ("deactivate-mark-hook"));
945 /* If buffer was visible in a window, and a different window was
946 selected, and the old selected window is still showing this
947 buffer, restore point in that window. */
950 && !EQ (tem
, selected_window
)
951 && (tem1
= XWINDOW (tem
)->buffer
,
952 (/* Window is live... */
954 /* ...and it shows the current buffer. */
955 && XBUFFER (tem1
) == current_buffer
)))
956 Fset_window_point (tem
, make_number (PT
));
962 DEFUN ("save-excursion", Fsave_excursion
, Ssave_excursion
, 0, UNEVALLED
, 0,
963 doc
: /* Save point, mark, and current buffer; execute BODY; restore those things.
964 Executes BODY just like `progn'.
965 The values of point, mark and the current buffer are restored
966 even in case of abnormal exit (throw or error).
967 The state of activation of the mark is also restored.
969 This construct does not save `deactivate-mark', and therefore
970 functions that change the buffer will still cause deactivation
971 of the mark at the end of the command. To prevent that, bind
972 `deactivate-mark' with `let'.
974 If you only want to save the current buffer but not point nor mark,
975 then just use `save-current-buffer', or even `with-current-buffer'.
977 usage: (save-excursion &rest BODY) */)
980 register Lisp_Object val
;
981 int count
= SPECPDL_INDEX ();
983 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
986 return unbind_to (count
, val
);
989 DEFUN ("save-current-buffer", Fsave_current_buffer
, Ssave_current_buffer
, 0, UNEVALLED
, 0,
990 doc
: /* Save the current buffer; execute BODY; restore the current buffer.
991 Executes BODY just like `progn'.
992 usage: (save-current-buffer &rest BODY) */)
996 int count
= SPECPDL_INDEX ();
998 record_unwind_protect (set_buffer_if_live
, Fcurrent_buffer ());
1000 val
= Fprogn (args
);
1001 return unbind_to (count
, val
);
1004 DEFUN ("buffer-size", Fbufsize
, Sbufsize
, 0, 1, 0,
1005 doc
: /* Return the number of characters in the current buffer.
1006 If BUFFER, return the number of characters in that buffer instead. */)
1007 (Lisp_Object buffer
)
1010 return make_number (Z
- BEG
);
1013 CHECK_BUFFER (buffer
);
1014 return make_number (BUF_Z (XBUFFER (buffer
))
1015 - BUF_BEG (XBUFFER (buffer
)));
1019 DEFUN ("point-min", Fpoint_min
, Spoint_min
, 0, 0, 0,
1020 doc
: /* Return the minimum permissible value of point in the current buffer.
1021 This is 1, unless narrowing (a buffer restriction) is in effect. */)
1025 XSETFASTINT (temp
, BEGV
);
1029 DEFUN ("point-min-marker", Fpoint_min_marker
, Spoint_min_marker
, 0, 0, 0,
1030 doc
: /* Return a marker to the minimum permissible value of point in this buffer.
1031 This is the beginning, unless narrowing (a buffer restriction) is in effect. */)
1034 return buildmark (BEGV
, BEGV_BYTE
);
1037 DEFUN ("point-max", Fpoint_max
, Spoint_max
, 0, 0, 0,
1038 doc
: /* Return the maximum permissible value of point in the current buffer.
1039 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1040 is in effect, in which case it is less. */)
1044 XSETFASTINT (temp
, ZV
);
1048 DEFUN ("point-max-marker", Fpoint_max_marker
, Spoint_max_marker
, 0, 0, 0,
1049 doc
: /* Return a marker to the maximum permissible value of point in this buffer.
1050 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1051 is in effect, in which case it is less. */)
1054 return buildmark (ZV
, ZV_BYTE
);
1057 DEFUN ("gap-position", Fgap_position
, Sgap_position
, 0, 0, 0,
1058 doc
: /* Return the position of the gap, in the current buffer.
1059 See also `gap-size'. */)
1063 XSETFASTINT (temp
, GPT
);
1067 DEFUN ("gap-size", Fgap_size
, Sgap_size
, 0, 0, 0,
1068 doc
: /* Return the size of the current buffer's gap.
1069 See also `gap-position'. */)
1073 XSETFASTINT (temp
, GAP_SIZE
);
1077 DEFUN ("position-bytes", Fposition_bytes
, Sposition_bytes
, 1, 1, 0,
1078 doc
: /* Return the byte position for character position POSITION.
1079 If POSITION is out of range, the value is nil. */)
1080 (Lisp_Object position
)
1082 CHECK_NUMBER_COERCE_MARKER (position
);
1083 if (XINT (position
) < BEG
|| XINT (position
) > Z
)
1085 return make_number (CHAR_TO_BYTE (XINT (position
)));
1088 DEFUN ("byte-to-position", Fbyte_to_position
, Sbyte_to_position
, 1, 1, 0,
1089 doc
: /* Return the character position for byte position BYTEPOS.
1090 If BYTEPOS is out of range, the value is nil. */)
1091 (Lisp_Object bytepos
)
1093 CHECK_NUMBER (bytepos
);
1094 if (XINT (bytepos
) < BEG_BYTE
|| XINT (bytepos
) > Z_BYTE
)
1096 return make_number (BYTE_TO_CHAR (XINT (bytepos
)));
1099 DEFUN ("following-char", Ffollowing_char
, Sfollowing_char
, 0, 0, 0,
1100 doc
: /* Return the character following point, as a number.
1101 At the end of the buffer or accessible region, return 0. */)
1106 XSETFASTINT (temp
, 0);
1108 XSETFASTINT (temp
, FETCH_CHAR (PT_BYTE
));
1112 DEFUN ("preceding-char", Fprevious_char
, Sprevious_char
, 0, 0, 0,
1113 doc
: /* Return the character preceding point, as a number.
1114 At the beginning of the buffer or accessible region, return 0. */)
1119 XSETFASTINT (temp
, 0);
1120 else if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
1122 EMACS_INT pos
= PT_BYTE
;
1124 XSETFASTINT (temp
, FETCH_CHAR (pos
));
1127 XSETFASTINT (temp
, FETCH_BYTE (PT_BYTE
- 1));
1131 DEFUN ("bobp", Fbobp
, Sbobp
, 0, 0, 0,
1132 doc
: /* Return t if point is at the beginning of the buffer.
1133 If the buffer is narrowed, this means the beginning of the narrowed part. */)
1141 DEFUN ("eobp", Feobp
, Seobp
, 0, 0, 0,
1142 doc
: /* Return t if point is at the end of the buffer.
1143 If the buffer is narrowed, this means the end of the narrowed part. */)
1151 DEFUN ("bolp", Fbolp
, Sbolp
, 0, 0, 0,
1152 doc
: /* Return t if point is at the beginning of a line. */)
1155 if (PT
== BEGV
|| FETCH_BYTE (PT_BYTE
- 1) == '\n')
1160 DEFUN ("eolp", Feolp
, Seolp
, 0, 0, 0,
1161 doc
: /* Return t if point is at the end of a line.
1162 `End of a line' includes point being at the end of the buffer. */)
1165 if (PT
== ZV
|| FETCH_BYTE (PT_BYTE
) == '\n')
1170 DEFUN ("char-after", Fchar_after
, Schar_after
, 0, 1, 0,
1171 doc
: /* Return character in current buffer at position POS.
1172 POS is an integer or a marker and defaults to point.
1173 If POS is out of range, the value is nil. */)
1176 register EMACS_INT pos_byte
;
1181 XSETFASTINT (pos
, PT
);
1186 pos_byte
= marker_byte_position (pos
);
1187 if (pos_byte
< BEGV_BYTE
|| pos_byte
>= ZV_BYTE
)
1192 CHECK_NUMBER_COERCE_MARKER (pos
);
1193 if (XINT (pos
) < BEGV
|| XINT (pos
) >= ZV
)
1196 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1199 return make_number (FETCH_CHAR (pos_byte
));
1202 DEFUN ("char-before", Fchar_before
, Schar_before
, 0, 1, 0,
1203 doc
: /* Return character in current buffer preceding position POS.
1204 POS is an integer or a marker and defaults to point.
1205 If POS is out of range, the value is nil. */)
1208 register Lisp_Object val
;
1209 register EMACS_INT pos_byte
;
1214 XSETFASTINT (pos
, PT
);
1219 pos_byte
= marker_byte_position (pos
);
1221 if (pos_byte
<= BEGV_BYTE
|| pos_byte
> ZV_BYTE
)
1226 CHECK_NUMBER_COERCE_MARKER (pos
);
1228 if (XINT (pos
) <= BEGV
|| XINT (pos
) > ZV
)
1231 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1234 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
1237 XSETFASTINT (val
, FETCH_CHAR (pos_byte
));
1242 XSETFASTINT (val
, FETCH_BYTE (pos_byte
));
1247 DEFUN ("user-login-name", Fuser_login_name
, Suser_login_name
, 0, 1, 0,
1248 doc
: /* Return the name under which the user logged in, as a string.
1249 This is based on the effective uid, not the real uid.
1250 Also, if the environment variables LOGNAME or USER are set,
1251 that determines the value of this function.
1253 If optional argument UID is an integer or a float, return the login name
1254 of the user with that uid, or nil if there is no such user. */)
1260 /* Set up the user name info if we didn't do it before.
1261 (That can happen if Emacs is dumpable
1262 but you decide to run `temacs -l loadup' and not dump. */
1263 if (INTEGERP (Vuser_login_name
))
1267 return Vuser_login_name
;
1269 id
= XFLOATINT (uid
);
1273 return (pw
? build_string (pw
->pw_name
) : Qnil
);
1276 DEFUN ("user-real-login-name", Fuser_real_login_name
, Suser_real_login_name
,
1278 doc
: /* Return the name of the user's real uid, as a string.
1279 This ignores the environment variables LOGNAME and USER, so it differs from
1280 `user-login-name' when running under `su'. */)
1283 /* Set up the user name info if we didn't do it before.
1284 (That can happen if Emacs is dumpable
1285 but you decide to run `temacs -l loadup' and not dump. */
1286 if (INTEGERP (Vuser_login_name
))
1288 return Vuser_real_login_name
;
1291 DEFUN ("user-uid", Fuser_uid
, Suser_uid
, 0, 0, 0,
1292 doc
: /* Return the effective uid of Emacs.
1293 Value is an integer or a float, depending on the value. */)
1296 /* Assignment to EMACS_INT stops GCC whining about limited range of
1298 EMACS_INT euid
= geteuid ();
1300 /* Make sure we don't produce a negative UID due to signed integer
1303 return make_float (geteuid ());
1304 return make_fixnum_or_float (euid
);
1307 DEFUN ("user-real-uid", Fuser_real_uid
, Suser_real_uid
, 0, 0, 0,
1308 doc
: /* Return the real uid of Emacs.
1309 Value is an integer or a float, depending on the value. */)
1312 /* Assignment to EMACS_INT stops GCC whining about limited range of
1314 EMACS_INT uid
= getuid ();
1316 /* Make sure we don't produce a negative UID due to signed integer
1319 return make_float (getuid ());
1320 return make_fixnum_or_float (uid
);
1323 DEFUN ("user-full-name", Fuser_full_name
, Suser_full_name
, 0, 1, 0,
1324 doc
: /* Return the full name of the user logged in, as a string.
1325 If the full name corresponding to Emacs's userid is not known,
1328 If optional argument UID is an integer or float, return the full name
1329 of the user with that uid, or nil if there is no such user.
1330 If UID is a string, return the full name of the user with that login
1331 name, or nil if there is no such user. */)
1335 register char *p
, *q
;
1339 return Vuser_full_name
;
1340 else if (NUMBERP (uid
))
1342 uid_t u
= XFLOATINT (uid
);
1347 else if (STRINGP (uid
))
1350 pw
= getpwnam (SSDATA (uid
));
1354 error ("Invalid UID specification");
1360 /* Chop off everything after the first comma. */
1361 q
= strchr (p
, ',');
1362 full
= make_string (p
, q
? q
- p
: strlen (p
));
1364 #ifdef AMPERSAND_FULL_NAME
1366 q
= strchr (p
, '&');
1367 /* Substitute the login name for the &, upcasing the first character. */
1373 login
= Fuser_login_name (make_number (pw
->pw_uid
));
1374 r
= (char *) alloca (strlen (p
) + SCHARS (login
) + 1);
1375 memcpy (r
, p
, q
- p
);
1377 strcat (r
, SSDATA (login
));
1378 r
[q
- p
] = upcase ((unsigned char) r
[q
- p
]);
1380 full
= build_string (r
);
1382 #endif /* AMPERSAND_FULL_NAME */
1387 DEFUN ("system-name", Fsystem_name
, Ssystem_name
, 0, 0, 0,
1388 doc
: /* Return the host name of the machine you are running on, as a string. */)
1391 return Vsystem_name
;
1395 get_system_name (void)
1397 if (STRINGP (Vsystem_name
))
1398 return SSDATA (Vsystem_name
);
1404 get_operating_system_release (void)
1406 if (STRINGP (Voperating_system_release
))
1407 return SSDATA (Voperating_system_release
);
1412 DEFUN ("emacs-pid", Femacs_pid
, Semacs_pid
, 0, 0, 0,
1413 doc
: /* Return the process ID of Emacs, as an integer. */)
1416 return make_number (getpid ());
1422 # define TIME_T_MIN TYPE_MINIMUM (time_t)
1425 # define TIME_T_MAX TYPE_MAXIMUM (time_t)
1428 /* Report that a time value is out of range for Emacs. */
1430 time_overflow (void)
1432 error ("Specified time is not representable");
1435 /* Return the upper part of the time T (everything but the bottom 16 bits),
1436 making sure that it is representable. */
1440 time_t hi
= t
>> 16;
1442 /* Check for overflow, helping the compiler for common cases where
1443 no runtime check is needed, and taking care not to convert
1444 negative numbers to unsigned before comparing them. */
1445 if (! ((! TYPE_SIGNED (time_t)
1446 || MOST_NEGATIVE_FIXNUM
<= TIME_T_MIN
>> 16
1447 || MOST_NEGATIVE_FIXNUM
<= hi
)
1448 && (TIME_T_MAX
>> 16 <= MOST_POSITIVE_FIXNUM
1449 || hi
<= MOST_POSITIVE_FIXNUM
)))
1455 /* Return the bottom 16 bits of the time T. */
1459 return t
& ((1 << 16) - 1);
1462 DEFUN ("current-time", Fcurrent_time
, Scurrent_time
, 0, 0, 0,
1463 doc
: /* Return the current time, as the number of seconds since 1970-01-01 00:00:00.
1464 The time is returned as a list of three integers. The first has the
1465 most significant 16 bits of the seconds, while the second has the
1466 least significant 16 bits. The third integer gives the microsecond
1469 The microsecond count is zero on systems that do not provide
1470 resolution finer than a second. */)
1476 return list3 (make_number (hi_time (EMACS_SECS (t
))),
1477 make_number (lo_time (EMACS_SECS (t
))),
1478 make_number (EMACS_USECS (t
)));
1481 DEFUN ("get-internal-run-time", Fget_internal_run_time
, Sget_internal_run_time
,
1483 doc
: /* Return the current run time used by Emacs.
1484 The time is returned as a list of three integers. The first has the
1485 most significant 16 bits of the seconds, while the second has the
1486 least significant 16 bits. The third integer gives the microsecond
1489 On systems that can't determine the run time, `get-internal-run-time'
1490 does the same thing as `current-time'. The microsecond count is zero
1491 on systems that do not provide resolution finer than a second. */)
1494 #ifdef HAVE_GETRUSAGE
1495 struct rusage usage
;
1499 if (getrusage (RUSAGE_SELF
, &usage
) < 0)
1500 /* This shouldn't happen. What action is appropriate? */
1503 /* Sum up user time and system time. */
1504 secs
= usage
.ru_utime
.tv_sec
+ usage
.ru_stime
.tv_sec
;
1505 usecs
= usage
.ru_utime
.tv_usec
+ usage
.ru_stime
.tv_usec
;
1506 if (usecs
>= 1000000)
1512 return list3 (make_number (hi_time (secs
)),
1513 make_number (lo_time (secs
)),
1514 make_number (usecs
));
1515 #else /* ! HAVE_GETRUSAGE */
1517 return w32_get_internal_run_time ();
1518 #else /* ! WINDOWSNT */
1519 return Fcurrent_time ();
1520 #endif /* WINDOWSNT */
1521 #endif /* HAVE_GETRUSAGE */
1525 /* Make a Lisp list that represents the time T. */
1527 make_time (time_t t
)
1529 return list2 (make_number (hi_time (t
)),
1530 make_number (lo_time (t
)));
1533 /* Decode a Lisp list SPECIFIED_TIME that represents a time.
1534 If SPECIFIED_TIME is nil, use the current time.
1535 Set *RESULT to seconds since the Epoch.
1536 If USEC is not null, set *USEC to the microseconds component.
1537 Return nonzero if successful. */
1539 lisp_time_argument (Lisp_Object specified_time
, time_t *result
, int *usec
)
1541 if (NILP (specified_time
))
1548 *usec
= EMACS_USECS (t
);
1549 *result
= EMACS_SECS (t
);
1553 return time (result
) != -1;
1557 Lisp_Object high
, low
;
1559 high
= Fcar (specified_time
);
1560 CHECK_NUMBER (high
);
1561 low
= Fcdr (specified_time
);
1566 Lisp_Object usec_l
= Fcdr (low
);
1568 usec_l
= Fcar (usec_l
);
1573 CHECK_NUMBER (usec_l
);
1574 *usec
= XINT (usec_l
);
1584 /* Check for overflow, helping the compiler for common cases
1585 where no runtime check is needed, and taking care not to
1586 convert negative numbers to unsigned before comparing them. */
1587 if (! ((TYPE_SIGNED (time_t)
1588 ? (TIME_T_MIN
>> 16 <= MOST_NEGATIVE_FIXNUM
1589 || TIME_T_MIN
>> 16 <= hi
)
1591 && (MOST_POSITIVE_FIXNUM
<= TIME_T_MAX
>> 16
1592 || hi
<= TIME_T_MAX
>> 16)))
1595 *result
= (hi
<< 16) + (XINT (low
) & 0xffff);
1600 DEFUN ("float-time", Ffloat_time
, Sfloat_time
, 0, 1, 0,
1601 doc
: /* Return the current time, as a float number of seconds since the epoch.
1602 If SPECIFIED-TIME is given, it is the time to convert to float
1603 instead of the current time. The argument should have the form
1604 (HIGH LOW) or (HIGH LOW USEC). Thus, you can use times obtained from
1605 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
1606 have the form (HIGH . LOW), but this is considered obsolete.
1608 WARNING: Since the result is floating point, it may not be exact.
1609 If precise time stamps are required, use either `current-time',
1610 or (if you need time as a string) `format-time-string'. */)
1611 (Lisp_Object specified_time
)
1616 if (! lisp_time_argument (specified_time
, &sec
, &usec
))
1617 error ("Invalid time specification");
1619 return make_float ((sec
* 1e6
+ usec
) / 1e6
);
1622 /* Write information into buffer S of size MAXSIZE, according to the
1623 FORMAT of length FORMAT_LEN, using time information taken from *TP.
1624 Default to Universal Time if UT is nonzero, local time otherwise.
1625 Use NS as the number of nanoseconds in the %N directive.
1626 Return the number of bytes written, not including the terminating
1627 '\0'. If S is NULL, nothing will be written anywhere; so to
1628 determine how many bytes would be written, use NULL for S and
1629 ((size_t) -1) for MAXSIZE.
1631 This function behaves like nstrftime, except it allows null
1632 bytes in FORMAT and it does not support nanoseconds. */
1634 emacs_nmemftime (char *s
, size_t maxsize
, const char *format
,
1635 size_t format_len
, const struct tm
*tp
, int ut
, int ns
)
1639 /* Loop through all the null-terminated strings in the format
1640 argument. Normally there's just one null-terminated string, but
1641 there can be arbitrarily many, concatenated together, if the
1642 format contains '\0' bytes. nstrftime stops at the first
1643 '\0' byte so we must invoke it separately for each such string. */
1652 result
= nstrftime (s
, maxsize
, format
, tp
, ut
, ns
);
1656 if (result
== 0 && s
[0] != '\0')
1661 maxsize
-= result
+ 1;
1663 len
= strlen (format
);
1664 if (len
== format_len
)
1668 format_len
-= len
+ 1;
1672 DEFUN ("format-time-string", Fformat_time_string
, Sformat_time_string
, 1, 3, 0,
1673 doc
: /* Use FORMAT-STRING to format the time TIME, or now if omitted.
1674 TIME is specified as (HIGH LOW . IGNORED), as returned by
1675 `current-time' or `file-attributes'. The obsolete form (HIGH . LOW)
1676 is also still accepted.
1677 The third, optional, argument UNIVERSAL, if non-nil, means describe TIME
1678 as Universal Time; nil means describe TIME in the local time zone.
1679 The value is a copy of FORMAT-STRING, but with certain constructs replaced
1680 by text that describes the specified date and time in TIME:
1682 %Y is the year, %y within the century, %C the century.
1683 %G is the year corresponding to the ISO week, %g within the century.
1684 %m is the numeric month.
1685 %b and %h are the locale's abbreviated month name, %B the full name.
1686 %d is the day of the month, zero-padded, %e is blank-padded.
1687 %u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.
1688 %a is the locale's abbreviated name of the day of week, %A the full name.
1689 %U is the week number starting on Sunday, %W starting on Monday,
1690 %V according to ISO 8601.
1691 %j is the day of the year.
1693 %H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H
1694 only blank-padded, %l is like %I blank-padded.
1695 %p is the locale's equivalent of either AM or PM.
1698 %N is the nanosecond, %6N the microsecond, %3N the millisecond, etc.
1699 %Z is the time zone name, %z is the numeric form.
1700 %s is the number of seconds since 1970-01-01 00:00:00 +0000.
1702 %c is the locale's date and time format.
1703 %x is the locale's "preferred" date format.
1704 %D is like "%m/%d/%y".
1706 %R is like "%H:%M", %T is like "%H:%M:%S", %r is like "%I:%M:%S %p".
1707 %X is the locale's "preferred" time format.
1709 Finally, %n is a newline, %t is a tab, %% is a literal %.
1711 Certain flags and modifiers are available with some format controls.
1712 The flags are `_', `-', `^' and `#'. For certain characters X,
1713 %_X is like %X, but padded with blanks; %-X is like %X,
1714 but without padding. %^X is like %X, but with all textual
1715 characters up-cased; %#X is like %X, but with letter-case of
1716 all textual characters reversed.
1717 %NX (where N stands for an integer) is like %X,
1718 but takes up at least N (a number) positions.
1719 The modifiers are `E' and `O'. For certain characters X,
1720 %EX is a locale's alternative version of %X;
1721 %OX is like %X, but uses the locale's number symbols.
1723 For example, to produce full ISO 8601 format, use "%Y-%m-%dT%T%z". */)
1724 (Lisp_Object format_string
, Lisp_Object timeval
, Lisp_Object universal
)
1731 int ut
= ! NILP (universal
);
1733 CHECK_STRING (format_string
);
1735 if (! (lisp_time_argument (timeval
, &value
, &usec
)
1736 && 0 <= usec
&& usec
< 1000000))
1737 error ("Invalid time specification");
1740 format_string
= code_convert_string_norecord (format_string
,
1741 Vlocale_coding_system
, 1);
1743 /* This is probably enough. */
1744 size
= SBYTES (format_string
) * 6 + 50;
1747 tm
= ut
? gmtime (&value
) : localtime (&value
);
1752 synchronize_system_time_locale ();
1756 char *buf
= (char *) alloca (size
+ 1);
1761 result
= emacs_nmemftime (buf
, size
, SSDATA (format_string
),
1762 SBYTES (format_string
),
1765 if ((result
> 0 && result
< size
) || (result
== 0 && buf
[0] == '\0'))
1766 return code_convert_string_norecord (make_unibyte_string (buf
, result
),
1767 Vlocale_coding_system
, 0);
1769 /* If buffer was too small, make it bigger and try again. */
1771 result
= emacs_nmemftime (NULL
, (size_t) -1,
1772 SSDATA (format_string
),
1773 SBYTES (format_string
),
1780 DEFUN ("decode-time", Fdecode_time
, Sdecode_time
, 0, 1, 0,
1781 doc
: /* Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST ZONE).
1782 The optional SPECIFIED-TIME should be a list of (HIGH LOW . IGNORED),
1783 as from `current-time' and `file-attributes', or nil to use the
1784 current time. The obsolete form (HIGH . LOW) is also still accepted.
1785 The list has the following nine members: SEC is an integer between 0
1786 and 60; SEC is 60 for a leap second, which only some operating systems
1787 support. MINUTE is an integer between 0 and 59. HOUR is an integer
1788 between 0 and 23. DAY is an integer between 1 and 31. MONTH is an
1789 integer between 1 and 12. YEAR is an integer indicating the
1790 four-digit year. DOW is the day of week, an integer between 0 and 6,
1791 where 0 is Sunday. DST is t if daylight saving time is in effect,
1792 otherwise nil. ZONE is an integer indicating the number of seconds
1793 east of Greenwich. (Note that Common Lisp has different meanings for
1795 (Lisp_Object specified_time
)
1799 struct tm
*decoded_time
;
1800 Lisp_Object list_args
[9];
1802 if (! lisp_time_argument (specified_time
, &time_spec
, NULL
))
1803 error ("Invalid time specification");
1806 decoded_time
= localtime (&time_spec
);
1809 && MOST_NEGATIVE_FIXNUM
- TM_YEAR_BASE
<= decoded_time
->tm_year
1810 && decoded_time
->tm_year
<= MOST_POSITIVE_FIXNUM
- TM_YEAR_BASE
))
1812 XSETFASTINT (list_args
[0], decoded_time
->tm_sec
);
1813 XSETFASTINT (list_args
[1], decoded_time
->tm_min
);
1814 XSETFASTINT (list_args
[2], decoded_time
->tm_hour
);
1815 XSETFASTINT (list_args
[3], decoded_time
->tm_mday
);
1816 XSETFASTINT (list_args
[4], decoded_time
->tm_mon
+ 1);
1817 /* On 64-bit machines an int is narrower than EMACS_INT, thus the
1818 cast below avoids overflow in int arithmetics. */
1819 XSETINT (list_args
[5], TM_YEAR_BASE
+ (EMACS_INT
) decoded_time
->tm_year
);
1820 XSETFASTINT (list_args
[6], decoded_time
->tm_wday
);
1821 list_args
[7] = (decoded_time
->tm_isdst
)? Qt
: Qnil
;
1823 /* Make a copy, in case gmtime modifies the struct. */
1824 save_tm
= *decoded_time
;
1826 decoded_time
= gmtime (&time_spec
);
1828 if (decoded_time
== 0)
1829 list_args
[8] = Qnil
;
1831 XSETINT (list_args
[8], tm_diff (&save_tm
, decoded_time
));
1832 return Flist (9, list_args
);
1835 /* Return OBJ - OFFSET, checking that OBJ is a valid fixnum and that
1836 the result is representable as an int. Assume OFFSET is small and
1839 check_tm_member (Lisp_Object obj
, int offset
)
1844 if (! (INT_MIN
+ offset
<= n
&& n
- offset
<= INT_MAX
))
1849 DEFUN ("encode-time", Fencode_time
, Sencode_time
, 6, MANY
, 0,
1850 doc
: /* Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.
1851 This is the reverse operation of `decode-time', which see.
1852 ZONE defaults to the current time zone rule. This can
1853 be a string or t (as from `set-time-zone-rule'), or it can be a list
1854 \(as from `current-time-zone') or an integer (as from `decode-time')
1855 applied without consideration for daylight saving time.
1857 You can pass more than 7 arguments; then the first six arguments
1858 are used as SECOND through YEAR, and the *last* argument is used as ZONE.
1859 The intervening arguments are ignored.
1860 This feature lets (apply 'encode-time (decode-time ...)) work.
1862 Out-of-range values for SECOND, MINUTE, HOUR, DAY, or MONTH are allowed;
1863 for example, a DAY of 0 means the day preceding the given month.
1864 Year numbers less than 100 are treated just like other year numbers.
1865 If you want them to stand for years in this century, you must do that yourself.
1867 Years before 1970 are not guaranteed to work. On some systems,
1868 year values as low as 1901 do work.
1870 usage: (encode-time SECOND MINUTE HOUR DAY MONTH YEAR &optional ZONE) */)
1871 (int nargs
, register Lisp_Object
*args
)
1875 Lisp_Object zone
= (nargs
> 6 ? args
[nargs
- 1] : Qnil
);
1877 tm
.tm_sec
= check_tm_member (args
[0], 0);
1878 tm
.tm_min
= check_tm_member (args
[1], 0);
1879 tm
.tm_hour
= check_tm_member (args
[2], 0);
1880 tm
.tm_mday
= check_tm_member (args
[3], 0);
1881 tm
.tm_mon
= check_tm_member (args
[4], 1);
1882 tm
.tm_year
= check_tm_member (args
[5], TM_YEAR_BASE
);
1890 value
= mktime (&tm
);
1896 const char *tzstring
;
1897 char **oldenv
= environ
, **newenv
;
1901 else if (STRINGP (zone
))
1902 tzstring
= SSDATA (zone
);
1903 else if (INTEGERP (zone
))
1905 int abszone
= eabs (XINT (zone
));
1906 sprintf (tzbuf
, "XXX%s%d:%02d:%02d", "-" + (XINT (zone
) < 0),
1907 abszone
/ (60*60), (abszone
/60) % 60, abszone
% 60);
1911 error ("Invalid time zone specification");
1913 /* Set TZ before calling mktime; merely adjusting mktime's returned
1914 value doesn't suffice, since that would mishandle leap seconds. */
1915 set_time_zone_rule (tzstring
);
1918 value
= mktime (&tm
);
1921 /* Restore TZ to previous value. */
1925 #ifdef LOCALTIME_CACHE
1930 if (value
== (time_t) -1)
1933 return make_time (value
);
1936 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
, 0, 1, 0,
1937 doc
: /* Return the current local time, as a human-readable string.
1938 Programs can use this function to decode a time,
1939 since the number of columns in each field is fixed
1940 if the year is in the range 1000-9999.
1941 The format is `Sun Sep 16 01:03:52 1973'.
1942 However, see also the functions `decode-time' and `format-time-string'
1943 which provide a much more powerful and general facility.
1945 If SPECIFIED-TIME is given, it is a time to format instead of the
1946 current time. The argument should have the form (HIGH LOW . IGNORED).
1947 Thus, you can use times obtained from `current-time' and from
1948 `file-attributes'. SPECIFIED-TIME can also have the form (HIGH . LOW),
1949 but this is considered obsolete. */)
1950 (Lisp_Object specified_time
)
1956 if (! lisp_time_argument (specified_time
, &value
, NULL
))
1957 error ("Invalid time specification");
1959 /* Convert to a string, checking for out-of-range time stamps.
1960 Don't use 'ctime', as that might dump core if VALUE is out of
1963 tm
= localtime (&value
);
1965 if (! (tm
&& TM_YEAR_IN_ASCTIME_RANGE (tm
->tm_year
) && (tem
= asctime (tm
))))
1968 /* Remove the trailing newline. */
1969 tem
[strlen (tem
) - 1] = '\0';
1971 return build_string (tem
);
1974 /* Yield A - B, measured in seconds.
1975 This function is copied from the GNU C Library. */
1977 tm_diff (struct tm
*a
, struct tm
*b
)
1979 /* Compute intervening leap days correctly even if year is negative.
1980 Take care to avoid int overflow in leap day calculations,
1981 but it's OK to assume that A and B are close to each other. */
1982 int a4
= (a
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (a
->tm_year
& 3);
1983 int b4
= (b
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (b
->tm_year
& 3);
1984 int a100
= a4
/ 25 - (a4
% 25 < 0);
1985 int b100
= b4
/ 25 - (b4
% 25 < 0);
1986 int a400
= a100
>> 2;
1987 int b400
= b100
>> 2;
1988 int intervening_leap_days
= (a4
- b4
) - (a100
- b100
) + (a400
- b400
);
1989 int years
= a
->tm_year
- b
->tm_year
;
1990 int days
= (365 * years
+ intervening_leap_days
1991 + (a
->tm_yday
- b
->tm_yday
));
1992 return (60 * (60 * (24 * days
+ (a
->tm_hour
- b
->tm_hour
))
1993 + (a
->tm_min
- b
->tm_min
))
1994 + (a
->tm_sec
- b
->tm_sec
));
1997 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 1, 0,
1998 doc
: /* Return the offset and name for the local time zone.
1999 This returns a list of the form (OFFSET NAME).
2000 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).
2001 A negative value means west of Greenwich.
2002 NAME is a string giving the name of the time zone.
2003 If SPECIFIED-TIME is given, the time zone offset is determined from it
2004 instead of using the current time. The argument should have the form
2005 (HIGH LOW . IGNORED). Thus, you can use times obtained from
2006 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
2007 have the form (HIGH . LOW), but this is considered obsolete.
2009 Some operating systems cannot provide all this information to Emacs;
2010 in this case, `current-time-zone' returns a list containing nil for
2011 the data it can't find. */)
2012 (Lisp_Object specified_time
)
2018 if (!lisp_time_argument (specified_time
, &value
, NULL
))
2023 t
= gmtime (&value
);
2027 t
= localtime (&value
);
2034 int offset
= tm_diff (t
, &gmt
);
2040 s
= (char *)t
->tm_zone
;
2041 #else /* not HAVE_TM_ZONE */
2043 if (t
->tm_isdst
== 0 || t
->tm_isdst
== 1)
2044 s
= tzname
[t
->tm_isdst
];
2046 #endif /* not HAVE_TM_ZONE */
2050 /* No local time zone name is available; use "+-NNNN" instead. */
2051 int am
= (offset
< 0 ? -offset
: offset
) / 60;
2052 sprintf (buf
, "%c%02d%02d", (offset
< 0 ? '-' : '+'), am
/60, am
%60);
2056 return Fcons (make_number (offset
), Fcons (build_string (s
), Qnil
));
2059 return Fmake_list (make_number (2), Qnil
);
2062 /* This holds the value of `environ' produced by the previous
2063 call to Fset_time_zone_rule, or 0 if Fset_time_zone_rule
2064 has never been called. */
2065 static char **environbuf
;
2067 /* This holds the startup value of the TZ environment variable so it
2068 can be restored if the user calls set-time-zone-rule with a nil
2070 static char *initial_tz
;
2072 DEFUN ("set-time-zone-rule", Fset_time_zone_rule
, Sset_time_zone_rule
, 1, 1, 0,
2073 doc
: /* Set the local time zone using TZ, a string specifying a time zone rule.
2074 If TZ is nil, use implementation-defined default time zone information.
2075 If TZ is t, use Universal Time. */)
2078 const char *tzstring
;
2080 /* When called for the first time, save the original TZ. */
2082 initial_tz
= (char *) getenv ("TZ");
2085 tzstring
= initial_tz
;
2086 else if (EQ (tz
, Qt
))
2091 tzstring
= SSDATA (tz
);
2094 set_time_zone_rule (tzstring
);
2096 environbuf
= environ
;
2101 #ifdef LOCALTIME_CACHE
2103 /* These two values are known to load tz files in buggy implementations,
2104 i.e. Solaris 1 executables running under either Solaris 1 or Solaris 2.
2105 Their values shouldn't matter in non-buggy implementations.
2106 We don't use string literals for these strings,
2107 since if a string in the environment is in readonly
2108 storage, it runs afoul of bugs in SVR4 and Solaris 2.3.
2109 See Sun bugs 1113095 and 1114114, ``Timezone routines
2110 improperly modify environment''. */
2112 static char set_time_zone_rule_tz1
[] = "TZ=GMT+0";
2113 static char set_time_zone_rule_tz2
[] = "TZ=GMT+1";
2117 /* Set the local time zone rule to TZSTRING.
2118 This allocates memory into `environ', which it is the caller's
2119 responsibility to free. */
2122 set_time_zone_rule (const char *tzstring
)
2125 char **from
, **to
, **newenv
;
2127 /* Make the ENVIRON vector longer with room for TZSTRING. */
2128 for (from
= environ
; *from
; from
++)
2130 envptrs
= from
- environ
+ 2;
2131 newenv
= to
= (char **) xmalloc (envptrs
* sizeof (char *)
2132 + (tzstring
? strlen (tzstring
) + 4 : 0));
2134 /* Add TZSTRING to the end of environ, as a value for TZ. */
2137 char *t
= (char *) (to
+ envptrs
);
2139 strcat (t
, tzstring
);
2143 /* Copy the old environ vector elements into NEWENV,
2144 but don't copy the TZ variable.
2145 So we have only one definition of TZ, which came from TZSTRING. */
2146 for (from
= environ
; *from
; from
++)
2147 if (strncmp (*from
, "TZ=", 3) != 0)
2153 /* If we do have a TZSTRING, NEWENV points to the vector slot where
2154 the TZ variable is stored. If we do not have a TZSTRING,
2155 TO points to the vector slot which has the terminating null. */
2157 #ifdef LOCALTIME_CACHE
2159 /* In SunOS 4.1.3_U1 and 4.1.4, if TZ has a value like
2160 "US/Pacific" that loads a tz file, then changes to a value like
2161 "XXX0" that does not load a tz file, and then changes back to
2162 its original value, the last change is (incorrectly) ignored.
2163 Also, if TZ changes twice in succession to values that do
2164 not load a tz file, tzset can dump core (see Sun bug#1225179).
2165 The following code works around these bugs. */
2169 /* Temporarily set TZ to a value that loads a tz file
2170 and that differs from tzstring. */
2172 *newenv
= (strcmp (tzstring
, set_time_zone_rule_tz1
+ 3) == 0
2173 ? set_time_zone_rule_tz2
: set_time_zone_rule_tz1
);
2179 /* The implied tzstring is unknown, so temporarily set TZ to
2180 two different values that each load a tz file. */
2181 *to
= set_time_zone_rule_tz1
;
2184 *to
= set_time_zone_rule_tz2
;
2189 /* Now TZ has the desired value, and tzset can be invoked safely. */
2196 /* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC
2197 (if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a
2198 type of object is Lisp_String). INHERIT is passed to
2199 INSERT_FROM_STRING_FUNC as the last argument. */
2202 general_insert_function (void (*insert_func
)
2203 (const char *, EMACS_INT
),
2204 void (*insert_from_string_func
)
2205 (Lisp_Object
, EMACS_INT
, EMACS_INT
,
2206 EMACS_INT
, EMACS_INT
, int),
2207 int inherit
, int nargs
, Lisp_Object
*args
)
2209 register int argnum
;
2210 register Lisp_Object val
;
2212 for (argnum
= 0; argnum
< nargs
; argnum
++)
2215 if (CHARACTERP (val
))
2217 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2220 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2221 len
= CHAR_STRING (XFASTINT (val
), str
);
2224 str
[0] = (ASCII_CHAR_P (XINT (val
))
2226 : multibyte_char_to_unibyte (XINT (val
), Qnil
));
2229 (*insert_func
) ((char *) str
, len
);
2231 else if (STRINGP (val
))
2233 (*insert_from_string_func
) (val
, 0, 0,
2239 wrong_type_argument (Qchar_or_string_p
, val
);
2244 insert1 (Lisp_Object arg
)
2250 /* Callers passing one argument to Finsert need not gcpro the
2251 argument "array", since the only element of the array will
2252 not be used after calling insert or insert_from_string, so
2253 we don't care if it gets trashed. */
2255 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
2256 doc
: /* Insert the arguments, either strings or characters, at point.
2257 Point and before-insertion markers move forward to end up
2258 after the inserted text.
2259 Any other markers at the point of insertion remain before the text.
2261 If the current buffer is multibyte, unibyte strings are converted
2262 to multibyte for insertion (see `string-make-multibyte').
2263 If the current buffer is unibyte, multibyte strings are converted
2264 to unibyte for insertion (see `string-make-unibyte').
2266 When operating on binary data, it may be necessary to preserve the
2267 original bytes of a unibyte string when inserting it into a multibyte
2268 buffer; to accomplish this, apply `string-as-multibyte' to the string
2269 and insert the result.
2271 usage: (insert &rest ARGS) */)
2272 (int nargs
, register Lisp_Object
*args
)
2274 general_insert_function (insert
, insert_from_string
, 0, nargs
, args
);
2278 DEFUN ("insert-and-inherit", Finsert_and_inherit
, Sinsert_and_inherit
,
2280 doc
: /* Insert the arguments at point, inheriting properties from adjoining text.
2281 Point and before-insertion markers move forward to end up
2282 after the inserted text.
2283 Any other markers at the point of insertion remain before the text.
2285 If the current buffer is multibyte, unibyte strings are converted
2286 to multibyte for insertion (see `unibyte-char-to-multibyte').
2287 If the current buffer is unibyte, multibyte strings are converted
2288 to unibyte for insertion.
2290 usage: (insert-and-inherit &rest ARGS) */)
2291 (int nargs
, register Lisp_Object
*args
)
2293 general_insert_function (insert_and_inherit
, insert_from_string
, 1,
2298 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
2299 doc
: /* Insert strings or characters at point, relocating markers after the text.
2300 Point and markers move forward to end up after the inserted text.
2302 If the current buffer is multibyte, unibyte strings are converted
2303 to multibyte for insertion (see `unibyte-char-to-multibyte').
2304 If the current buffer is unibyte, multibyte strings are converted
2305 to unibyte for insertion.
2307 usage: (insert-before-markers &rest ARGS) */)
2308 (int nargs
, register Lisp_Object
*args
)
2310 general_insert_function (insert_before_markers
,
2311 insert_from_string_before_markers
, 0,
2316 DEFUN ("insert-before-markers-and-inherit", Finsert_and_inherit_before_markers
,
2317 Sinsert_and_inherit_before_markers
, 0, MANY
, 0,
2318 doc
: /* Insert text at point, relocating markers and inheriting properties.
2319 Point and markers move forward to end up after the inserted 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-before-markers-and-inherit &rest ARGS) */)
2327 (int nargs
, register Lisp_Object
*args
)
2329 general_insert_function (insert_before_markers_and_inherit
,
2330 insert_from_string_before_markers
, 1,
2335 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 2, 3, 0,
2336 doc
: /* Insert COUNT copies of CHARACTER.
2337 Point, and before-insertion markers, are relocated as in the function `insert'.
2338 The optional third arg INHERIT, if non-nil, says to inherit text properties
2339 from adjoining text, if those properties are sticky. */)
2340 (Lisp_Object character
, Lisp_Object count
, Lisp_Object inherit
)
2342 register char *string
;
2343 register EMACS_INT stringlen
;
2345 register EMACS_INT n
;
2347 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2349 CHECK_NUMBER (character
);
2350 CHECK_NUMBER (count
);
2352 if (!NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2353 len
= CHAR_STRING (XFASTINT (character
), str
);
2355 str
[0] = XFASTINT (character
), len
= 1;
2356 if (MOST_POSITIVE_FIXNUM
/ len
< XINT (count
))
2357 error ("Maximum buffer size would be exceeded");
2358 n
= XINT (count
) * len
;
2361 stringlen
= min (n
, 256 * len
);
2362 string
= (char *) alloca (stringlen
);
2363 for (i
= 0; i
< stringlen
; i
++)
2364 string
[i
] = str
[i
% len
];
2365 while (n
>= stringlen
)
2368 if (!NILP (inherit
))
2369 insert_and_inherit (string
, stringlen
);
2371 insert (string
, stringlen
);
2376 if (!NILP (inherit
))
2377 insert_and_inherit (string
, n
);
2384 DEFUN ("insert-byte", Finsert_byte
, Sinsert_byte
, 2, 3, 0,
2385 doc
: /* Insert COUNT (second arg) copies of BYTE (first arg).
2386 Both arguments are required.
2387 BYTE is a number of the range 0..255.
2389 If BYTE is 128..255 and the current buffer is multibyte, the
2390 corresponding eight-bit character is inserted.
2392 Point, and before-insertion markers, are relocated as in the function `insert'.
2393 The optional third arg INHERIT, if non-nil, says to inherit text properties
2394 from adjoining text, if those properties are sticky. */)
2395 (Lisp_Object byte
, Lisp_Object count
, Lisp_Object inherit
)
2397 CHECK_NUMBER (byte
);
2398 if (XINT (byte
) < 0 || XINT (byte
) > 255)
2399 args_out_of_range_3 (byte
, make_number (0), make_number (255));
2400 if (XINT (byte
) >= 128
2401 && ! NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2402 XSETFASTINT (byte
, BYTE8_TO_CHAR (XINT (byte
)));
2403 return Finsert_char (byte
, count
, inherit
);
2407 /* Making strings from buffer contents. */
2409 /* Return a Lisp_String containing the text of the current buffer from
2410 START to END. If text properties are in use and the current buffer
2411 has properties in the range specified, the resulting string will also
2412 have them, if PROPS is nonzero.
2414 We don't want to use plain old make_string here, because it calls
2415 make_uninit_string, which can cause the buffer arena to be
2416 compacted. make_string has no way of knowing that the data has
2417 been moved, and thus copies the wrong data into the string. This
2418 doesn't effect most of the other users of make_string, so it should
2419 be left as is. But we should use this function when conjuring
2420 buffer substrings. */
2423 make_buffer_string (EMACS_INT start
, EMACS_INT end
, int props
)
2425 EMACS_INT start_byte
= CHAR_TO_BYTE (start
);
2426 EMACS_INT end_byte
= CHAR_TO_BYTE (end
);
2428 return make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
);
2431 /* Return a Lisp_String containing the text of the current buffer from
2432 START / START_BYTE to END / END_BYTE.
2434 If text properties are in use and the current buffer
2435 has properties in the range specified, the resulting string will also
2436 have them, if PROPS is nonzero.
2438 We don't want to use plain old make_string here, because it calls
2439 make_uninit_string, which can cause the buffer arena to be
2440 compacted. make_string has no way of knowing that the data has
2441 been moved, and thus copies the wrong data into the string. This
2442 doesn't effect most of the other users of make_string, so it should
2443 be left as is. But we should use this function when conjuring
2444 buffer substrings. */
2447 make_buffer_string_both (EMACS_INT start
, EMACS_INT start_byte
,
2448 EMACS_INT end
, EMACS_INT end_byte
, int props
)
2450 Lisp_Object result
, tem
, tem1
;
2452 if (start
< GPT
&& GPT
< end
)
2455 if (! NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
2456 result
= make_uninit_multibyte_string (end
- start
, end_byte
- start_byte
);
2458 result
= make_uninit_string (end
- start
);
2459 memcpy (SDATA (result
), BYTE_POS_ADDR (start_byte
), end_byte
- start_byte
);
2461 /* If desired, update and copy the text properties. */
2464 update_buffer_properties (start
, end
);
2466 tem
= Fnext_property_change (make_number (start
), Qnil
, make_number (end
));
2467 tem1
= Ftext_properties_at (make_number (start
), Qnil
);
2469 if (XINT (tem
) != end
|| !NILP (tem1
))
2470 copy_intervals_to_string (result
, current_buffer
, start
,
2477 /* Call Vbuffer_access_fontify_functions for the range START ... END
2478 in the current buffer, if necessary. */
2481 update_buffer_properties (EMACS_INT start
, EMACS_INT end
)
2483 /* If this buffer has some access functions,
2484 call them, specifying the range of the buffer being accessed. */
2485 if (!NILP (Vbuffer_access_fontify_functions
))
2487 Lisp_Object args
[3];
2490 args
[0] = Qbuffer_access_fontify_functions
;
2491 XSETINT (args
[1], start
);
2492 XSETINT (args
[2], end
);
2494 /* But don't call them if we can tell that the work
2495 has already been done. */
2496 if (!NILP (Vbuffer_access_fontified_property
))
2498 tem
= Ftext_property_any (args
[1], args
[2],
2499 Vbuffer_access_fontified_property
,
2502 Frun_hook_with_args (3, args
);
2505 Frun_hook_with_args (3, args
);
2509 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
2510 doc
: /* Return the contents of part of the current buffer as a string.
2511 The two arguments START and END are character positions;
2512 they can be in either order.
2513 The string returned is multibyte if the buffer is multibyte.
2515 This function copies the text properties of that part of the buffer
2516 into the result string; if you don't want the text properties,
2517 use `buffer-substring-no-properties' instead. */)
2518 (Lisp_Object start
, Lisp_Object end
)
2520 register EMACS_INT b
, e
;
2522 validate_region (&start
, &end
);
2526 return make_buffer_string (b
, e
, 1);
2529 DEFUN ("buffer-substring-no-properties", Fbuffer_substring_no_properties
,
2530 Sbuffer_substring_no_properties
, 2, 2, 0,
2531 doc
: /* Return the characters of part of the buffer, without the text properties.
2532 The two arguments START and END are character positions;
2533 they can be in either order. */)
2534 (Lisp_Object start
, Lisp_Object end
)
2536 register EMACS_INT b
, e
;
2538 validate_region (&start
, &end
);
2542 return make_buffer_string (b
, e
, 0);
2545 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
2546 doc
: /* Return the contents of the current buffer as a string.
2547 If narrowing is in effect, this function returns only the visible part
2551 return make_buffer_string (BEGV
, ZV
, 1);
2554 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
2556 doc
: /* Insert before point a substring of the contents of BUFFER.
2557 BUFFER may be a buffer or a buffer name.
2558 Arguments START and END are character positions specifying the substring.
2559 They default to the values of (point-min) and (point-max) in BUFFER. */)
2560 (Lisp_Object buffer
, Lisp_Object start
, Lisp_Object end
)
2562 register EMACS_INT b
, e
, temp
;
2563 register struct buffer
*bp
, *obuf
;
2566 buf
= Fget_buffer (buffer
);
2570 if (NILP (BVAR (bp
, name
)))
2571 error ("Selecting deleted buffer");
2577 CHECK_NUMBER_COERCE_MARKER (start
);
2584 CHECK_NUMBER_COERCE_MARKER (end
);
2589 temp
= b
, b
= e
, e
= temp
;
2591 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
2592 args_out_of_range (start
, end
);
2594 obuf
= current_buffer
;
2595 set_buffer_internal_1 (bp
);
2596 update_buffer_properties (b
, e
);
2597 set_buffer_internal_1 (obuf
);
2599 insert_from_buffer (bp
, b
, e
- b
, 0);
2603 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
2605 doc
: /* Compare two substrings of two buffers; return result as number.
2606 the value is -N if first string is less after N-1 chars,
2607 +N if first string is greater after N-1 chars, or 0 if strings match.
2608 Each substring is represented as three arguments: BUFFER, START and END.
2609 That makes six args in all, three for each substring.
2611 The value of `case-fold-search' in the current buffer
2612 determines whether case is significant or ignored. */)
2613 (Lisp_Object buffer1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object buffer2
, Lisp_Object start2
, Lisp_Object end2
)
2615 register EMACS_INT begp1
, endp1
, begp2
, endp2
, temp
;
2616 register struct buffer
*bp1
, *bp2
;
2617 register Lisp_Object trt
2618 = (!NILP (BVAR (current_buffer
, case_fold_search
))
2619 ? BVAR (current_buffer
, case_canon_table
) : Qnil
);
2620 EMACS_INT chars
= 0;
2621 EMACS_INT i1
, i2
, i1_byte
, i2_byte
;
2623 /* Find the first buffer and its substring. */
2626 bp1
= current_buffer
;
2630 buf1
= Fget_buffer (buffer1
);
2633 bp1
= XBUFFER (buf1
);
2634 if (NILP (BVAR (bp1
, name
)))
2635 error ("Selecting deleted buffer");
2639 begp1
= BUF_BEGV (bp1
);
2642 CHECK_NUMBER_COERCE_MARKER (start1
);
2643 begp1
= XINT (start1
);
2646 endp1
= BUF_ZV (bp1
);
2649 CHECK_NUMBER_COERCE_MARKER (end1
);
2650 endp1
= XINT (end1
);
2654 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
2656 if (!(BUF_BEGV (bp1
) <= begp1
2658 && endp1
<= BUF_ZV (bp1
)))
2659 args_out_of_range (start1
, end1
);
2661 /* Likewise for second substring. */
2664 bp2
= current_buffer
;
2668 buf2
= Fget_buffer (buffer2
);
2671 bp2
= XBUFFER (buf2
);
2672 if (NILP (BVAR (bp2
, name
)))
2673 error ("Selecting deleted buffer");
2677 begp2
= BUF_BEGV (bp2
);
2680 CHECK_NUMBER_COERCE_MARKER (start2
);
2681 begp2
= XINT (start2
);
2684 endp2
= BUF_ZV (bp2
);
2687 CHECK_NUMBER_COERCE_MARKER (end2
);
2688 endp2
= XINT (end2
);
2692 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
2694 if (!(BUF_BEGV (bp2
) <= begp2
2696 && endp2
<= BUF_ZV (bp2
)))
2697 args_out_of_range (start2
, end2
);
2701 i1_byte
= buf_charpos_to_bytepos (bp1
, i1
);
2702 i2_byte
= buf_charpos_to_bytepos (bp2
, i2
);
2704 while (i1
< endp1
&& i2
< endp2
)
2706 /* When we find a mismatch, we must compare the
2707 characters, not just the bytes. */
2712 if (! NILP (BVAR (bp1
, enable_multibyte_characters
)))
2714 c1
= BUF_FETCH_MULTIBYTE_CHAR (bp1
, i1_byte
);
2715 BUF_INC_POS (bp1
, i1_byte
);
2720 c1
= BUF_FETCH_BYTE (bp1
, i1
);
2721 MAKE_CHAR_MULTIBYTE (c1
);
2725 if (! NILP (BVAR (bp2
, enable_multibyte_characters
)))
2727 c2
= BUF_FETCH_MULTIBYTE_CHAR (bp2
, i2_byte
);
2728 BUF_INC_POS (bp2
, i2_byte
);
2733 c2
= BUF_FETCH_BYTE (bp2
, i2
);
2734 MAKE_CHAR_MULTIBYTE (c2
);
2740 c1
= CHAR_TABLE_TRANSLATE (trt
, c1
);
2741 c2
= CHAR_TABLE_TRANSLATE (trt
, c2
);
2744 return make_number (- 1 - chars
);
2746 return make_number (chars
+ 1);
2751 /* The strings match as far as they go.
2752 If one is shorter, that one is less. */
2753 if (chars
< endp1
- begp1
)
2754 return make_number (chars
+ 1);
2755 else if (chars
< endp2
- begp2
)
2756 return make_number (- chars
- 1);
2758 /* Same length too => they are equal. */
2759 return make_number (0);
2763 subst_char_in_region_unwind (Lisp_Object arg
)
2765 return BVAR (current_buffer
, undo_list
) = arg
;
2769 subst_char_in_region_unwind_1 (Lisp_Object arg
)
2771 return BVAR (current_buffer
, filename
) = arg
;
2774 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
2775 Ssubst_char_in_region
, 4, 5, 0,
2776 doc
: /* From START to END, replace FROMCHAR with TOCHAR each time it occurs.
2777 If optional arg NOUNDO is non-nil, don't record this change for undo
2778 and don't mark the buffer as really changed.
2779 Both characters must have the same length of multi-byte form. */)
2780 (Lisp_Object start
, Lisp_Object end
, Lisp_Object fromchar
, Lisp_Object tochar
, Lisp_Object noundo
)
2782 register EMACS_INT pos
, pos_byte
, stop
, i
, len
, end_byte
;
2783 /* Keep track of the first change in the buffer:
2784 if 0 we haven't found it yet.
2785 if < 0 we've found it and we've run the before-change-function.
2786 if > 0 we've actually performed it and the value is its position. */
2787 EMACS_INT changed
= 0;
2788 unsigned char fromstr
[MAX_MULTIBYTE_LENGTH
], tostr
[MAX_MULTIBYTE_LENGTH
];
2790 int count
= SPECPDL_INDEX ();
2791 #define COMBINING_NO 0
2792 #define COMBINING_BEFORE 1
2793 #define COMBINING_AFTER 2
2794 #define COMBINING_BOTH (COMBINING_BEFORE | COMBINING_AFTER)
2795 int maybe_byte_combining
= COMBINING_NO
;
2796 EMACS_INT last_changed
= 0;
2797 int multibyte_p
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
2801 validate_region (&start
, &end
);
2802 CHECK_NUMBER (fromchar
);
2803 CHECK_NUMBER (tochar
);
2807 len
= CHAR_STRING (XFASTINT (fromchar
), fromstr
);
2808 if (CHAR_STRING (XFASTINT (tochar
), tostr
) != len
)
2809 error ("Characters in `subst-char-in-region' have different byte-lengths");
2810 if (!ASCII_BYTE_P (*tostr
))
2812 /* If *TOSTR is in the range 0x80..0x9F and TOCHAR is not a
2813 complete multibyte character, it may be combined with the
2814 after bytes. If it is in the range 0xA0..0xFF, it may be
2815 combined with the before and after bytes. */
2816 if (!CHAR_HEAD_P (*tostr
))
2817 maybe_byte_combining
= COMBINING_BOTH
;
2818 else if (BYTES_BY_CHAR_HEAD (*tostr
) > len
)
2819 maybe_byte_combining
= COMBINING_AFTER
;
2825 fromstr
[0] = XFASTINT (fromchar
);
2826 tostr
[0] = XFASTINT (tochar
);
2830 pos_byte
= CHAR_TO_BYTE (pos
);
2831 stop
= CHAR_TO_BYTE (XINT (end
));
2834 /* If we don't want undo, turn off putting stuff on the list.
2835 That's faster than getting rid of things,
2836 and it prevents even the entry for a first change.
2837 Also inhibit locking the file. */
2838 if (!changed
&& !NILP (noundo
))
2840 record_unwind_protect (subst_char_in_region_unwind
,
2841 BVAR (current_buffer
, undo_list
));
2842 BVAR (current_buffer
, undo_list
) = Qt
;
2843 /* Don't do file-locking. */
2844 record_unwind_protect (subst_char_in_region_unwind_1
,
2845 BVAR (current_buffer
, filename
));
2846 BVAR (current_buffer
, filename
) = Qnil
;
2849 if (pos_byte
< GPT_BYTE
)
2850 stop
= min (stop
, GPT_BYTE
);
2853 EMACS_INT pos_byte_next
= pos_byte
;
2855 if (pos_byte
>= stop
)
2857 if (pos_byte
>= end_byte
) break;
2860 p
= BYTE_POS_ADDR (pos_byte
);
2862 INC_POS (pos_byte_next
);
2865 if (pos_byte_next
- pos_byte
== len
2866 && p
[0] == fromstr
[0]
2868 || (p
[1] == fromstr
[1]
2869 && (len
== 2 || (p
[2] == fromstr
[2]
2870 && (len
== 3 || p
[3] == fromstr
[3]))))))
2873 /* We've already seen this and run the before-change-function;
2874 this time we only need to record the actual position. */
2879 modify_region (current_buffer
, pos
, XINT (end
), 0);
2881 if (! NILP (noundo
))
2883 if (MODIFF
- 1 == SAVE_MODIFF
)
2885 if (MODIFF
- 1 == BUF_AUTOSAVE_MODIFF (current_buffer
))
2886 BUF_AUTOSAVE_MODIFF (current_buffer
)++;
2889 /* The before-change-function may have moved the gap
2890 or even modified the buffer so we should start over. */
2894 /* Take care of the case where the new character
2895 combines with neighboring bytes. */
2896 if (maybe_byte_combining
2897 && (maybe_byte_combining
== COMBINING_AFTER
2898 ? (pos_byte_next
< Z_BYTE
2899 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2900 : ((pos_byte_next
< Z_BYTE
2901 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2902 || (pos_byte
> BEG_BYTE
2903 && ! ASCII_BYTE_P (FETCH_BYTE (pos_byte
- 1))))))
2905 Lisp_Object tem
, string
;
2907 struct gcpro gcpro1
;
2909 tem
= BVAR (current_buffer
, undo_list
);
2912 /* Make a multibyte string containing this single character. */
2913 string
= make_multibyte_string ((char *) tostr
, 1, len
);
2914 /* replace_range is less efficient, because it moves the gap,
2915 but it handles combining correctly. */
2916 replace_range (pos
, pos
+ 1, string
,
2918 pos_byte_next
= CHAR_TO_BYTE (pos
);
2919 if (pos_byte_next
> pos_byte
)
2920 /* Before combining happened. We should not increment
2921 POS. So, to cancel the later increment of POS,
2925 INC_POS (pos_byte_next
);
2927 if (! NILP (noundo
))
2928 BVAR (current_buffer
, undo_list
) = tem
;
2935 record_change (pos
, 1);
2936 for (i
= 0; i
< len
; i
++) *p
++ = tostr
[i
];
2938 last_changed
= pos
+ 1;
2940 pos_byte
= pos_byte_next
;
2946 signal_after_change (changed
,
2947 last_changed
- changed
, last_changed
- changed
);
2948 update_compositions (changed
, last_changed
, CHECK_ALL
);
2951 unbind_to (count
, Qnil
);
2956 static Lisp_Object
check_translation (EMACS_INT
, EMACS_INT
, EMACS_INT
,
2959 /* Helper function for Ftranslate_region_internal.
2961 Check if a character sequence at POS (POS_BYTE) matches an element
2962 of VAL. VAL is a list (([FROM-CHAR ...] . TO) ...). If a matching
2963 element is found, return it. Otherwise return Qnil. */
2966 check_translation (EMACS_INT pos
, EMACS_INT pos_byte
, EMACS_INT end
,
2969 int buf_size
= 16, buf_used
= 0;
2970 int *buf
= alloca (sizeof (int) * buf_size
);
2972 for (; CONSP (val
); val
= XCDR (val
))
2981 if (! VECTORP (elt
))
2984 if (len
<= end
- pos
)
2986 for (i
= 0; i
< len
; i
++)
2990 unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
2993 if (buf_used
== buf_size
)
2998 newbuf
= alloca (sizeof (int) * buf_size
);
2999 memcpy (newbuf
, buf
, sizeof (int) * buf_used
);
3002 buf
[buf_used
++] = STRING_CHAR_AND_LENGTH (p
, len1
);
3005 if (XINT (AREF (elt
, i
)) != buf
[i
])
3016 DEFUN ("translate-region-internal", Ftranslate_region_internal
,
3017 Stranslate_region_internal
, 3, 3, 0,
3018 doc
: /* Internal use only.
3019 From START to END, translate characters according to TABLE.
3020 TABLE is a string or a char-table; the Nth character in it is the
3021 mapping for the character with code N.
3022 It returns the number of characters changed. */)
3023 (Lisp_Object start
, Lisp_Object end
, register Lisp_Object table
)
3025 register unsigned char *tt
; /* Trans table. */
3026 register int nc
; /* New character. */
3027 int cnt
; /* Number of changes made. */
3028 EMACS_INT size
; /* Size of translate table. */
3029 EMACS_INT pos
, pos_byte
, end_pos
;
3030 int multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3031 int string_multibyte
IF_LINT (= 0);
3033 validate_region (&start
, &end
);
3034 if (CHAR_TABLE_P (table
))
3036 if (! EQ (XCHAR_TABLE (table
)->purpose
, Qtranslation_table
))
3037 error ("Not a translation table");
3043 CHECK_STRING (table
);
3045 if (! multibyte
&& (SCHARS (table
) < SBYTES (table
)))
3046 table
= string_make_unibyte (table
);
3047 string_multibyte
= SCHARS (table
) < SBYTES (table
);
3048 size
= SBYTES (table
);
3053 pos_byte
= CHAR_TO_BYTE (pos
);
3054 end_pos
= XINT (end
);
3055 modify_region (current_buffer
, pos
, end_pos
, 0);
3058 for (; pos
< end_pos
; )
3060 register unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
3061 unsigned char *str
, buf
[MAX_MULTIBYTE_LENGTH
];
3067 oc
= STRING_CHAR_AND_LENGTH (p
, len
);
3074 /* Reload as signal_after_change in last iteration may GC. */
3076 if (string_multibyte
)
3078 str
= tt
+ string_char_to_byte (table
, oc
);
3079 nc
= STRING_CHAR_AND_LENGTH (str
, str_len
);
3084 if (! ASCII_BYTE_P (nc
) && multibyte
)
3086 str_len
= BYTE8_STRING (nc
, buf
);
3101 val
= CHAR_TABLE_REF (table
, oc
);
3102 if (CHARACTERP (val
)
3103 && (c
= XINT (val
), CHAR_VALID_P (c
, 0)))
3106 str_len
= CHAR_STRING (nc
, buf
);
3109 else if (VECTORP (val
) || (CONSP (val
)))
3111 /* VAL is [TO_CHAR ...] or (([FROM-CHAR ...] . TO) ...)
3112 where TO is TO-CHAR or [TO-CHAR ...]. */
3117 if (nc
!= oc
&& nc
>= 0)
3119 /* Simple one char to one char translation. */
3124 /* This is less efficient, because it moves the gap,
3125 but it should handle multibyte characters correctly. */
3126 string
= make_multibyte_string ((char *) str
, 1, str_len
);
3127 replace_range (pos
, pos
+ 1, string
, 1, 0, 1);
3132 record_change (pos
, 1);
3133 while (str_len
-- > 0)
3135 signal_after_change (pos
, 1, 1);
3136 update_compositions (pos
, pos
+ 1, CHECK_BORDER
);
3146 val
= check_translation (pos
, pos_byte
, end_pos
, val
);
3153 /* VAL is ([FROM-CHAR ...] . TO). */
3154 len
= ASIZE (XCAR (val
));
3162 string
= Fconcat (1, &val
);
3166 string
= Fmake_string (make_number (1), val
);
3168 replace_range (pos
, pos
+ len
, string
, 1, 0, 1);
3169 pos_byte
+= SBYTES (string
);
3170 pos
+= SCHARS (string
);
3171 cnt
+= SCHARS (string
);
3172 end_pos
+= SCHARS (string
) - len
;
3180 return make_number (cnt
);
3183 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
3184 doc
: /* Delete the text between point and mark.
3186 When called from a program, expects two arguments,
3187 positions (integers or markers) specifying the stretch to be deleted. */)
3188 (Lisp_Object start
, Lisp_Object end
)
3190 validate_region (&start
, &end
);
3191 del_range (XINT (start
), XINT (end
));
3195 DEFUN ("delete-and-extract-region", Fdelete_and_extract_region
,
3196 Sdelete_and_extract_region
, 2, 2, 0,
3197 doc
: /* Delete the text between START and END and return it. */)
3198 (Lisp_Object start
, Lisp_Object end
)
3200 validate_region (&start
, &end
);
3201 if (XINT (start
) == XINT (end
))
3202 return empty_unibyte_string
;
3203 return del_range_1 (XINT (start
), XINT (end
), 1, 1);
3206 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
3207 doc
: /* Remove restrictions (narrowing) from current buffer.
3208 This allows the buffer's full text to be seen and edited. */)
3211 if (BEG
!= BEGV
|| Z
!= ZV
)
3212 current_buffer
->clip_changed
= 1;
3214 BEGV_BYTE
= BEG_BYTE
;
3215 SET_BUF_ZV_BOTH (current_buffer
, Z
, Z_BYTE
);
3216 /* Changing the buffer bounds invalidates any recorded current column. */
3217 invalidate_current_column ();
3221 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
3222 doc
: /* Restrict editing in this buffer to the current region.
3223 The rest of the text becomes temporarily invisible and untouchable
3224 but is not deleted; if you save the buffer in a file, the invisible
3225 text is included in the file. \\[widen] makes all visible again.
3226 See also `save-restriction'.
3228 When calling from a program, pass two arguments; positions (integers
3229 or markers) bounding the text that should remain visible. */)
3230 (register Lisp_Object start
, Lisp_Object end
)
3232 CHECK_NUMBER_COERCE_MARKER (start
);
3233 CHECK_NUMBER_COERCE_MARKER (end
);
3235 if (XINT (start
) > XINT (end
))
3238 tem
= start
; start
= end
; end
= tem
;
3241 if (!(BEG
<= XINT (start
) && XINT (start
) <= XINT (end
) && XINT (end
) <= Z
))
3242 args_out_of_range (start
, end
);
3244 if (BEGV
!= XFASTINT (start
) || ZV
!= XFASTINT (end
))
3245 current_buffer
->clip_changed
= 1;
3247 SET_BUF_BEGV (current_buffer
, XFASTINT (start
));
3248 SET_BUF_ZV (current_buffer
, XFASTINT (end
));
3249 if (PT
< XFASTINT (start
))
3250 SET_PT (XFASTINT (start
));
3251 if (PT
> XFASTINT (end
))
3252 SET_PT (XFASTINT (end
));
3253 /* Changing the buffer bounds invalidates any recorded current column. */
3254 invalidate_current_column ();
3259 save_restriction_save (void)
3261 if (BEGV
== BEG
&& ZV
== Z
)
3262 /* The common case that the buffer isn't narrowed.
3263 We return just the buffer object, which save_restriction_restore
3264 recognizes as meaning `no restriction'. */
3265 return Fcurrent_buffer ();
3267 /* We have to save a restriction, so return a pair of markers, one
3268 for the beginning and one for the end. */
3270 Lisp_Object beg
, end
;
3272 beg
= buildmark (BEGV
, BEGV_BYTE
);
3273 end
= buildmark (ZV
, ZV_BYTE
);
3275 /* END must move forward if text is inserted at its exact location. */
3276 XMARKER(end
)->insertion_type
= 1;
3278 return Fcons (beg
, end
);
3283 save_restriction_restore (Lisp_Object data
)
3285 struct buffer
*cur
= NULL
;
3286 struct buffer
*buf
= (CONSP (data
)
3287 ? XMARKER (XCAR (data
))->buffer
3290 if (buf
&& buf
!= current_buffer
&& !NILP (BVAR (buf
, pt_marker
)))
3291 { /* If `buf' uses markers to keep track of PT, BEGV, and ZV (as
3292 is the case if it is or has an indirect buffer), then make
3293 sure it is current before we update BEGV, so
3294 set_buffer_internal takes care of managing those markers. */
3295 cur
= current_buffer
;
3296 set_buffer_internal (buf
);
3300 /* A pair of marks bounding a saved restriction. */
3302 struct Lisp_Marker
*beg
= XMARKER (XCAR (data
));
3303 struct Lisp_Marker
*end
= XMARKER (XCDR (data
));
3304 eassert (buf
== end
->buffer
);
3306 if (buf
/* Verify marker still points to a buffer. */
3307 && (beg
->charpos
!= BUF_BEGV (buf
) || end
->charpos
!= BUF_ZV (buf
)))
3308 /* The restriction has changed from the saved one, so restore
3309 the saved restriction. */
3311 EMACS_INT pt
= BUF_PT (buf
);
3313 SET_BUF_BEGV_BOTH (buf
, beg
->charpos
, beg
->bytepos
);
3314 SET_BUF_ZV_BOTH (buf
, end
->charpos
, end
->bytepos
);
3316 if (pt
< beg
->charpos
|| pt
> end
->charpos
)
3317 /* The point is outside the new visible range, move it inside. */
3318 SET_BUF_PT_BOTH (buf
,
3319 clip_to_bounds (beg
->charpos
, pt
, end
->charpos
),
3320 clip_to_bounds (beg
->bytepos
, BUF_PT_BYTE (buf
),
3323 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3327 /* A buffer, which means that there was no old restriction. */
3329 if (buf
/* Verify marker still points to a buffer. */
3330 && (BUF_BEGV (buf
) != BUF_BEG (buf
) || BUF_ZV (buf
) != BUF_Z (buf
)))
3331 /* The buffer has been narrowed, get rid of the narrowing. */
3333 SET_BUF_BEGV_BOTH (buf
, BUF_BEG (buf
), BUF_BEG_BYTE (buf
));
3334 SET_BUF_ZV_BOTH (buf
, BUF_Z (buf
), BUF_Z_BYTE (buf
));
3336 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3340 /* Changing the buffer bounds invalidates any recorded current column. */
3341 invalidate_current_column ();
3344 set_buffer_internal (cur
);
3349 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
3350 doc
: /* Execute BODY, saving and restoring current buffer's restrictions.
3351 The buffer's restrictions make parts of the beginning and end invisible.
3352 \(They are set up with `narrow-to-region' and eliminated with `widen'.)
3353 This special form, `save-restriction', saves the current buffer's restrictions
3354 when it is entered, and restores them when it is exited.
3355 So any `narrow-to-region' within BODY lasts only until the end of the form.
3356 The old restrictions settings are restored
3357 even in case of abnormal exit (throw or error).
3359 The value returned is the value of the last form in BODY.
3361 Note: if you are using both `save-excursion' and `save-restriction',
3362 use `save-excursion' outermost:
3363 (save-excursion (save-restriction ...))
3365 usage: (save-restriction &rest BODY) */)
3368 register Lisp_Object val
;
3369 int count
= SPECPDL_INDEX ();
3371 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
3372 val
= Fprogn (body
);
3373 return unbind_to (count
, val
);
3376 /* Buffer for the most recent text displayed by Fmessage_box. */
3377 static char *message_text
;
3379 /* Allocated length of that buffer. */
3380 static int message_length
;
3382 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
3383 doc
: /* Display a message at the bottom of the screen.
3384 The message also goes into the `*Messages*' buffer.
3385 \(In keyboard macros, that's all it does.)
3388 The first argument is a format control string, and the rest are data
3389 to be formatted under control of the string. See `format' for details.
3391 Note: Use (message "%s" VALUE) to print the value of expressions and
3392 variables to avoid accidentally interpreting `%' as format specifiers.
3394 If the first argument is nil or the empty string, the function clears
3395 any existing message; this lets the minibuffer contents show. See
3396 also `current-message'.
3398 usage: (message FORMAT-STRING &rest ARGS) */)
3399 (int nargs
, Lisp_Object
*args
)
3402 || (STRINGP (args
[0])
3403 && SBYTES (args
[0]) == 0))
3410 register Lisp_Object val
;
3411 val
= Fformat (nargs
, args
);
3412 message3 (val
, SBYTES (val
), STRING_MULTIBYTE (val
));
3417 DEFUN ("message-box", Fmessage_box
, Smessage_box
, 1, MANY
, 0,
3418 doc
: /* Display a message, in a dialog box if possible.
3419 If a dialog box is not available, use the echo area.
3420 The first argument is a format control string, and the rest are data
3421 to be formatted under control of the string. See `format' for details.
3423 If the first argument is nil or the empty string, clear any existing
3424 message; let the minibuffer contents show.
3426 usage: (message-box FORMAT-STRING &rest ARGS) */)
3427 (int nargs
, Lisp_Object
*args
)
3436 register Lisp_Object val
;
3437 val
= Fformat (nargs
, args
);
3439 /* The MS-DOS frames support popup menus even though they are
3440 not FRAME_WINDOW_P. */
3441 if (FRAME_WINDOW_P (XFRAME (selected_frame
))
3442 || FRAME_MSDOS_P (XFRAME (selected_frame
)))
3444 Lisp_Object pane
, menu
, obj
;
3445 struct gcpro gcpro1
;
3446 pane
= Fcons (Fcons (build_string ("OK"), Qt
), Qnil
);
3448 menu
= Fcons (val
, pane
);
3449 obj
= Fx_popup_dialog (Qt
, menu
, Qt
);
3453 #endif /* HAVE_MENUS */
3454 /* Copy the data so that it won't move when we GC. */
3457 message_text
= (char *)xmalloc (80);
3458 message_length
= 80;
3460 if (SBYTES (val
) > message_length
)
3462 message_length
= SBYTES (val
);
3463 message_text
= (char *)xrealloc (message_text
, message_length
);
3465 memcpy (message_text
, SDATA (val
), SBYTES (val
));
3466 message2 (message_text
, SBYTES (val
),
3467 STRING_MULTIBYTE (val
));
3472 DEFUN ("message-or-box", Fmessage_or_box
, Smessage_or_box
, 1, MANY
, 0,
3473 doc
: /* Display a message in a dialog box or in the echo area.
3474 If this command was invoked with the mouse, use a dialog box if
3475 `use-dialog-box' is non-nil.
3476 Otherwise, use the echo area.
3477 The first argument is a format control string, and the rest are data
3478 to be formatted under control of the string. See `format' for details.
3480 If the first argument is nil or the empty string, clear any existing
3481 message; let the minibuffer contents show.
3483 usage: (message-or-box FORMAT-STRING &rest ARGS) */)
3484 (int nargs
, Lisp_Object
*args
)
3487 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3489 return Fmessage_box (nargs
, args
);
3491 return Fmessage (nargs
, args
);
3494 DEFUN ("current-message", Fcurrent_message
, Scurrent_message
, 0, 0, 0,
3495 doc
: /* Return the string currently displayed in the echo area, or nil if none. */)
3498 return current_message ();
3502 DEFUN ("propertize", Fpropertize
, Spropertize
, 1, MANY
, 0,
3503 doc
: /* Return a copy of STRING with text properties added.
3504 First argument is the string to copy.
3505 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
3506 properties to add to the result.
3507 usage: (propertize STRING &rest PROPERTIES) */)
3508 (int nargs
, Lisp_Object
*args
)
3510 Lisp_Object properties
, string
;
3511 struct gcpro gcpro1
, gcpro2
;
3514 /* Number of args must be odd. */
3515 if ((nargs
& 1) == 0 || nargs
< 1)
3516 error ("Wrong number of arguments");
3518 properties
= string
= Qnil
;
3519 GCPRO2 (properties
, string
);
3521 /* First argument must be a string. */
3522 CHECK_STRING (args
[0]);
3523 string
= Fcopy_sequence (args
[0]);
3525 for (i
= 1; i
< nargs
; i
+= 2)
3526 properties
= Fcons (args
[i
], Fcons (args
[i
+ 1], properties
));
3528 Fadd_text_properties (make_number (0),
3529 make_number (SCHARS (string
)),
3530 properties
, string
);
3531 RETURN_UNGCPRO (string
);
3535 /* Number of bytes that STRING will occupy when put into the result.
3536 MULTIBYTE is nonzero if the result should be multibyte. */
3538 #define CONVERTED_BYTE_SIZE(MULTIBYTE, STRING) \
3539 (((MULTIBYTE) && ! STRING_MULTIBYTE (STRING)) \
3540 ? count_size_as_multibyte (SDATA (STRING), SBYTES (STRING)) \
3543 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
3544 doc
: /* Format a string out of a format-string and arguments.
3545 The first argument is a format control string.
3546 The other arguments are substituted into it to make the result, a string.
3548 The format control string may contain %-sequences meaning to substitute
3549 the next available argument:
3551 %s means print a string argument. Actually, prints any object, with `princ'.
3552 %d means print as number in decimal (%o octal, %x hex).
3553 %X is like %x, but uses upper case.
3554 %e means print a number in exponential notation.
3555 %f means print a number in decimal-point notation.
3556 %g means print a number in exponential notation
3557 or decimal-point notation, whichever uses fewer characters.
3558 %c means print a number as a single character.
3559 %S means print any object as an s-expression (using `prin1').
3561 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.
3562 Use %% to put a single % into the output.
3564 A %-sequence may contain optional flag, width, and precision
3565 specifiers, as follows:
3567 %<flags><width><precision>character
3569 where flags is [+ #-0]+, width is [0-9]+, and precision is .[0-9]+
3571 The + flag character inserts a + before any positive number, while a
3572 space inserts a space before any positive number; these flags only
3573 affect %d, %e, %f, and %g sequences, and the + flag takes precedence.
3574 The # flag means to use an alternate display form for %o, %x, %X, %e,
3575 %f, and %g sequences. The - and 0 flags affect the width specifier,
3578 The width specifier supplies a lower limit for the length of the
3579 printed representation. The padding, if any, normally goes on the
3580 left, but it goes on the right if the - flag is present. The padding
3581 character is normally a space, but it is 0 if the 0 flag is present.
3582 The - flag takes precedence over the 0 flag.
3584 For %e, %f, and %g sequences, the number after the "." in the
3585 precision specifier says how many decimal places to show; if zero, the
3586 decimal point itself is omitted. For %s and %S, the precision
3587 specifier truncates the string to the given width.
3589 usage: (format STRING &rest OBJECTS) */)
3590 (int nargs
, register Lisp_Object
*args
)
3592 register int n
; /* The number of the next arg to substitute */
3593 register EMACS_INT total
; /* An estimate of the final length */
3595 register char *format
, *end
, *format_start
;
3597 /* Nonzero if the output should be a multibyte string,
3598 which is true if any of the inputs is one. */
3600 /* When we make a multibyte string, we must pay attention to the
3601 byte combining problem, i.e., a byte may be combined with a
3602 multibyte character of the previous string. This flag tells if we
3603 must consider such a situation or not. */
3604 int maybe_combine_byte
;
3606 /* Precision for each spec, or -1, a flag value meaning no precision
3607 was given in that spec. Element 0, corresponding to the format
3608 string itself, will not be used. Element NARGS, corresponding to
3609 no argument, *will* be assigned to in the case that a `%' and `.'
3610 occur after the final format specifier. */
3611 int *precision
= (int *) (alloca ((nargs
+ 1) * sizeof (int)));
3614 int arg_intervals
= 0;
3617 /* discarded[I] is 1 if byte I of the format
3618 string was not copied into the output.
3619 It is 2 if byte I was not the first byte of its character. */
3620 char *discarded
= 0;
3622 /* Each element records, for one argument,
3623 the start and end bytepos in the output string,
3624 and whether the argument is a string with intervals.
3625 info[0] is unused. Unused elements have -1 for start. */
3628 int start
, end
, intervals
;
3631 /* It should not be necessary to GCPRO ARGS, because
3632 the caller in the interpreter should take care of that. */
3634 /* Try to determine whether the result should be multibyte.
3635 This is not always right; sometimes the result needs to be multibyte
3636 because of an object that we will pass through prin1,
3637 and in that case, we won't know it here. */
3638 for (n
= 0; n
< nargs
; n
++)
3640 if (STRINGP (args
[n
]) && STRING_MULTIBYTE (args
[n
]))
3642 /* Piggyback on this loop to initialize precision[N]. */
3645 precision
[nargs
] = -1;
3647 CHECK_STRING (args
[0]);
3648 /* We may have to change "%S" to "%s". */
3649 args
[0] = Fcopy_sequence (args
[0]);
3651 /* GC should never happen here, so abort if it does. */
3654 /* If we start out planning a unibyte result,
3655 then discover it has to be multibyte, we jump back to retry.
3656 That can only happen from the first large while loop below. */
3659 format
= SSDATA (args
[0]);
3660 format_start
= format
;
3661 end
= format
+ SBYTES (args
[0]);
3664 /* Make room in result for all the non-%-codes in the control string. */
3665 total
= 5 + CONVERTED_BYTE_SIZE (multibyte
, args
[0]) + 1;
3667 /* Allocate the info and discarded tables. */
3669 int nbytes
= (nargs
+1) * sizeof *info
;
3672 info
= (struct info
*) alloca (nbytes
);
3673 memset (info
, 0, nbytes
);
3674 for (i
= 0; i
<= nargs
; i
++)
3677 SAFE_ALLOCA (discarded
, char *, SBYTES (args
[0]));
3678 memset (discarded
, 0, SBYTES (args
[0]));
3681 /* Add to TOTAL enough space to hold the converted arguments. */
3684 while (format
!= end
)
3685 if (*format
++ == '%')
3687 EMACS_INT thissize
= 0;
3688 EMACS_INT actual_width
= 0;
3689 char *this_format_start
= format
- 1;
3690 int field_width
= 0;
3692 /* General format specifications look like
3694 '%' [flags] [field-width] [precision] format
3699 field-width ::= [0-9]+
3700 precision ::= '.' [0-9]*
3702 If a field-width is specified, it specifies to which width
3703 the output should be padded with blanks, if the output
3704 string is shorter than field-width.
3706 If precision is specified, it specifies the number of
3707 digits to print after the '.' for floats, or the max.
3708 number of chars to print from a string. */
3710 while (format
!= end
3711 && (*format
== '-' || *format
== '0' || *format
== '#'
3712 || * format
== ' ' || *format
== '+'))
3715 if (*format
>= '0' && *format
<= '9')
3717 for (field_width
= 0; *format
>= '0' && *format
<= '9'; ++format
)
3718 field_width
= 10 * field_width
+ *format
- '0';
3721 /* N is not incremented for another few lines below, so refer to
3722 element N+1 (which might be precision[NARGS]). */
3726 for (precision
[n
+1] = 0; *format
>= '0' && *format
<= '9'; ++format
)
3727 precision
[n
+1] = 10 * precision
[n
+1] + *format
- '0';
3730 /* Extra +1 for 'l' that we may need to insert into the
3732 if (format
- this_format_start
+ 2 > longest_format
)
3733 longest_format
= format
- this_format_start
+ 2;
3736 error ("Format string ends in middle of format specifier");
3739 else if (++n
>= nargs
)
3740 error ("Not enough arguments for format string");
3741 else if (*format
== 'S')
3743 /* For `S', prin1 the argument and then treat like a string. */
3744 register Lisp_Object tem
;
3745 tem
= Fprin1_to_string (args
[n
], Qnil
);
3746 if (STRING_MULTIBYTE (tem
) && ! multibyte
)
3752 /* If we restart the loop, we should not come here again
3753 because args[n] is now a string and calling
3754 Fprin1_to_string on it produces superflous double
3755 quotes. So, change "%S" to "%s" now. */
3759 else if (SYMBOLP (args
[n
]))
3761 args
[n
] = SYMBOL_NAME (args
[n
]);
3762 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
3769 else if (STRINGP (args
[n
]))
3772 if (*format
!= 's' && *format
!= 'S')
3773 error ("Format specifier doesn't match argument type");
3774 /* In the case (PRECISION[N] > 0), THISSIZE may not need
3775 to be as large as is calculated here. Easy check for
3776 the case PRECISION = 0. */
3777 thissize
= precision
[n
] ? CONVERTED_BYTE_SIZE (multibyte
, args
[n
]) : 0;
3778 /* The precision also constrains how much of the argument
3779 string will finally appear (Bug#5710). */
3780 actual_width
= lisp_string_width (args
[n
], -1, NULL
, NULL
);
3781 if (precision
[n
] != -1)
3782 actual_width
= min (actual_width
, precision
[n
]);
3784 /* Would get MPV otherwise, since Lisp_Int's `point' to low memory. */
3785 else if (INTEGERP (args
[n
]) && *format
!= 's')
3787 /* The following loop assumes the Lisp type indicates
3788 the proper way to pass the argument.
3789 So make sure we have a flonum if the argument should
3791 if (*format
== 'e' || *format
== 'f' || *format
== 'g')
3792 args
[n
] = Ffloat (args
[n
]);
3794 if (*format
!= 'd' && *format
!= 'o' && *format
!= 'x'
3795 && *format
!= 'i' && *format
!= 'X' && *format
!= 'c')
3796 error ("Invalid format operation %%%c", *format
);
3798 thissize
= 30 + (precision
[n
] > 0 ? precision
[n
] : 0);
3801 if (! ASCII_CHAR_P (XINT (args
[n
]))
3802 /* Note: No one can remeber why we have to treat
3803 the character 0 as a multibyte character here.
3804 But, until it causes a real problem, let's
3806 || XINT (args
[n
]) == 0)
3813 args
[n
] = Fchar_to_string (args
[n
]);
3814 thissize
= SBYTES (args
[n
]);
3816 else if (! ASCII_BYTE_P (XINT (args
[n
])) && multibyte
)
3819 = Fchar_to_string (Funibyte_char_to_multibyte (args
[n
]));
3820 thissize
= SBYTES (args
[n
]);
3824 else if (FLOATP (args
[n
]) && *format
!= 's')
3826 if (! (*format
== 'e' || *format
== 'f' || *format
== 'g'))
3828 if (*format
!= 'd' && *format
!= 'o' && *format
!= 'x'
3829 && *format
!= 'i' && *format
!= 'X' && *format
!= 'c')
3830 error ("Invalid format operation %%%c", *format
);
3831 /* This fails unnecessarily if args[n] is bigger than
3832 most-positive-fixnum but smaller than MAXINT.
3833 These cases are important because we sometimes use floats
3834 to represent such integer values (typically such values
3835 come from UIDs or PIDs). */
3836 /* args[n] = Ftruncate (args[n], Qnil); */
3839 /* Note that we're using sprintf to print floats,
3840 so we have to take into account what that function
3842 /* Filter out flag value of -1. */
3843 thissize
= (MAX_10_EXP
+ 100
3844 + (precision
[n
] > 0 ? precision
[n
] : 0));
3848 /* Anything but a string, convert to a string using princ. */
3849 register Lisp_Object tem
;
3850 tem
= Fprin1_to_string (args
[n
], Qt
);
3851 if (STRING_MULTIBYTE (tem
) && ! multibyte
)
3860 thissize
+= max (0, field_width
- actual_width
);
3861 total
+= thissize
+ 4;
3866 /* Now we can no longer jump to retry.
3867 TOTAL and LONGEST_FORMAT are known for certain. */
3869 this_format
= (char *) alloca (longest_format
+ 1);
3871 /* Allocate the space for the result.
3872 Note that TOTAL is an overestimate. */
3873 SAFE_ALLOCA (buf
, char *, total
);
3879 /* Scan the format and store result in BUF. */
3880 format
= SSDATA (args
[0]);
3881 format_start
= format
;
3882 end
= format
+ SBYTES (args
[0]);
3883 maybe_combine_byte
= 0;
3884 while (format
!= end
)
3890 char *this_format_start
= format
;
3892 discarded
[format
- format_start
] = 1;
3895 while (strchr ("-+0# ", *format
))
3901 discarded
[format
- format_start
] = 1;
3905 minlen
= atoi (format
);
3907 while ((*format
>= '0' && *format
<= '9') || *format
== '.')
3909 discarded
[format
- format_start
] = 1;
3913 if (*format
++ == '%')
3922 discarded
[format
- format_start
- 1] = 1;
3923 info
[n
].start
= nchars
;
3925 if (STRINGP (args
[n
]))
3927 /* handle case (precision[n] >= 0) */
3930 EMACS_INT nbytes
, start
;
3931 EMACS_INT nchars_string
;
3933 /* lisp_string_width ignores a precision of 0, but GNU
3934 libc functions print 0 characters when the precision
3935 is 0. Imitate libc behavior here. Changing
3936 lisp_string_width is the right thing, and will be
3937 done, but meanwhile we work with it. */
3939 if (precision
[n
] == 0)
3940 width
= nchars_string
= nbytes
= 0;
3941 else if (precision
[n
] > 0)
3942 width
= lisp_string_width (args
[n
], precision
[n
],
3943 &nchars_string
, &nbytes
);
3945 { /* no precision spec given for this argument */
3946 width
= lisp_string_width (args
[n
], -1, NULL
, NULL
);
3947 nbytes
= SBYTES (args
[n
]);
3948 nchars_string
= SCHARS (args
[n
]);
3951 /* If spec requires it, pad on right with spaces. */
3952 padding
= minlen
- width
;
3954 while (padding
-- > 0)
3960 info
[n
].start
= start
= nchars
;
3961 nchars
+= nchars_string
;
3965 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3966 && STRING_MULTIBYTE (args
[n
])
3967 && !CHAR_HEAD_P (SREF (args
[n
], 0)))
3968 maybe_combine_byte
= 1;
3970 p
+= copy_text (SDATA (args
[n
]), (unsigned char *) p
,
3972 STRING_MULTIBYTE (args
[n
]), multibyte
);
3974 info
[n
].end
= nchars
;
3977 while (padding
-- > 0)
3983 /* If this argument has text properties, record where
3984 in the result string it appears. */
3985 if (STRING_INTERVALS (args
[n
]))
3986 info
[n
].intervals
= arg_intervals
= 1;
3988 else if (INTEGERP (args
[n
]) || FLOATP (args
[n
]))
3992 memcpy (this_format
, this_format_start
,
3993 format
- this_format_start
);
3994 this_format
[format
- this_format_start
] = 0;
3996 if (format
[-1] == 'e' || format
[-1] == 'f' || format
[-1] == 'g')
3997 sprintf (p
, this_format
, XFLOAT_DATA (args
[n
]));
4000 if (sizeof (EMACS_INT
) > sizeof (int)
4001 && format
[-1] != 'c')
4003 /* Insert 'l' before format spec. */
4004 this_format
[format
- this_format_start
]
4005 = this_format
[format
- this_format_start
- 1];
4006 this_format
[format
- this_format_start
- 1] = 'l';
4007 this_format
[format
- this_format_start
+ 1] = 0;
4010 if (INTEGERP (args
[n
]))
4012 if (format
[-1] == 'c')
4013 sprintf (p
, this_format
, (int) XINT (args
[n
]));
4014 else if (format
[-1] == 'd')
4015 sprintf (p
, this_format
, XINT (args
[n
]));
4016 /* Don't sign-extend for octal or hex printing. */
4018 sprintf (p
, this_format
, XUINT (args
[n
]));
4020 else if (format
[-1] == 'c')
4021 sprintf (p
, this_format
, (int) XFLOAT_DATA (args
[n
]));
4022 else if (format
[-1] == 'd')
4023 /* Maybe we should use "%1.0f" instead so it also works
4024 for values larger than MAXINT. */
4025 sprintf (p
, this_format
, (EMACS_INT
) XFLOAT_DATA (args
[n
]));
4027 /* Don't sign-extend for octal or hex printing. */
4028 sprintf (p
, this_format
, (EMACS_UINT
) XFLOAT_DATA (args
[n
]));
4033 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
4034 && !CHAR_HEAD_P (*((unsigned char *) p
)))
4035 maybe_combine_byte
= 1;
4036 this_nchars
= strlen (p
);
4038 p
+= str_to_multibyte ((unsigned char *) p
,
4039 buf
+ total
- 1 - p
, this_nchars
);
4042 nchars
+= this_nchars
;
4043 info
[n
].end
= nchars
;
4047 else if (STRING_MULTIBYTE (args
[0]))
4049 /* Copy a whole multibyte character. */
4052 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
4053 && !CHAR_HEAD_P (*format
))
4054 maybe_combine_byte
= 1;
4056 while (! CHAR_HEAD_P (*format
))
4058 discarded
[format
- format_start
] = 2;
4065 /* Convert a single-byte character to multibyte. */
4066 int len
= copy_text ((unsigned char *) format
, (unsigned char *) p
,
4074 *p
++ = *format
++, nchars
++;
4077 if (p
> buf
+ total
)
4080 if (maybe_combine_byte
)
4081 nchars
= multibyte_chars_in_text ((unsigned char *) buf
, p
- buf
);
4082 val
= make_specified_string (buf
, nchars
, p
- buf
, multibyte
);
4084 /* If we allocated BUF with malloc, free it too. */
4087 /* If the format string has text properties, or any of the string
4088 arguments has text properties, set up text properties of the
4091 if (STRING_INTERVALS (args
[0]) || arg_intervals
)
4093 Lisp_Object len
, new_len
, props
;
4094 struct gcpro gcpro1
;
4096 /* Add text properties from the format string. */
4097 len
= make_number (SCHARS (args
[0]));
4098 props
= text_property_list (args
[0], make_number (0), len
, Qnil
);
4103 EMACS_INT bytepos
= 0, position
= 0, translated
= 0;
4107 /* Adjust the bounds of each text property
4108 to the proper start and end in the output string. */
4110 /* Put the positions in PROPS in increasing order, so that
4111 we can do (effectively) one scan through the position
4112 space of the format string. */
4113 props
= Fnreverse (props
);
4115 /* BYTEPOS is the byte position in the format string,
4116 POSITION is the untranslated char position in it,
4117 TRANSLATED is the translated char position in BUF,
4118 and ARGN is the number of the next arg we will come to. */
4119 for (list
= props
; CONSP (list
); list
= XCDR (list
))
4126 /* First adjust the property start position. */
4127 pos
= XINT (XCAR (item
));
4129 /* Advance BYTEPOS, POSITION, TRANSLATED and ARGN
4130 up to this position. */
4131 for (; position
< pos
; bytepos
++)
4133 if (! discarded
[bytepos
])
4134 position
++, translated
++;
4135 else if (discarded
[bytepos
] == 1)
4138 if (translated
== info
[argn
].start
)
4140 translated
+= info
[argn
].end
- info
[argn
].start
;
4146 XSETCAR (item
, make_number (translated
));
4148 /* Likewise adjust the property end position. */
4149 pos
= XINT (XCAR (XCDR (item
)));
4151 for (; position
< pos
; bytepos
++)
4153 if (! discarded
[bytepos
])
4154 position
++, translated
++;
4155 else if (discarded
[bytepos
] == 1)
4158 if (translated
== info
[argn
].start
)
4160 translated
+= info
[argn
].end
- info
[argn
].start
;
4166 XSETCAR (XCDR (item
), make_number (translated
));
4169 add_text_properties_from_list (val
, props
, make_number (0));
4172 /* Add text properties from arguments. */
4174 for (n
= 1; n
< nargs
; ++n
)
4175 if (info
[n
].intervals
)
4177 len
= make_number (SCHARS (args
[n
]));
4178 new_len
= make_number (info
[n
].end
- info
[n
].start
);
4179 props
= text_property_list (args
[n
], make_number (0), len
, Qnil
);
4180 props
= extend_property_ranges (props
, new_len
);
4181 /* If successive arguments have properties, be sure that
4182 the value of `composition' property be the copy. */
4183 if (n
> 1 && info
[n
- 1].end
)
4184 make_composition_value_copy (props
);
4185 add_text_properties_from_list (val
, props
,
4186 make_number (info
[n
].start
));
4196 format2 (const char *string1
, Lisp_Object arg0
, Lisp_Object arg1
)
4198 Lisp_Object args
[3];
4199 args
[0] = build_string (string1
);
4202 return Fformat (3, args
);
4205 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
4206 doc
: /* Return t if two characters match, optionally ignoring case.
4207 Both arguments must be characters (i.e. integers).
4208 Case is ignored if `case-fold-search' is non-nil in the current buffer. */)
4209 (register Lisp_Object c1
, Lisp_Object c2
)
4212 /* Check they're chars, not just integers, otherwise we could get array
4213 bounds violations in downcase. */
4214 CHECK_CHARACTER (c1
);
4215 CHECK_CHARACTER (c2
);
4217 if (XINT (c1
) == XINT (c2
))
4219 if (NILP (BVAR (current_buffer
, case_fold_search
)))
4223 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
))
4224 && ! ASCII_CHAR_P (i1
))
4226 MAKE_CHAR_MULTIBYTE (i1
);
4229 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
))
4230 && ! ASCII_CHAR_P (i2
))
4232 MAKE_CHAR_MULTIBYTE (i2
);
4234 return (downcase (i1
) == downcase (i2
) ? Qt
: Qnil
);
4237 /* Transpose the markers in two regions of the current buffer, and
4238 adjust the ones between them if necessary (i.e.: if the regions
4241 START1, END1 are the character positions of the first region.
4242 START1_BYTE, END1_BYTE are the byte positions.
4243 START2, END2 are the character positions of the second region.
4244 START2_BYTE, END2_BYTE are the byte positions.
4246 Traverses the entire marker list of the buffer to do so, adding an
4247 appropriate amount to some, subtracting from some, and leaving the
4248 rest untouched. Most of this is copied from adjust_markers in insdel.c.
4250 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
4253 transpose_markers (EMACS_INT start1
, EMACS_INT end1
,
4254 EMACS_INT start2
, EMACS_INT end2
,
4255 EMACS_INT start1_byte
, EMACS_INT end1_byte
,
4256 EMACS_INT start2_byte
, EMACS_INT end2_byte
)
4258 register EMACS_INT amt1
, amt1_byte
, amt2
, amt2_byte
, diff
, diff_byte
, mpos
;
4259 register struct Lisp_Marker
*marker
;
4261 /* Update point as if it were a marker. */
4265 TEMP_SET_PT_BOTH (PT
+ (end2
- end1
),
4266 PT_BYTE
+ (end2_byte
- end1_byte
));
4267 else if (PT
< start2
)
4268 TEMP_SET_PT_BOTH (PT
+ (end2
- start2
) - (end1
- start1
),
4269 (PT_BYTE
+ (end2_byte
- start2_byte
)
4270 - (end1_byte
- start1_byte
)));
4272 TEMP_SET_PT_BOTH (PT
- (start2
- start1
),
4273 PT_BYTE
- (start2_byte
- start1_byte
));
4275 /* We used to adjust the endpoints here to account for the gap, but that
4276 isn't good enough. Even if we assume the caller has tried to move the
4277 gap out of our way, it might still be at start1 exactly, for example;
4278 and that places it `inside' the interval, for our purposes. The amount
4279 of adjustment is nontrivial if there's a `denormalized' marker whose
4280 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
4281 the dirty work to Fmarker_position, below. */
4283 /* The difference between the region's lengths */
4284 diff
= (end2
- start2
) - (end1
- start1
);
4285 diff_byte
= (end2_byte
- start2_byte
) - (end1_byte
- start1_byte
);
4287 /* For shifting each marker in a region by the length of the other
4288 region plus the distance between the regions. */
4289 amt1
= (end2
- start2
) + (start2
- end1
);
4290 amt2
= (end1
- start1
) + (start2
- end1
);
4291 amt1_byte
= (end2_byte
- start2_byte
) + (start2_byte
- end1_byte
);
4292 amt2_byte
= (end1_byte
- start1_byte
) + (start2_byte
- end1_byte
);
4294 for (marker
= BUF_MARKERS (current_buffer
); marker
; marker
= marker
->next
)
4296 mpos
= marker
->bytepos
;
4297 if (mpos
>= start1_byte
&& mpos
< end2_byte
)
4299 if (mpos
< end1_byte
)
4301 else if (mpos
< start2_byte
)
4305 marker
->bytepos
= mpos
;
4307 mpos
= marker
->charpos
;
4308 if (mpos
>= start1
&& mpos
< end2
)
4312 else if (mpos
< start2
)
4317 marker
->charpos
= mpos
;
4321 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
4322 doc
: /* Transpose region STARTR1 to ENDR1 with STARTR2 to ENDR2.
4323 The regions should not be overlapping, because the size of the buffer is
4324 never changed in a transposition.
4326 Optional fifth arg LEAVE-MARKERS, if non-nil, means don't update
4327 any markers that happen to be located in the regions.
4329 Transposing beyond buffer boundaries is an error. */)
4330 (Lisp_Object startr1
, Lisp_Object endr1
, Lisp_Object startr2
, Lisp_Object endr2
, Lisp_Object leave_markers
)
4332 register EMACS_INT start1
, end1
, start2
, end2
;
4333 EMACS_INT start1_byte
, start2_byte
, len1_byte
, len2_byte
;
4334 EMACS_INT gap
, len1
, len_mid
, len2
;
4335 unsigned char *start1_addr
, *start2_addr
, *temp
;
4337 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
, tmp_interval3
;
4340 XSETBUFFER (buf
, current_buffer
);
4341 cur_intv
= BUF_INTERVALS (current_buffer
);
4343 validate_region (&startr1
, &endr1
);
4344 validate_region (&startr2
, &endr2
);
4346 start1
= XFASTINT (startr1
);
4347 end1
= XFASTINT (endr1
);
4348 start2
= XFASTINT (startr2
);
4349 end2
= XFASTINT (endr2
);
4352 /* Swap the regions if they're reversed. */
4355 register EMACS_INT glumph
= start1
;
4363 len1
= end1
- start1
;
4364 len2
= end2
- start2
;
4367 error ("Transposed regions overlap");
4368 else if (start1
== end1
|| start2
== end2
)
4369 error ("Transposed region has length 0");
4371 /* The possibilities are:
4372 1. Adjacent (contiguous) regions, or separate but equal regions
4373 (no, really equal, in this case!), or
4374 2. Separate regions of unequal size.
4376 The worst case is usually No. 2. It means that (aside from
4377 potential need for getting the gap out of the way), there also
4378 needs to be a shifting of the text between the two regions. So
4379 if they are spread far apart, we are that much slower... sigh. */
4381 /* It must be pointed out that the really studly thing to do would
4382 be not to move the gap at all, but to leave it in place and work
4383 around it if necessary. This would be extremely efficient,
4384 especially considering that people are likely to do
4385 transpositions near where they are working interactively, which
4386 is exactly where the gap would be found. However, such code
4387 would be much harder to write and to read. So, if you are
4388 reading this comment and are feeling squirrely, by all means have
4389 a go! I just didn't feel like doing it, so I will simply move
4390 the gap the minimum distance to get it out of the way, and then
4391 deal with an unbroken array. */
4393 /* Make sure the gap won't interfere, by moving it out of the text
4394 we will operate on. */
4395 if (start1
< gap
&& gap
< end2
)
4397 if (gap
- start1
< end2
- gap
)
4403 start1_byte
= CHAR_TO_BYTE (start1
);
4404 start2_byte
= CHAR_TO_BYTE (start2
);
4405 len1_byte
= CHAR_TO_BYTE (end1
) - start1_byte
;
4406 len2_byte
= CHAR_TO_BYTE (end2
) - start2_byte
;
4408 #ifdef BYTE_COMBINING_DEBUG
4411 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4412 len2_byte
, start1
, start1_byte
)
4413 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4414 len1_byte
, end2
, start2_byte
+ len2_byte
)
4415 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4416 len1_byte
, end2
, start2_byte
+ len2_byte
))
4421 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4422 len2_byte
, start1
, start1_byte
)
4423 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4424 len1_byte
, start2
, start2_byte
)
4425 || count_combining_after (BYTE_POS_ADDR (start2_byte
),
4426 len2_byte
, end1
, start1_byte
+ len1_byte
)
4427 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4428 len1_byte
, end2
, start2_byte
+ len2_byte
))
4433 /* Hmmm... how about checking to see if the gap is large
4434 enough to use as the temporary storage? That would avoid an
4435 allocation... interesting. Later, don't fool with it now. */
4437 /* Working without memmove, for portability (sigh), so must be
4438 careful of overlapping subsections of the array... */
4440 if (end1
== start2
) /* adjacent regions */
4442 modify_region (current_buffer
, start1
, end2
, 0);
4443 record_change (start1
, len1
+ len2
);
4445 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4446 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4447 /* Don't use Fset_text_properties: that can cause GC, which can
4448 clobber objects stored in the tmp_intervals. */
4449 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4450 if (!NULL_INTERVAL_P (tmp_interval3
))
4451 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4453 /* First region smaller than second. */
4454 if (len1_byte
< len2_byte
)
4458 SAFE_ALLOCA (temp
, unsigned char *, len2_byte
);
4460 /* Don't precompute these addresses. We have to compute them
4461 at the last minute, because the relocating allocator might
4462 have moved the buffer around during the xmalloc. */
4463 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4464 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4466 memcpy (temp
, start2_addr
, len2_byte
);
4467 memcpy (start1_addr
+ len2_byte
, start1_addr
, len1_byte
);
4468 memcpy (start1_addr
, temp
, len2_byte
);
4472 /* First region not smaller than second. */
4476 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4477 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4478 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4479 memcpy (temp
, start1_addr
, len1_byte
);
4480 memcpy (start1_addr
, start2_addr
, len2_byte
);
4481 memcpy (start1_addr
+ len2_byte
, temp
, len1_byte
);
4484 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
4485 len1
, current_buffer
, 0);
4486 graft_intervals_into_buffer (tmp_interval2
, start1
,
4487 len2
, current_buffer
, 0);
4488 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4489 update_compositions (start1
+ len2
, end2
, CHECK_TAIL
);
4491 /* Non-adjacent regions, because end1 != start2, bleagh... */
4494 len_mid
= start2_byte
- (start1_byte
+ len1_byte
);
4496 if (len1_byte
== len2_byte
)
4497 /* Regions are same size, though, how nice. */
4501 modify_region (current_buffer
, start1
, end1
, 0);
4502 modify_region (current_buffer
, start2
, end2
, 0);
4503 record_change (start1
, len1
);
4504 record_change (start2
, len2
);
4505 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4506 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4508 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr1
, 0);
4509 if (!NULL_INTERVAL_P (tmp_interval3
))
4510 set_text_properties_1 (startr1
, endr1
, Qnil
, buf
, tmp_interval3
);
4512 tmp_interval3
= validate_interval_range (buf
, &startr2
, &endr2
, 0);
4513 if (!NULL_INTERVAL_P (tmp_interval3
))
4514 set_text_properties_1 (startr2
, endr2
, Qnil
, buf
, tmp_interval3
);
4516 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4517 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4518 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4519 memcpy (temp
, start1_addr
, len1_byte
);
4520 memcpy (start1_addr
, start2_addr
, len2_byte
);
4521 memcpy (start2_addr
, temp
, len1_byte
);
4524 graft_intervals_into_buffer (tmp_interval1
, start2
,
4525 len1
, current_buffer
, 0);
4526 graft_intervals_into_buffer (tmp_interval2
, start1
,
4527 len2
, current_buffer
, 0);
4530 else if (len1_byte
< len2_byte
) /* Second region larger than first */
4531 /* Non-adjacent & unequal size, area between must also be shifted. */
4535 modify_region (current_buffer
, start1
, end2
, 0);
4536 record_change (start1
, (end2
- start1
));
4537 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4538 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4539 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4541 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4542 if (!NULL_INTERVAL_P (tmp_interval3
))
4543 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4545 /* holds region 2 */
4546 SAFE_ALLOCA (temp
, unsigned char *, len2_byte
);
4547 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4548 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4549 memcpy (temp
, start2_addr
, len2_byte
);
4550 memcpy (start1_addr
+ len_mid
+ len2_byte
, start1_addr
, len1_byte
);
4551 memmove (start1_addr
+ len2_byte
, start1_addr
+ len1_byte
, len_mid
);
4552 memcpy (start1_addr
, temp
, len2_byte
);
4555 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4556 len1
, current_buffer
, 0);
4557 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4558 len_mid
, current_buffer
, 0);
4559 graft_intervals_into_buffer (tmp_interval2
, start1
,
4560 len2
, current_buffer
, 0);
4563 /* Second region smaller than first. */
4567 record_change (start1
, (end2
- start1
));
4568 modify_region (current_buffer
, start1
, end2
, 0);
4570 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4571 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4572 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4574 tmp_interval3
= validate_interval_range (buf
, &startr1
, &endr2
, 0);
4575 if (!NULL_INTERVAL_P (tmp_interval3
))
4576 set_text_properties_1 (startr1
, endr2
, Qnil
, buf
, tmp_interval3
);
4578 /* holds region 1 */
4579 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4580 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4581 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4582 memcpy (temp
, start1_addr
, len1_byte
);
4583 memcpy (start1_addr
, start2_addr
, len2_byte
);
4584 memcpy (start1_addr
+ len2_byte
, start1_addr
+ len1_byte
, len_mid
);
4585 memcpy (start1_addr
+ len2_byte
+ len_mid
, temp
, len1_byte
);
4588 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4589 len1
, current_buffer
, 0);
4590 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4591 len_mid
, current_buffer
, 0);
4592 graft_intervals_into_buffer (tmp_interval2
, start1
,
4593 len2
, current_buffer
, 0);
4596 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4597 update_compositions (end2
- len1
, end2
, CHECK_BORDER
);
4600 /* When doing multiple transpositions, it might be nice
4601 to optimize this. Perhaps the markers in any one buffer
4602 should be organized in some sorted data tree. */
4603 if (NILP (leave_markers
))
4605 transpose_markers (start1
, end1
, start2
, end2
,
4606 start1_byte
, start1_byte
+ len1_byte
,
4607 start2_byte
, start2_byte
+ len2_byte
);
4608 fix_start_end_in_overlays (start1
, end2
);
4611 signal_after_change (start1
, end2
- start1
, end2
- start1
);
4617 syms_of_editfns (void)
4622 Qbuffer_access_fontify_functions
4623 = intern_c_string ("buffer-access-fontify-functions");
4624 staticpro (&Qbuffer_access_fontify_functions
);
4626 DEFVAR_LISP ("inhibit-field-text-motion", Vinhibit_field_text_motion
,
4627 doc
: /* Non-nil means text motion commands don't notice fields. */);
4628 Vinhibit_field_text_motion
= Qnil
;
4630 DEFVAR_LISP ("buffer-access-fontify-functions",
4631 Vbuffer_access_fontify_functions
,
4632 doc
: /* List of functions called by `buffer-substring' to fontify if necessary.
4633 Each function is called with two arguments which specify the range
4634 of the buffer being accessed. */);
4635 Vbuffer_access_fontify_functions
= Qnil
;
4639 obuf
= Fcurrent_buffer ();
4640 /* Do this here, because init_buffer_once is too early--it won't work. */
4641 Fset_buffer (Vprin1_to_string_buffer
);
4642 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
4643 Fset (Fmake_local_variable (intern_c_string ("buffer-access-fontify-functions")),
4648 DEFVAR_LISP ("buffer-access-fontified-property",
4649 Vbuffer_access_fontified_property
,
4650 doc
: /* Property which (if non-nil) indicates text has been fontified.
4651 `buffer-substring' need not call the `buffer-access-fontify-functions'
4652 functions if all the text being accessed has this property. */);
4653 Vbuffer_access_fontified_property
= Qnil
;
4655 DEFVAR_LISP ("system-name", Vsystem_name
,
4656 doc
: /* The host name of the machine Emacs is running on. */);
4658 DEFVAR_LISP ("user-full-name", Vuser_full_name
,
4659 doc
: /* The full name of the user logged in. */);
4661 DEFVAR_LISP ("user-login-name", Vuser_login_name
,
4662 doc
: /* The user's name, taken from environment variables if possible. */);
4664 DEFVAR_LISP ("user-real-login-name", Vuser_real_login_name
,
4665 doc
: /* The user's name, based upon the real uid only. */);
4667 DEFVAR_LISP ("operating-system-release", Voperating_system_release
,
4668 doc
: /* The release of the operating system Emacs is running on. */);
4670 defsubr (&Spropertize
);
4671 defsubr (&Schar_equal
);
4672 defsubr (&Sgoto_char
);
4673 defsubr (&Sstring_to_char
);
4674 defsubr (&Schar_to_string
);
4675 defsubr (&Sbyte_to_string
);
4676 defsubr (&Sbuffer_substring
);
4677 defsubr (&Sbuffer_substring_no_properties
);
4678 defsubr (&Sbuffer_string
);
4680 defsubr (&Spoint_marker
);
4681 defsubr (&Smark_marker
);
4683 defsubr (&Sregion_beginning
);
4684 defsubr (&Sregion_end
);
4686 staticpro (&Qfield
);
4687 Qfield
= intern_c_string ("field");
4688 staticpro (&Qboundary
);
4689 Qboundary
= intern_c_string ("boundary");
4690 defsubr (&Sfield_beginning
);
4691 defsubr (&Sfield_end
);
4692 defsubr (&Sfield_string
);
4693 defsubr (&Sfield_string_no_properties
);
4694 defsubr (&Sdelete_field
);
4695 defsubr (&Sconstrain_to_field
);
4697 defsubr (&Sline_beginning_position
);
4698 defsubr (&Sline_end_position
);
4700 /* defsubr (&Smark); */
4701 /* defsubr (&Sset_mark); */
4702 defsubr (&Ssave_excursion
);
4703 defsubr (&Ssave_current_buffer
);
4705 defsubr (&Sbufsize
);
4706 defsubr (&Spoint_max
);
4707 defsubr (&Spoint_min
);
4708 defsubr (&Spoint_min_marker
);
4709 defsubr (&Spoint_max_marker
);
4710 defsubr (&Sgap_position
);
4711 defsubr (&Sgap_size
);
4712 defsubr (&Sposition_bytes
);
4713 defsubr (&Sbyte_to_position
);
4719 defsubr (&Sfollowing_char
);
4720 defsubr (&Sprevious_char
);
4721 defsubr (&Schar_after
);
4722 defsubr (&Schar_before
);
4724 defsubr (&Sinsert_before_markers
);
4725 defsubr (&Sinsert_and_inherit
);
4726 defsubr (&Sinsert_and_inherit_before_markers
);
4727 defsubr (&Sinsert_char
);
4728 defsubr (&Sinsert_byte
);
4730 defsubr (&Suser_login_name
);
4731 defsubr (&Suser_real_login_name
);
4732 defsubr (&Suser_uid
);
4733 defsubr (&Suser_real_uid
);
4734 defsubr (&Suser_full_name
);
4735 defsubr (&Semacs_pid
);
4736 defsubr (&Scurrent_time
);
4737 defsubr (&Sget_internal_run_time
);
4738 defsubr (&Sformat_time_string
);
4739 defsubr (&Sfloat_time
);
4740 defsubr (&Sdecode_time
);
4741 defsubr (&Sencode_time
);
4742 defsubr (&Scurrent_time_string
);
4743 defsubr (&Scurrent_time_zone
);
4744 defsubr (&Sset_time_zone_rule
);
4745 defsubr (&Ssystem_name
);
4746 defsubr (&Smessage
);
4747 defsubr (&Smessage_box
);
4748 defsubr (&Smessage_or_box
);
4749 defsubr (&Scurrent_message
);
4752 defsubr (&Sinsert_buffer_substring
);
4753 defsubr (&Scompare_buffer_substrings
);
4754 defsubr (&Ssubst_char_in_region
);
4755 defsubr (&Stranslate_region_internal
);
4756 defsubr (&Sdelete_region
);
4757 defsubr (&Sdelete_and_extract_region
);
4759 defsubr (&Snarrow_to_region
);
4760 defsubr (&Ssave_restriction
);
4761 defsubr (&Stranspose_regions
);