1 /* Lisp functions pertaining to editing.
2 Copyright (C) 1985, 1986, 1987, 1989, 1993, 1994, 1995, 1996,
3 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
4 2005, 2006, 2007 Free Software Foundation, Inc.
6 This file is part of GNU Emacs.
8 GNU Emacs is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 2, or (at your option)
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs; see the file COPYING. If not, write to
20 the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
21 Boston, MA 02110-1301, USA. */
25 #include <sys/types.h>
36 #ifdef HAVE_SYS_UTSNAME_H
37 #include <sys/utsname.h>
42 /* systime.h includes <sys/time.h> which, on some systems, is required
43 for <sys/resource.h>; thus systime.h must be included before
47 #if defined HAVE_SYS_RESOURCE_H
48 #include <sys/resource.h>
53 #include "intervals.h"
59 #include "blockinput.h"
63 #define MAX_10_EXP DBL_MAX_10_EXP
65 #define MAX_10_EXP 310
73 extern char **environ
;
76 #define TM_YEAR_BASE 1900
78 /* Nonzero if TM_YEAR is a struct tm's tm_year value that causes
79 asctime to have well-defined behavior. */
80 #ifndef TM_YEAR_IN_ASCTIME_RANGE
81 # define TM_YEAR_IN_ASCTIME_RANGE(tm_year) \
82 (1000 - TM_YEAR_BASE <= (tm_year) && (tm_year) <= 9999 - TM_YEAR_BASE)
85 extern size_t emacs_strftimeu
P_ ((char *, size_t, const char *,
86 const struct tm
*, int));
87 static int tm_diff
P_ ((struct tm
*, struct tm
*));
88 static void find_field
P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
, int *, Lisp_Object
, int *));
89 static void update_buffer_properties
P_ ((int, int));
90 static Lisp_Object region_limit
P_ ((int));
91 int lisp_time_argument
P_ ((Lisp_Object
, time_t *, int *));
92 static size_t emacs_memftimeu
P_ ((char *, size_t, const char *,
93 size_t, const struct tm
*, int));
94 static void general_insert_function
P_ ((void (*) (const unsigned char *, int),
95 void (*) (Lisp_Object
, int, int, int,
97 int, int, Lisp_Object
*));
98 static Lisp_Object subst_char_in_region_unwind
P_ ((Lisp_Object
));
99 static Lisp_Object subst_char_in_region_unwind_1
P_ ((Lisp_Object
));
100 static void transpose_markers
P_ ((int, int, int, int, int, int, int, int));
103 extern char *index
P_ ((const char *, int));
106 Lisp_Object Vbuffer_access_fontify_functions
;
107 Lisp_Object Qbuffer_access_fontify_functions
;
108 Lisp_Object Vbuffer_access_fontified_property
;
110 Lisp_Object Fuser_full_name
P_ ((Lisp_Object
));
112 /* Non-nil means don't stop at field boundary in text motion commands. */
114 Lisp_Object Vinhibit_field_text_motion
;
116 /* Some static data, and a function to initialize it for each run */
118 Lisp_Object Vsystem_name
;
119 Lisp_Object Vuser_real_login_name
; /* login name of current user ID */
120 Lisp_Object Vuser_full_name
; /* full name of current user */
121 Lisp_Object Vuser_login_name
; /* user name from LOGNAME or USER */
122 Lisp_Object Voperating_system_release
; /* Operating System Release */
124 /* Symbol for the text property used to mark fields. */
128 /* A special value for Qfield properties. */
130 Lisp_Object Qboundary
;
137 register unsigned char *p
;
138 struct passwd
*pw
; /* password entry for the current user */
141 /* Set up system_name even when dumping. */
145 /* Don't bother with this on initial start when just dumping out */
148 #endif /* not CANNOT_DUMP */
150 pw
= (struct passwd
*) getpwuid (getuid ());
152 /* We let the real user name default to "root" because that's quite
153 accurate on MSDOG and because it lets Emacs find the init file.
154 (The DVX libraries override the Djgpp libraries here.) */
155 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "root");
157 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "unknown");
160 /* Get the effective user name, by consulting environment variables,
161 or the effective uid if those are unset. */
162 user_name
= (char *) getenv ("LOGNAME");
165 user_name
= (char *) getenv ("USERNAME"); /* it's USERNAME on NT */
166 #else /* WINDOWSNT */
167 user_name
= (char *) getenv ("USER");
168 #endif /* WINDOWSNT */
171 pw
= (struct passwd
*) getpwuid (geteuid ());
172 user_name
= (char *) (pw
? pw
->pw_name
: "unknown");
174 Vuser_login_name
= build_string (user_name
);
176 /* If the user name claimed in the environment vars differs from
177 the real uid, use the claimed name to find the full name. */
178 tem
= Fstring_equal (Vuser_login_name
, Vuser_real_login_name
);
179 Vuser_full_name
= Fuser_full_name (NILP (tem
)? make_number (geteuid())
182 p
= (unsigned char *) getenv ("NAME");
184 Vuser_full_name
= build_string (p
);
185 else if (NILP (Vuser_full_name
))
186 Vuser_full_name
= build_string ("unknown");
188 #ifdef HAVE_SYS_UTSNAME_H
192 Voperating_system_release
= build_string (uts
.release
);
195 Voperating_system_release
= Qnil
;
199 DEFUN ("char-to-string", Fchar_to_string
, Schar_to_string
, 1, 1, 0,
200 doc
: /* Convert arg CHAR to a string containing that character.
201 usage: (char-to-string CHAR) */)
203 Lisp_Object character
;
206 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
208 CHECK_NUMBER (character
);
210 len
= (SINGLE_BYTE_CHAR_P (XFASTINT (character
))
211 ? (*str
= (unsigned char)(XFASTINT (character
)), 1)
212 : char_to_string (XFASTINT (character
), str
));
213 return make_string_from_bytes (str
, 1, len
);
216 DEFUN ("string-to-char", Fstring_to_char
, Sstring_to_char
, 1, 1, 0,
217 doc
: /* Convert arg STRING to a character, the first character of that string.
218 A multibyte character is handled correctly. */)
220 register Lisp_Object string
;
222 register Lisp_Object val
;
223 CHECK_STRING (string
);
226 if (STRING_MULTIBYTE (string
))
227 XSETFASTINT (val
, STRING_CHAR (SDATA (string
), SBYTES (string
)));
229 XSETFASTINT (val
, SREF (string
, 0));
232 XSETFASTINT (val
, 0);
237 buildmark (charpos
, bytepos
)
238 int charpos
, bytepos
;
240 register Lisp_Object mark
;
241 mark
= Fmake_marker ();
242 set_marker_both (mark
, Qnil
, charpos
, bytepos
);
246 DEFUN ("point", Fpoint
, Spoint
, 0, 0, 0,
247 doc
: /* Return value of point, as an integer.
248 Beginning of buffer is position (point-min). */)
252 XSETFASTINT (temp
, PT
);
256 DEFUN ("point-marker", Fpoint_marker
, Spoint_marker
, 0, 0, 0,
257 doc
: /* Return value of point, as a marker object. */)
260 return buildmark (PT
, PT_BYTE
);
264 clip_to_bounds (lower
, num
, upper
)
265 int lower
, num
, upper
;
269 else if (num
> upper
)
275 DEFUN ("goto-char", Fgoto_char
, Sgoto_char
, 1, 1, "NGoto char: ",
276 doc
: /* Set point to POSITION, a number or marker.
277 Beginning of buffer is position (point-min), end is (point-max). */)
279 register Lisp_Object position
;
283 if (MARKERP (position
)
284 && current_buffer
== XMARKER (position
)->buffer
)
286 pos
= marker_position (position
);
288 SET_PT_BOTH (BEGV
, BEGV_BYTE
);
290 SET_PT_BOTH (ZV
, ZV_BYTE
);
292 SET_PT_BOTH (pos
, marker_byte_position (position
));
297 CHECK_NUMBER_COERCE_MARKER (position
);
299 pos
= clip_to_bounds (BEGV
, XINT (position
), ZV
);
305 /* Return the start or end position of the region.
306 BEGINNINGP non-zero means return the start.
307 If there is no region active, signal an error. */
310 region_limit (beginningp
)
313 extern Lisp_Object Vmark_even_if_inactive
; /* Defined in callint.c. */
316 if (!NILP (Vtransient_mark_mode
)
317 && NILP (Vmark_even_if_inactive
)
318 && NILP (current_buffer
->mark_active
))
319 xsignal0 (Qmark_inactive
);
321 m
= Fmarker_position (current_buffer
->mark
);
323 error ("The mark is not set now, so there is no region");
325 if ((PT
< XFASTINT (m
)) == (beginningp
!= 0))
326 m
= make_number (PT
);
330 DEFUN ("region-beginning", Fregion_beginning
, Sregion_beginning
, 0, 0, 0,
331 doc
: /* Return position of beginning of region, as an integer. */)
334 return region_limit (1);
337 DEFUN ("region-end", Fregion_end
, Sregion_end
, 0, 0, 0,
338 doc
: /* Return position of end of region, as an integer. */)
341 return region_limit (0);
344 DEFUN ("mark-marker", Fmark_marker
, Smark_marker
, 0, 0, 0,
345 doc
: /* Return this buffer's mark, as a marker object.
346 Watch out! Moving this marker changes the mark position.
347 If you set the marker not to point anywhere, the buffer will have no mark. */)
350 return current_buffer
->mark
;
354 /* Find all the overlays in the current buffer that touch position POS.
355 Return the number found, and store them in a vector in VEC
359 overlays_around (pos
, vec
, len
)
364 Lisp_Object overlay
, start
, end
;
365 struct Lisp_Overlay
*tail
;
366 int startpos
, endpos
;
369 for (tail
= current_buffer
->overlays_before
; tail
; tail
= tail
->next
)
371 XSETMISC (overlay
, tail
);
373 end
= OVERLAY_END (overlay
);
374 endpos
= OVERLAY_POSITION (end
);
377 start
= OVERLAY_START (overlay
);
378 startpos
= OVERLAY_POSITION (start
);
383 /* Keep counting overlays even if we can't return them all. */
388 for (tail
= current_buffer
->overlays_after
; tail
; tail
= tail
->next
)
390 XSETMISC (overlay
, tail
);
392 start
= OVERLAY_START (overlay
);
393 startpos
= OVERLAY_POSITION (start
);
396 end
= OVERLAY_END (overlay
);
397 endpos
= OVERLAY_POSITION (end
);
409 /* Return the value of property PROP, in OBJECT at POSITION.
410 It's the value of PROP that a char inserted at POSITION would get.
411 OBJECT is optional and defaults to the current buffer.
412 If OBJECT is a buffer, then overlay properties are considered as well as
414 If OBJECT is a window, then that window's buffer is used, but
415 window-specific overlays are considered only if they are associated
418 get_pos_property (position
, prop
, object
)
419 Lisp_Object position
, object
;
420 register Lisp_Object prop
;
422 CHECK_NUMBER_COERCE_MARKER (position
);
425 XSETBUFFER (object
, current_buffer
);
426 else if (WINDOWP (object
))
427 object
= XWINDOW (object
)->buffer
;
429 if (!BUFFERP (object
))
430 /* pos-property only makes sense in buffers right now, since strings
431 have no overlays and no notion of insertion for which stickiness
433 return Fget_text_property (position
, prop
, object
);
436 int posn
= XINT (position
);
438 Lisp_Object
*overlay_vec
, tem
;
439 struct buffer
*obuf
= current_buffer
;
441 set_buffer_temp (XBUFFER (object
));
443 /* First try with room for 40 overlays. */
445 overlay_vec
= (Lisp_Object
*) alloca (noverlays
* sizeof (Lisp_Object
));
446 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
448 /* If there are more than 40,
449 make enough space for all, and try again. */
452 overlay_vec
= (Lisp_Object
*) alloca (noverlays
* sizeof (Lisp_Object
));
453 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
455 noverlays
= sort_overlays (overlay_vec
, noverlays
, NULL
);
457 set_buffer_temp (obuf
);
459 /* Now check the overlays in order of decreasing priority. */
460 while (--noverlays
>= 0)
462 Lisp_Object ol
= overlay_vec
[noverlays
];
463 tem
= Foverlay_get (ol
, prop
);
466 /* Check the overlay is indeed active at point. */
467 Lisp_Object start
= OVERLAY_START (ol
), finish
= OVERLAY_END (ol
);
468 if ((OVERLAY_POSITION (start
) == posn
469 && XMARKER (start
)->insertion_type
== 1)
470 || (OVERLAY_POSITION (finish
) == posn
471 && XMARKER (finish
)->insertion_type
== 0))
472 ; /* The overlay will not cover a char inserted at point. */
480 { /* Now check the text-properties. */
481 int stickiness
= text_property_stickiness (prop
, position
, object
);
483 return Fget_text_property (position
, prop
, object
);
484 else if (stickiness
< 0
485 && XINT (position
) > BUF_BEGV (XBUFFER (object
)))
486 return Fget_text_property (make_number (XINT (position
) - 1),
494 /* Find the field surrounding POS in *BEG and *END. If POS is nil,
495 the value of point is used instead. If BEG or END is null,
496 means don't store the beginning or end of the field.
498 BEG_LIMIT and END_LIMIT serve to limit the ranged of the returned
499 results; they do not effect boundary behavior.
501 If MERGE_AT_BOUNDARY is nonzero, then if POS is at the very first
502 position of a field, then the beginning of the previous field is
503 returned instead of the beginning of POS's field (since the end of a
504 field is actually also the beginning of the next input field, this
505 behavior is sometimes useful). Additionally in the MERGE_AT_BOUNDARY
506 true case, if two fields are separated by a field with the special
507 value `boundary', and POS lies within it, then the two separated
508 fields are considered to be adjacent, and POS between them, when
509 finding the beginning and ending of the "merged" field.
511 Either BEG or END may be 0, in which case the corresponding value
515 find_field (pos
, merge_at_boundary
, beg_limit
, beg
, end_limit
, end
)
517 Lisp_Object merge_at_boundary
;
518 Lisp_Object beg_limit
, end_limit
;
521 /* Fields right before and after the point. */
522 Lisp_Object before_field
, after_field
;
523 /* 1 if POS counts as the start of a field. */
524 int at_field_start
= 0;
525 /* 1 if POS counts as the end of a field. */
526 int at_field_end
= 0;
529 XSETFASTINT (pos
, PT
);
531 CHECK_NUMBER_COERCE_MARKER (pos
);
534 = get_char_property_and_overlay (pos
, Qfield
, Qnil
, NULL
);
536 = (XFASTINT (pos
) > BEGV
537 ? get_char_property_and_overlay (make_number (XINT (pos
) - 1),
539 /* Using nil here would be a more obvious choice, but it would
540 fail when the buffer starts with a non-sticky field. */
543 /* See if we need to handle the case where MERGE_AT_BOUNDARY is nil
544 and POS is at beginning of a field, which can also be interpreted
545 as the end of the previous field. Note that the case where if
546 MERGE_AT_BOUNDARY is non-nil (see function comment) is actually the
547 more natural one; then we avoid treating the beginning of a field
549 if (NILP (merge_at_boundary
))
551 Lisp_Object field
= get_pos_property (pos
, Qfield
, Qnil
);
552 if (!EQ (field
, after_field
))
554 if (!EQ (field
, before_field
))
556 if (NILP (field
) && at_field_start
&& at_field_end
)
557 /* If an inserted char would have a nil field while the surrounding
558 text is non-nil, we're probably not looking at a
559 zero-length field, but instead at a non-nil field that's
560 not intended for editing (such as comint's prompts). */
561 at_field_end
= at_field_start
= 0;
564 /* Note about special `boundary' fields:
566 Consider the case where the point (`.') is between the fields `x' and `y':
570 In this situation, if merge_at_boundary is true, we consider the
571 `x' and `y' fields as forming one big merged field, and so the end
572 of the field is the end of `y'.
574 However, if `x' and `y' are separated by a special `boundary' field
575 (a field with a `field' char-property of 'boundary), then we ignore
576 this special field when merging adjacent fields. Here's the same
577 situation, but with a `boundary' field between the `x' and `y' fields:
581 Here, if point is at the end of `x', the beginning of `y', or
582 anywhere in-between (within the `boundary' field), we merge all
583 three fields and consider the beginning as being the beginning of
584 the `x' field, and the end as being the end of the `y' field. */
589 /* POS is at the edge of a field, and we should consider it as
590 the beginning of the following field. */
591 *beg
= XFASTINT (pos
);
593 /* Find the previous field boundary. */
596 if (!NILP (merge_at_boundary
) && EQ (before_field
, Qboundary
))
597 /* Skip a `boundary' field. */
598 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
601 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
603 *beg
= NILP (p
) ? BEGV
: XFASTINT (p
);
610 /* POS is at the edge of a field, and we should consider it as
611 the end of the previous field. */
612 *end
= XFASTINT (pos
);
614 /* Find the next field boundary. */
616 if (!NILP (merge_at_boundary
) && EQ (after_field
, Qboundary
))
617 /* Skip a `boundary' field. */
618 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
621 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
623 *end
= NILP (pos
) ? ZV
: XFASTINT (pos
);
629 DEFUN ("delete-field", Fdelete_field
, Sdelete_field
, 0, 1, 0,
630 doc
: /* Delete the field surrounding POS.
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. */)
637 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
639 del_range (beg
, end
);
643 DEFUN ("field-string", Ffield_string
, Sfield_string
, 0, 1, 0,
644 doc
: /* Return the contents of the field surrounding POS as a string.
645 A field is a region of text with the same `field' property.
646 If POS is nil, the value of point is used for POS. */)
651 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
652 return make_buffer_string (beg
, end
, 1);
655 DEFUN ("field-string-no-properties", Ffield_string_no_properties
, Sfield_string_no_properties
, 0, 1, 0,
656 doc
: /* Return the contents of the field around POS, without text-properties.
657 A field is a region of text with the same `field' property.
658 If POS is nil, the value of point is used for POS. */)
663 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
664 return make_buffer_string (beg
, end
, 0);
667 DEFUN ("field-beginning", Ffield_beginning
, Sfield_beginning
, 0, 3, 0,
668 doc
: /* Return the beginning of the field surrounding POS.
669 A field is a region of text with the same `field' property.
670 If POS is nil, the value of point is used for POS.
671 If ESCAPE-FROM-EDGE is non-nil and POS is at the beginning of its
672 field, then the beginning of the *previous* field is returned.
673 If LIMIT is non-nil, it is a buffer position; if the beginning of the field
674 is before LIMIT, then LIMIT will be returned instead. */)
675 (pos
, escape_from_edge
, limit
)
676 Lisp_Object pos
, escape_from_edge
, limit
;
679 find_field (pos
, escape_from_edge
, limit
, &beg
, Qnil
, 0);
680 return make_number (beg
);
683 DEFUN ("field-end", Ffield_end
, Sfield_end
, 0, 3, 0,
684 doc
: /* Return the end of the field surrounding POS.
685 A field is a region of text with the same `field' property.
686 If POS is nil, the value of point is used for POS.
687 If ESCAPE-FROM-EDGE is non-nil and POS is at the end of its field,
688 then the end of the *following* field is returned.
689 If LIMIT is non-nil, it is a buffer position; if the end of the field
690 is after LIMIT, then LIMIT will be returned instead. */)
691 (pos
, escape_from_edge
, limit
)
692 Lisp_Object pos
, escape_from_edge
, limit
;
695 find_field (pos
, escape_from_edge
, Qnil
, 0, limit
, &end
);
696 return make_number (end
);
699 DEFUN ("constrain-to-field", Fconstrain_to_field
, Sconstrain_to_field
, 2, 5, 0,
700 doc
: /* Return the position closest to NEW-POS that is in the same field as OLD-POS.
702 A field is a region of text with the same `field' property.
703 If NEW-POS is nil, then the current point is used instead, and set to the
704 constrained position if that is different.
706 If OLD-POS is at the boundary of two fields, then the allowable
707 positions for NEW-POS depends on the value of the optional argument
708 ESCAPE-FROM-EDGE: If ESCAPE-FROM-EDGE is nil, then NEW-POS is
709 constrained to the field that has the same `field' char-property
710 as any new characters inserted at OLD-POS, whereas if ESCAPE-FROM-EDGE
711 is non-nil, NEW-POS is constrained to the union of the two adjacent
712 fields. Additionally, if two fields are separated by another field with
713 the special value `boundary', then any point within this special field is
714 also considered to be `on the boundary'.
716 If the optional argument ONLY-IN-LINE is non-nil and constraining
717 NEW-POS would move it to a different line, NEW-POS is returned
718 unconstrained. This useful for commands that move by line, like
719 \\[next-line] or \\[beginning-of-line], which should generally respect field boundaries
720 only in the case where they can still move to the right line.
722 If the optional argument INHIBIT-CAPTURE-PROPERTY is non-nil, and OLD-POS has
723 a non-nil property of that name, then any field boundaries are ignored.
725 Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */)
726 (new_pos
, old_pos
, escape_from_edge
, only_in_line
, inhibit_capture_property
)
727 Lisp_Object new_pos
, old_pos
;
728 Lisp_Object escape_from_edge
, only_in_line
, inhibit_capture_property
;
730 /* If non-zero, then the original point, before re-positioning. */
733 Lisp_Object prev_old
, prev_new
;
736 /* Use the current point, and afterwards, set it. */
739 XSETFASTINT (new_pos
, PT
);
742 CHECK_NUMBER_COERCE_MARKER (new_pos
);
743 CHECK_NUMBER_COERCE_MARKER (old_pos
);
745 fwd
= (XFASTINT (new_pos
) > XFASTINT (old_pos
));
747 prev_old
= make_number (XFASTINT (old_pos
) - 1);
748 prev_new
= make_number (XFASTINT (new_pos
) - 1);
750 if (NILP (Vinhibit_field_text_motion
)
751 && !EQ (new_pos
, old_pos
)
752 && (!NILP (Fget_char_property (new_pos
, Qfield
, Qnil
))
753 || !NILP (Fget_char_property (old_pos
, Qfield
, Qnil
))
754 /* To recognize field boundaries, we must also look at the
755 previous positions; we could use `get_pos_property'
756 instead, but in itself that would fail inside non-sticky
757 fields (like comint prompts). */
758 || (XFASTINT (new_pos
) > BEGV
759 && !NILP (Fget_char_property (prev_new
, Qfield
, Qnil
)))
760 || (XFASTINT (old_pos
) > BEGV
761 && !NILP (Fget_char_property (prev_old
, Qfield
, Qnil
))))
762 && (NILP (inhibit_capture_property
)
763 /* Field boundaries are again a problem; but now we must
764 decide the case exactly, so we need to call
765 `get_pos_property' as well. */
766 || (NILP (get_pos_property (old_pos
, inhibit_capture_property
, Qnil
))
767 && (XFASTINT (old_pos
) <= BEGV
768 || NILP (Fget_char_property (old_pos
, inhibit_capture_property
, Qnil
))
769 || NILP (Fget_char_property (prev_old
, inhibit_capture_property
, Qnil
))))))
770 /* It is possible that NEW_POS is not within the same field as
771 OLD_POS; try to move NEW_POS so that it is. */
774 Lisp_Object field_bound
;
777 field_bound
= Ffield_end (old_pos
, escape_from_edge
, new_pos
);
779 field_bound
= Ffield_beginning (old_pos
, escape_from_edge
, new_pos
);
781 if (/* See if ESCAPE_FROM_EDGE caused FIELD_BOUND to jump to the
782 other side of NEW_POS, which would mean that NEW_POS is
783 already acceptable, and it's not necessary to constrain it
785 ((XFASTINT (field_bound
) < XFASTINT (new_pos
)) ? fwd
: !fwd
)
786 /* NEW_POS should be constrained, but only if either
787 ONLY_IN_LINE is nil (in which case any constraint is OK),
788 or NEW_POS and FIELD_BOUND are on the same line (in which
789 case the constraint is OK even if ONLY_IN_LINE is non-nil). */
790 && (NILP (only_in_line
)
791 /* This is the ONLY_IN_LINE case, check that NEW_POS and
792 FIELD_BOUND are on the same line by seeing whether
793 there's an intervening newline or not. */
794 || (scan_buffer ('\n',
795 XFASTINT (new_pos
), XFASTINT (field_bound
),
796 fwd
? -1 : 1, &shortage
, 1),
798 /* Constrain NEW_POS to FIELD_BOUND. */
799 new_pos
= field_bound
;
801 if (orig_point
&& XFASTINT (new_pos
) != orig_point
)
802 /* The NEW_POS argument was originally nil, so automatically set PT. */
803 SET_PT (XFASTINT (new_pos
));
810 DEFUN ("line-beginning-position",
811 Fline_beginning_position
, Sline_beginning_position
, 0, 1, 0,
812 doc
: /* Return the character position of the first character on the current line.
813 With argument N not nil or 1, move forward N - 1 lines first.
814 If scan reaches end of buffer, return that position.
816 This function constrains the returned position to the current field
817 unless that would be on a different line than the original,
818 unconstrained result. If N is nil or 1, and a front-sticky field
819 starts at point, the scan stops as soon as it starts. To ignore field
820 boundaries bind `inhibit-field-text-motion' to t.
822 This function does not move point. */)
826 int orig
, orig_byte
, end
;
827 int count
= SPECPDL_INDEX ();
828 specbind (Qinhibit_point_motion_hooks
, Qt
);
837 Fforward_line (make_number (XINT (n
) - 1));
840 SET_PT_BOTH (orig
, orig_byte
);
842 unbind_to (count
, Qnil
);
844 /* Return END constrained to the current input field. */
845 return Fconstrain_to_field (make_number (end
), make_number (orig
),
846 XINT (n
) != 1 ? Qt
: Qnil
,
850 DEFUN ("line-end-position", Fline_end_position
, Sline_end_position
, 0, 1, 0,
851 doc
: /* Return the character position of the last character on the current line.
852 With argument N not nil or 1, move forward N - 1 lines first.
853 If scan reaches end of buffer, return that position.
855 This function constrains the returned position to the current field
856 unless that would be on a different line than the original,
857 unconstrained result. If N is nil or 1, and a rear-sticky field ends
858 at point, the scan stops as soon as it starts. To ignore field
859 boundaries bind `inhibit-field-text-motion' to t.
861 This function does not move point. */)
873 end_pos
= find_before_next_newline (orig
, 0, XINT (n
) - (XINT (n
) <= 0));
875 /* Return END_POS constrained to the current input field. */
876 return Fconstrain_to_field (make_number (end_pos
), make_number (orig
),
882 save_excursion_save ()
884 int visible
= (XBUFFER (XWINDOW (selected_window
)->buffer
)
887 return Fcons (Fpoint_marker (),
888 Fcons (Fcopy_marker (current_buffer
->mark
, Qnil
),
889 Fcons (visible
? Qt
: Qnil
,
890 Fcons (current_buffer
->mark_active
,
895 save_excursion_restore (info
)
898 Lisp_Object tem
, tem1
, omark
, nmark
;
899 struct gcpro gcpro1
, gcpro2
, gcpro3
;
902 tem
= Fmarker_buffer (XCAR (info
));
903 /* If buffer being returned to is now deleted, avoid error */
904 /* Otherwise could get error here while unwinding to top level
906 /* In that case, Fmarker_buffer returns nil now. */
910 omark
= nmark
= Qnil
;
911 GCPRO3 (info
, omark
, nmark
);
918 unchain_marker (XMARKER (tem
));
923 omark
= Fmarker_position (current_buffer
->mark
);
924 Fset_marker (current_buffer
->mark
, tem
, Fcurrent_buffer ());
925 nmark
= Fmarker_position (tem
);
926 unchain_marker (XMARKER (tem
));
930 visible_p
= !NILP (XCAR (info
));
932 #if 0 /* We used to make the current buffer visible in the selected window
933 if that was true previously. That avoids some anomalies.
934 But it creates others, and it wasn't documented, and it is simpler
935 and cleaner never to alter the window/buffer connections. */
938 && current_buffer
!= XBUFFER (XWINDOW (selected_window
)->buffer
))
939 Fswitch_to_buffer (Fcurrent_buffer (), Qnil
);
945 tem1
= current_buffer
->mark_active
;
946 current_buffer
->mark_active
= tem
;
948 if (!NILP (Vrun_hooks
))
950 /* If mark is active now, and either was not active
951 or was at a different place, run the activate hook. */
952 if (! NILP (current_buffer
->mark_active
))
954 if (! EQ (omark
, nmark
))
955 call1 (Vrun_hooks
, intern ("activate-mark-hook"));
957 /* If mark has ceased to be active, run deactivate hook. */
958 else if (! NILP (tem1
))
959 call1 (Vrun_hooks
, intern ("deactivate-mark-hook"));
962 /* If buffer was visible in a window, and a different window was
963 selected, and the old selected window is still showing this
964 buffer, restore point in that window. */
967 && !EQ (tem
, selected_window
)
968 && (tem1
= XWINDOW (tem
)->buffer
,
969 (/* Window is live... */
971 /* ...and it shows the current buffer. */
972 && XBUFFER (tem1
) == current_buffer
)))
973 Fset_window_point (tem
, make_number (PT
));
979 DEFUN ("save-excursion", Fsave_excursion
, Ssave_excursion
, 0, UNEVALLED
, 0,
980 doc
: /* Save point, mark, and current buffer; execute BODY; restore those things.
981 Executes BODY just like `progn'.
982 The values of point, mark and the current buffer are restored
983 even in case of abnormal exit (throw or error).
984 The state of activation of the mark is also restored.
986 This construct does not save `deactivate-mark', and therefore
987 functions that change the buffer will still cause deactivation
988 of the mark at the end of the command. To prevent that, bind
989 `deactivate-mark' with `let'.
991 usage: (save-excursion &rest BODY) */)
995 register Lisp_Object val
;
996 int count
= SPECPDL_INDEX ();
998 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
1000 val
= Fprogn (args
);
1001 return unbind_to (count
, val
);
1004 DEFUN ("save-current-buffer", Fsave_current_buffer
, Ssave_current_buffer
, 0, UNEVALLED
, 0,
1005 doc
: /* Save the current buffer; execute BODY; restore the current buffer.
1006 Executes BODY just like `progn'.
1007 usage: (save-current-buffer &rest BODY) */)
1012 int count
= SPECPDL_INDEX ();
1014 record_unwind_protect (set_buffer_if_live
, Fcurrent_buffer ());
1016 val
= Fprogn (args
);
1017 return unbind_to (count
, val
);
1020 DEFUN ("buffer-size", Fbufsize
, Sbufsize
, 0, 1, 0,
1021 doc
: /* Return the number of characters in the current buffer.
1022 If BUFFER, return the number of characters in that buffer instead. */)
1027 return make_number (Z
- BEG
);
1030 CHECK_BUFFER (buffer
);
1031 return make_number (BUF_Z (XBUFFER (buffer
))
1032 - BUF_BEG (XBUFFER (buffer
)));
1036 DEFUN ("point-min", Fpoint_min
, Spoint_min
, 0, 0, 0,
1037 doc
: /* Return the minimum permissible value of point in the current buffer.
1038 This is 1, unless narrowing (a buffer restriction) is in effect. */)
1042 XSETFASTINT (temp
, BEGV
);
1046 DEFUN ("point-min-marker", Fpoint_min_marker
, Spoint_min_marker
, 0, 0, 0,
1047 doc
: /* Return a marker to the minimum permissible value of point in this buffer.
1048 This is the beginning, unless narrowing (a buffer restriction) is in effect. */)
1051 return buildmark (BEGV
, BEGV_BYTE
);
1054 DEFUN ("point-max", Fpoint_max
, Spoint_max
, 0, 0, 0,
1055 doc
: /* Return the maximum permissible value of point in the current buffer.
1056 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1057 is in effect, in which case it is less. */)
1061 XSETFASTINT (temp
, ZV
);
1065 DEFUN ("point-max-marker", Fpoint_max_marker
, Spoint_max_marker
, 0, 0, 0,
1066 doc
: /* Return a marker to the maximum permissible value of point in this buffer.
1067 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1068 is in effect, in which case it is less. */)
1071 return buildmark (ZV
, ZV_BYTE
);
1074 DEFUN ("gap-position", Fgap_position
, Sgap_position
, 0, 0, 0,
1075 doc
: /* Return the position of the gap, in the current buffer.
1076 See also `gap-size'. */)
1080 XSETFASTINT (temp
, GPT
);
1084 DEFUN ("gap-size", Fgap_size
, Sgap_size
, 0, 0, 0,
1085 doc
: /* Return the size of the current buffer's gap.
1086 See also `gap-position'. */)
1090 XSETFASTINT (temp
, GAP_SIZE
);
1094 DEFUN ("position-bytes", Fposition_bytes
, Sposition_bytes
, 1, 1, 0,
1095 doc
: /* Return the byte position for character position POSITION.
1096 If POSITION is out of range, the value is nil. */)
1098 Lisp_Object position
;
1100 CHECK_NUMBER_COERCE_MARKER (position
);
1101 if (XINT (position
) < BEG
|| XINT (position
) > Z
)
1103 return make_number (CHAR_TO_BYTE (XINT (position
)));
1106 DEFUN ("byte-to-position", Fbyte_to_position
, Sbyte_to_position
, 1, 1, 0,
1107 doc
: /* Return the character position for byte position BYTEPOS.
1108 If BYTEPOS is out of range, the value is nil. */)
1110 Lisp_Object bytepos
;
1112 CHECK_NUMBER (bytepos
);
1113 if (XINT (bytepos
) < BEG_BYTE
|| XINT (bytepos
) > Z_BYTE
)
1115 return make_number (BYTE_TO_CHAR (XINT (bytepos
)));
1118 DEFUN ("following-char", Ffollowing_char
, Sfollowing_char
, 0, 0, 0,
1119 doc
: /* Return the character following point, as a number.
1120 At the end of the buffer or accessible region, return 0. */)
1125 XSETFASTINT (temp
, 0);
1127 XSETFASTINT (temp
, FETCH_CHAR (PT_BYTE
));
1131 DEFUN ("preceding-char", Fprevious_char
, Sprevious_char
, 0, 0, 0,
1132 doc
: /* Return the character preceding point, as a number.
1133 At the beginning of the buffer or accessible region, return 0. */)
1138 XSETFASTINT (temp
, 0);
1139 else if (!NILP (current_buffer
->enable_multibyte_characters
))
1143 XSETFASTINT (temp
, FETCH_CHAR (pos
));
1146 XSETFASTINT (temp
, FETCH_BYTE (PT_BYTE
- 1));
1150 DEFUN ("bobp", Fbobp
, Sbobp
, 0, 0, 0,
1151 doc
: /* Return t if point is at the beginning of the buffer.
1152 If the buffer is narrowed, this means the beginning of the narrowed part. */)
1160 DEFUN ("eobp", Feobp
, Seobp
, 0, 0, 0,
1161 doc
: /* Return t if point is at the end of the buffer.
1162 If the buffer is narrowed, this means the end of the narrowed part. */)
1170 DEFUN ("bolp", Fbolp
, Sbolp
, 0, 0, 0,
1171 doc
: /* Return t if point is at the beginning of a line. */)
1174 if (PT
== BEGV
|| FETCH_BYTE (PT_BYTE
- 1) == '\n')
1179 DEFUN ("eolp", Feolp
, Seolp
, 0, 0, 0,
1180 doc
: /* Return t if point is at the end of a line.
1181 `End of a line' includes point being at the end of the buffer. */)
1184 if (PT
== ZV
|| FETCH_BYTE (PT_BYTE
) == '\n')
1189 DEFUN ("char-after", Fchar_after
, Schar_after
, 0, 1, 0,
1190 doc
: /* Return character in current buffer at position POS.
1191 POS is an integer or a marker and defaults to point.
1192 If POS is out of range, the value is nil. */)
1196 register int pos_byte
;
1201 XSETFASTINT (pos
, PT
);
1206 pos_byte
= marker_byte_position (pos
);
1207 if (pos_byte
< BEGV_BYTE
|| pos_byte
>= ZV_BYTE
)
1212 CHECK_NUMBER_COERCE_MARKER (pos
);
1213 if (XINT (pos
) < BEGV
|| XINT (pos
) >= ZV
)
1216 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1219 return make_number (FETCH_CHAR (pos_byte
));
1222 DEFUN ("char-before", Fchar_before
, Schar_before
, 0, 1, 0,
1223 doc
: /* Return character in current buffer preceding position POS.
1224 POS is an integer or a marker and defaults to point.
1225 If POS is out of range, the value is nil. */)
1229 register Lisp_Object val
;
1230 register int pos_byte
;
1235 XSETFASTINT (pos
, PT
);
1240 pos_byte
= marker_byte_position (pos
);
1242 if (pos_byte
<= BEGV_BYTE
|| pos_byte
> ZV_BYTE
)
1247 CHECK_NUMBER_COERCE_MARKER (pos
);
1249 if (XINT (pos
) <= BEGV
|| XINT (pos
) > ZV
)
1252 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1255 if (!NILP (current_buffer
->enable_multibyte_characters
))
1258 XSETFASTINT (val
, FETCH_CHAR (pos_byte
));
1263 XSETFASTINT (val
, FETCH_BYTE (pos_byte
));
1268 DEFUN ("user-login-name", Fuser_login_name
, Suser_login_name
, 0, 1, 0,
1269 doc
: /* Return the name under which the user logged in, as a string.
1270 This is based on the effective uid, not the real uid.
1271 Also, if the environment variables LOGNAME or USER are set,
1272 that determines the value of this function.
1274 If optional argument UID is an integer, return the login name of the user
1275 with that uid, or nil if there is no such user. */)
1281 /* Set up the user name info if we didn't do it before.
1282 (That can happen if Emacs is dumpable
1283 but you decide to run `temacs -l loadup' and not dump. */
1284 if (INTEGERP (Vuser_login_name
))
1288 return Vuser_login_name
;
1292 pw
= (struct passwd
*) getpwuid (XINT (uid
));
1294 return (pw
? build_string (pw
->pw_name
) : Qnil
);
1297 DEFUN ("user-real-login-name", Fuser_real_login_name
, Suser_real_login_name
,
1299 doc
: /* Return the name of the user's real uid, as a string.
1300 This ignores the environment variables LOGNAME and USER, so it differs from
1301 `user-login-name' when running under `su'. */)
1304 /* Set up the user name info if we didn't do it before.
1305 (That can happen if Emacs is dumpable
1306 but you decide to run `temacs -l loadup' and not dump. */
1307 if (INTEGERP (Vuser_login_name
))
1309 return Vuser_real_login_name
;
1312 DEFUN ("user-uid", Fuser_uid
, Suser_uid
, 0, 0, 0,
1313 doc
: /* Return the effective uid of Emacs.
1314 Value is an integer or float, depending on the value. */)
1317 /* Assignment to EMACS_INT stops GCC whining about limited range of
1319 EMACS_INT euid
= geteuid ();
1320 return make_fixnum_or_float (euid
);
1323 DEFUN ("user-real-uid", Fuser_real_uid
, Suser_real_uid
, 0, 0, 0,
1324 doc
: /* Return the real uid of Emacs.
1325 Value is an integer or float, depending on the value. */)
1328 /* Assignment to EMACS_INT stops GCC whining about limited range of
1330 EMACS_INT uid
= getuid ();
1331 return make_fixnum_or_float (uid
);
1334 DEFUN ("user-full-name", Fuser_full_name
, Suser_full_name
, 0, 1, 0,
1335 doc
: /* Return the full name of the user logged in, as a string.
1336 If the full name corresponding to Emacs's userid is not known,
1339 If optional argument UID is an integer or float, return the full name
1340 of the user with that uid, or nil if there is no such user.
1341 If UID is a string, return the full name of the user with that login
1342 name, or nil if there is no such user. */)
1347 register unsigned char *p
, *q
;
1351 return Vuser_full_name
;
1352 else if (NUMBERP (uid
))
1355 pw
= (struct passwd
*) getpwuid ((uid_t
) XFLOATINT (uid
));
1358 else if (STRINGP (uid
))
1361 pw
= (struct passwd
*) getpwnam (SDATA (uid
));
1365 error ("Invalid UID specification");
1370 p
= (unsigned char *) USER_FULL_NAME
;
1371 /* Chop off everything after the first comma. */
1372 q
= (unsigned char *) index (p
, ',');
1373 full
= make_string (p
, q
? q
- p
: strlen (p
));
1375 #ifdef AMPERSAND_FULL_NAME
1377 q
= (unsigned char *) index (p
, '&');
1378 /* Substitute the login name for the &, upcasing the first character. */
1381 register unsigned char *r
;
1384 login
= Fuser_login_name (make_number (pw
->pw_uid
));
1385 r
= (unsigned char *) alloca (strlen (p
) + SCHARS (login
) + 1);
1386 bcopy (p
, r
, q
- p
);
1388 strcat (r
, SDATA (login
));
1389 r
[q
- p
] = UPCASE (r
[q
- p
]);
1391 full
= build_string (r
);
1393 #endif /* AMPERSAND_FULL_NAME */
1398 DEFUN ("system-name", Fsystem_name
, Ssystem_name
, 0, 0, 0,
1399 doc
: /* Return the host name of the machine you are running on, as a string. */)
1402 return Vsystem_name
;
1405 /* For the benefit of callers who don't want to include lisp.h */
1410 if (STRINGP (Vsystem_name
))
1411 return (char *) SDATA (Vsystem_name
);
1417 get_operating_system_release()
1419 if (STRINGP (Voperating_system_release
))
1420 return (char *) SDATA (Voperating_system_release
);
1425 DEFUN ("emacs-pid", Femacs_pid
, Semacs_pid
, 0, 0, 0,
1426 doc
: /* Return the process ID of Emacs, as an integer. */)
1429 return make_number (getpid ());
1432 DEFUN ("current-time", Fcurrent_time
, Scurrent_time
, 0, 0, 0,
1433 doc
: /* Return the current time, as the number of seconds since 1970-01-01 00:00:00.
1434 The time is returned as a list of three integers. The first has the
1435 most significant 16 bits of the seconds, while the second has the
1436 least significant 16 bits. The third integer gives the microsecond
1439 The microsecond count is zero on systems that do not provide
1440 resolution finer than a second. */)
1446 return list3 (make_number ((EMACS_SECS (t
) >> 16) & 0xffff),
1447 make_number ((EMACS_SECS (t
) >> 0) & 0xffff),
1448 make_number (EMACS_USECS (t
)));
1451 DEFUN ("get-internal-run-time", Fget_internal_run_time
, Sget_internal_run_time
,
1453 doc
: /* Return the current run time used by Emacs.
1454 The time is returned as a list of three integers. The first has the
1455 most significant 16 bits of the seconds, while the second has the
1456 least significant 16 bits. The third integer gives the microsecond
1459 On systems that can't determine the run time, get-internal-run-time
1460 does the same thing as current-time. The microsecond count is zero on
1461 systems that do not provide resolution finer than a second. */)
1464 #ifdef HAVE_GETRUSAGE
1465 struct rusage usage
;
1468 if (getrusage (RUSAGE_SELF
, &usage
) < 0)
1469 /* This shouldn't happen. What action is appropriate? */
1472 /* Sum up user time and system time. */
1473 secs
= usage
.ru_utime
.tv_sec
+ usage
.ru_stime
.tv_sec
;
1474 usecs
= usage
.ru_utime
.tv_usec
+ usage
.ru_stime
.tv_usec
;
1475 if (usecs
>= 1000000)
1481 return list3 (make_number ((secs
>> 16) & 0xffff),
1482 make_number ((secs
>> 0) & 0xffff),
1483 make_number (usecs
));
1485 return Fcurrent_time ();
1491 lisp_time_argument (specified_time
, result
, usec
)
1492 Lisp_Object specified_time
;
1496 if (NILP (specified_time
))
1503 *usec
= EMACS_USECS (t
);
1504 *result
= EMACS_SECS (t
);
1508 return time (result
) != -1;
1512 Lisp_Object high
, low
;
1513 high
= Fcar (specified_time
);
1514 CHECK_NUMBER (high
);
1515 low
= Fcdr (specified_time
);
1520 Lisp_Object usec_l
= Fcdr (low
);
1522 usec_l
= Fcar (usec_l
);
1527 CHECK_NUMBER (usec_l
);
1528 *usec
= XINT (usec_l
);
1536 *result
= (XINT (high
) << 16) + (XINT (low
) & 0xffff);
1537 return *result
>> 16 == XINT (high
);
1541 DEFUN ("float-time", Ffloat_time
, Sfloat_time
, 0, 1, 0,
1542 doc
: /* Return the current time, as a float number of seconds since the epoch.
1543 If SPECIFIED-TIME is given, it is the time to convert to float
1544 instead of the current time. The argument should have the form
1545 (HIGH LOW . IGNORED). Thus, you can use times obtained from
1546 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
1547 have the form (HIGH . LOW), but this is considered obsolete.
1549 WARNING: Since the result is floating point, it may not be exact.
1550 Do not use this function if precise time stamps are required. */)
1552 Lisp_Object specified_time
;
1557 if (! lisp_time_argument (specified_time
, &sec
, &usec
))
1558 error ("Invalid time specification");
1560 return make_float ((sec
* 1e6
+ usec
) / 1e6
);
1563 /* Write information into buffer S of size MAXSIZE, according to the
1564 FORMAT of length FORMAT_LEN, using time information taken from *TP.
1565 Default to Universal Time if UT is nonzero, local time otherwise.
1566 Return the number of bytes written, not including the terminating
1567 '\0'. If S is NULL, nothing will be written anywhere; so to
1568 determine how many bytes would be written, use NULL for S and
1569 ((size_t) -1) for MAXSIZE.
1571 This function behaves like emacs_strftimeu, except it allows null
1574 emacs_memftimeu (s
, maxsize
, format
, format_len
, tp
, ut
)
1579 const struct tm
*tp
;
1584 /* Loop through all the null-terminated strings in the format
1585 argument. Normally there's just one null-terminated string, but
1586 there can be arbitrarily many, concatenated together, if the
1587 format contains '\0' bytes. emacs_strftimeu stops at the first
1588 '\0' byte so we must invoke it separately for each such string. */
1597 result
= emacs_strftimeu (s
, maxsize
, format
, tp
, ut
);
1601 if (result
== 0 && s
[0] != '\0')
1606 maxsize
-= result
+ 1;
1608 len
= strlen (format
);
1609 if (len
== format_len
)
1613 format_len
-= len
+ 1;
1617 DEFUN ("format-time-string", Fformat_time_string
, Sformat_time_string
, 1, 3, 0,
1618 doc
: /* Use FORMAT-STRING to format the time TIME, or now if omitted.
1619 TIME is specified as (HIGH LOW . IGNORED), as returned by
1620 `current-time' or `file-attributes'. The obsolete form (HIGH . LOW)
1621 is also still accepted.
1622 The third, optional, argument UNIVERSAL, if non-nil, means describe TIME
1623 as Universal Time; nil means describe TIME in the local time zone.
1624 The value is a copy of FORMAT-STRING, but with certain constructs replaced
1625 by text that describes the specified date and time in TIME:
1627 %Y is the year, %y within the century, %C the century.
1628 %G is the year corresponding to the ISO week, %g within the century.
1629 %m is the numeric month.
1630 %b and %h are the locale's abbreviated month name, %B the full name.
1631 %d is the day of the month, zero-padded, %e is blank-padded.
1632 %u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.
1633 %a is the locale's abbreviated name of the day of week, %A the full name.
1634 %U is the week number starting on Sunday, %W starting on Monday,
1635 %V according to ISO 8601.
1636 %j is the day of the year.
1638 %H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H
1639 only blank-padded, %l is like %I blank-padded.
1640 %p is the locale's equivalent of either AM or PM.
1643 %Z is the time zone name, %z is the numeric form.
1644 %s is the number of seconds since 1970-01-01 00:00:00 +0000.
1646 %c is the locale's date and time format.
1647 %x is the locale's "preferred" date format.
1648 %D is like "%m/%d/%y".
1650 %R is like "%H:%M", %T is like "%H:%M:%S", %r is like "%I:%M:%S %p".
1651 %X is the locale's "preferred" time format.
1653 Finally, %n is a newline, %t is a tab, %% is a literal %.
1655 Certain flags and modifiers are available with some format controls.
1656 The flags are `_', `-', `^' and `#'. For certain characters X,
1657 %_X is like %X, but padded with blanks; %-X is like %X,
1658 but without padding. %^X is like %X, but with all textual
1659 characters up-cased; %#X is like %X, but with letter-case of
1660 all textual characters reversed.
1661 %NX (where N stands for an integer) is like %X,
1662 but takes up at least N (a number) positions.
1663 The modifiers are `E' and `O'. For certain characters X,
1664 %EX is a locale's alternative version of %X;
1665 %OX is like %X, but uses the locale's number symbols.
1667 For example, to produce full ISO 8601 format, use "%Y-%m-%dT%T%z". */)
1668 (format_string
, time
, universal
)
1669 Lisp_Object format_string
, time
, universal
;
1674 int ut
= ! NILP (universal
);
1676 CHECK_STRING (format_string
);
1678 if (! lisp_time_argument (time
, &value
, NULL
))
1679 error ("Invalid time specification");
1681 format_string
= code_convert_string_norecord (format_string
,
1682 Vlocale_coding_system
, 1);
1684 /* This is probably enough. */
1685 size
= SBYTES (format_string
) * 6 + 50;
1688 tm
= ut
? gmtime (&value
) : localtime (&value
);
1691 error ("Specified time is not representable");
1693 synchronize_system_time_locale ();
1697 char *buf
= (char *) alloca (size
+ 1);
1702 result
= emacs_memftimeu (buf
, size
, SDATA (format_string
),
1703 SBYTES (format_string
),
1706 if ((result
> 0 && result
< size
) || (result
== 0 && buf
[0] == '\0'))
1707 return code_convert_string_norecord (make_unibyte_string (buf
, result
),
1708 Vlocale_coding_system
, 0);
1710 /* If buffer was too small, make it bigger and try again. */
1712 result
= emacs_memftimeu (NULL
, (size_t) -1,
1713 SDATA (format_string
),
1714 SBYTES (format_string
),
1721 DEFUN ("decode-time", Fdecode_time
, Sdecode_time
, 0, 1, 0,
1722 doc
: /* Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST ZONE).
1723 The optional SPECIFIED-TIME should be a list of (HIGH LOW . IGNORED),
1724 as from `current-time' and `file-attributes', or `nil' to use the
1725 current time. The obsolete form (HIGH . LOW) is also still accepted.
1726 The list has the following nine members: SEC is an integer between 0
1727 and 60; SEC is 60 for a leap second, which only some operating systems
1728 support. MINUTE is an integer between 0 and 59. HOUR is an integer
1729 between 0 and 23. DAY is an integer between 1 and 31. MONTH is an
1730 integer between 1 and 12. YEAR is an integer indicating the
1731 four-digit year. DOW is the day of week, an integer between 0 and 6,
1732 where 0 is Sunday. DST is t if daylight savings time is effect,
1733 otherwise nil. ZONE is an integer indicating the number of seconds
1734 east of Greenwich. (Note that Common Lisp has different meanings for
1737 Lisp_Object specified_time
;
1741 struct tm
*decoded_time
;
1742 Lisp_Object list_args
[9];
1744 if (! lisp_time_argument (specified_time
, &time_spec
, NULL
))
1745 error ("Invalid time specification");
1748 decoded_time
= localtime (&time_spec
);
1751 error ("Specified time is not representable");
1752 XSETFASTINT (list_args
[0], decoded_time
->tm_sec
);
1753 XSETFASTINT (list_args
[1], decoded_time
->tm_min
);
1754 XSETFASTINT (list_args
[2], decoded_time
->tm_hour
);
1755 XSETFASTINT (list_args
[3], decoded_time
->tm_mday
);
1756 XSETFASTINT (list_args
[4], decoded_time
->tm_mon
+ 1);
1757 /* On 64-bit machines an int is narrower than EMACS_INT, thus the
1758 cast below avoids overflow in int arithmetics. */
1759 XSETINT (list_args
[5], TM_YEAR_BASE
+ (EMACS_INT
) decoded_time
->tm_year
);
1760 XSETFASTINT (list_args
[6], decoded_time
->tm_wday
);
1761 list_args
[7] = (decoded_time
->tm_isdst
)? Qt
: Qnil
;
1763 /* Make a copy, in case gmtime modifies the struct. */
1764 save_tm
= *decoded_time
;
1766 decoded_time
= gmtime (&time_spec
);
1768 if (decoded_time
== 0)
1769 list_args
[8] = Qnil
;
1771 XSETINT (list_args
[8], tm_diff (&save_tm
, decoded_time
));
1772 return Flist (9, list_args
);
1775 DEFUN ("encode-time", Fencode_time
, Sencode_time
, 6, MANY
, 0,
1776 doc
: /* Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.
1777 This is the reverse operation of `decode-time', which see.
1778 ZONE defaults to the current time zone rule. This can
1779 be a string or t (as from `set-time-zone-rule'), or it can be a list
1780 \(as from `current-time-zone') or an integer (as from `decode-time')
1781 applied without consideration for daylight savings time.
1783 You can pass more than 7 arguments; then the first six arguments
1784 are used as SECOND through YEAR, and the *last* argument is used as ZONE.
1785 The intervening arguments are ignored.
1786 This feature lets (apply 'encode-time (decode-time ...)) work.
1788 Out-of-range values for SECOND, MINUTE, HOUR, DAY, or MONTH are allowed;
1789 for example, a DAY of 0 means the day preceding the given month.
1790 Year numbers less than 100 are treated just like other year numbers.
1791 If you want them to stand for years in this century, you must do that yourself.
1793 Years before 1970 are not guaranteed to work. On some systems,
1794 year values as low as 1901 do work.
1796 usage: (encode-time SECOND MINUTE HOUR DAY MONTH YEAR &optional ZONE) */)
1799 register Lisp_Object
*args
;
1803 Lisp_Object zone
= (nargs
> 6 ? args
[nargs
- 1] : Qnil
);
1805 CHECK_NUMBER (args
[0]); /* second */
1806 CHECK_NUMBER (args
[1]); /* minute */
1807 CHECK_NUMBER (args
[2]); /* hour */
1808 CHECK_NUMBER (args
[3]); /* day */
1809 CHECK_NUMBER (args
[4]); /* month */
1810 CHECK_NUMBER (args
[5]); /* year */
1812 tm
.tm_sec
= XINT (args
[0]);
1813 tm
.tm_min
= XINT (args
[1]);
1814 tm
.tm_hour
= XINT (args
[2]);
1815 tm
.tm_mday
= XINT (args
[3]);
1816 tm
.tm_mon
= XINT (args
[4]) - 1;
1817 tm
.tm_year
= XINT (args
[5]) - TM_YEAR_BASE
;
1825 time
= mktime (&tm
);
1832 char **oldenv
= environ
, **newenv
;
1836 else if (STRINGP (zone
))
1837 tzstring
= (char *) SDATA (zone
);
1838 else if (INTEGERP (zone
))
1840 int abszone
= abs (XINT (zone
));
1841 sprintf (tzbuf
, "XXX%s%d:%02d:%02d", "-" + (XINT (zone
) < 0),
1842 abszone
/ (60*60), (abszone
/60) % 60, abszone
% 60);
1846 error ("Invalid time zone specification");
1848 /* Set TZ before calling mktime; merely adjusting mktime's returned
1849 value doesn't suffice, since that would mishandle leap seconds. */
1850 set_time_zone_rule (tzstring
);
1853 time
= mktime (&tm
);
1856 /* Restore TZ to previous value. */
1860 #ifdef LOCALTIME_CACHE
1865 if (time
== (time_t) -1)
1866 error ("Specified time is not representable");
1868 return make_time (time
);
1871 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
, 0, 1, 0,
1872 doc
: /* Return the current time, as a human-readable string.
1873 Programs can use this function to decode a time,
1874 since the number of columns in each field is fixed
1875 if the year is in the range 1000-9999.
1876 The format is `Sun Sep 16 01:03:52 1973'.
1877 However, see also the functions `decode-time' and `format-time-string'
1878 which provide a much more powerful and general facility.
1880 If SPECIFIED-TIME is given, it is a time to format instead of the
1881 current time. The argument should have the form (HIGH LOW . IGNORED).
1882 Thus, you can use times obtained from `current-time' and from
1883 `file-attributes'. SPECIFIED-TIME can also have the form (HIGH . LOW),
1884 but this is considered obsolete. */)
1886 Lisp_Object specified_time
;
1892 if (! lisp_time_argument (specified_time
, &value
, NULL
))
1893 error ("Invalid time specification");
1895 /* Convert to a string, checking for out-of-range time stamps.
1896 Don't use 'ctime', as that might dump core if VALUE is out of
1899 tm
= localtime (&value
);
1901 if (! (tm
&& TM_YEAR_IN_ASCTIME_RANGE (tm
->tm_year
) && (tem
= asctime (tm
))))
1902 error ("Specified time is not representable");
1904 /* Remove the trailing newline. */
1905 tem
[strlen (tem
) - 1] = '\0';
1907 return build_string (tem
);
1910 /* Yield A - B, measured in seconds.
1911 This function is copied from the GNU C Library. */
1916 /* Compute intervening leap days correctly even if year is negative.
1917 Take care to avoid int overflow in leap day calculations,
1918 but it's OK to assume that A and B are close to each other. */
1919 int a4
= (a
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (a
->tm_year
& 3);
1920 int b4
= (b
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (b
->tm_year
& 3);
1921 int a100
= a4
/ 25 - (a4
% 25 < 0);
1922 int b100
= b4
/ 25 - (b4
% 25 < 0);
1923 int a400
= a100
>> 2;
1924 int b400
= b100
>> 2;
1925 int intervening_leap_days
= (a4
- b4
) - (a100
- b100
) + (a400
- b400
);
1926 int years
= a
->tm_year
- b
->tm_year
;
1927 int days
= (365 * years
+ intervening_leap_days
1928 + (a
->tm_yday
- b
->tm_yday
));
1929 return (60 * (60 * (24 * days
+ (a
->tm_hour
- b
->tm_hour
))
1930 + (a
->tm_min
- b
->tm_min
))
1931 + (a
->tm_sec
- b
->tm_sec
));
1934 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 1, 0,
1935 doc
: /* Return the offset and name for the local time zone.
1936 This returns a list of the form (OFFSET NAME).
1937 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).
1938 A negative value means west of Greenwich.
1939 NAME is a string giving the name of the time zone.
1940 If SPECIFIED-TIME is given, the time zone offset is determined from it
1941 instead of using the current time. The argument should have the form
1942 (HIGH LOW . IGNORED). Thus, you can use times obtained from
1943 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
1944 have the form (HIGH . LOW), but this is considered obsolete.
1946 Some operating systems cannot provide all this information to Emacs;
1947 in this case, `current-time-zone' returns a list containing nil for
1948 the data it can't find. */)
1950 Lisp_Object specified_time
;
1956 if (!lisp_time_argument (specified_time
, &value
, NULL
))
1961 t
= gmtime (&value
);
1965 t
= localtime (&value
);
1972 int offset
= tm_diff (t
, &gmt
);
1977 s
= (char *)t
->tm_zone
;
1978 #else /* not HAVE_TM_ZONE */
1980 if (t
->tm_isdst
== 0 || t
->tm_isdst
== 1)
1981 s
= tzname
[t
->tm_isdst
];
1983 #endif /* not HAVE_TM_ZONE */
1985 #if defined HAVE_TM_ZONE || defined HAVE_TZNAME
1988 /* On Japanese w32, we can get a Japanese string as time
1989 zone name. Don't accept that. */
1991 for (p
= s
; *p
&& (isalnum ((unsigned char)*p
) || *p
== ' '); ++p
)
2000 /* No local time zone name is available; use "+-NNNN" instead. */
2001 int am
= (offset
< 0 ? -offset
: offset
) / 60;
2002 sprintf (buf
, "%c%02d%02d", (offset
< 0 ? '-' : '+'), am
/60, am
%60);
2005 return Fcons (make_number (offset
), Fcons (build_string (s
), Qnil
));
2008 return Fmake_list (make_number (2), Qnil
);
2011 /* This holds the value of `environ' produced by the previous
2012 call to Fset_time_zone_rule, or 0 if Fset_time_zone_rule
2013 has never been called. */
2014 static char **environbuf
;
2016 DEFUN ("set-time-zone-rule", Fset_time_zone_rule
, Sset_time_zone_rule
, 1, 1, 0,
2017 doc
: /* Set the local time zone using TZ, a string specifying a time zone rule.
2018 If TZ is nil, use implementation-defined default time zone information.
2019 If TZ is t, use Universal Time. */)
2027 else if (EQ (tz
, Qt
))
2032 tzstring
= (char *) SDATA (tz
);
2035 set_time_zone_rule (tzstring
);
2038 environbuf
= environ
;
2043 #ifdef LOCALTIME_CACHE
2045 /* These two values are known to load tz files in buggy implementations,
2046 i.e. Solaris 1 executables running under either Solaris 1 or Solaris 2.
2047 Their values shouldn't matter in non-buggy implementations.
2048 We don't use string literals for these strings,
2049 since if a string in the environment is in readonly
2050 storage, it runs afoul of bugs in SVR4 and Solaris 2.3.
2051 See Sun bugs 1113095 and 1114114, ``Timezone routines
2052 improperly modify environment''. */
2054 static char set_time_zone_rule_tz1
[] = "TZ=GMT+0";
2055 static char set_time_zone_rule_tz2
[] = "TZ=GMT+1";
2059 /* Set the local time zone rule to TZSTRING.
2060 This allocates memory into `environ', which it is the caller's
2061 responsibility to free. */
2064 set_time_zone_rule (tzstring
)
2068 char **from
, **to
, **newenv
;
2070 /* Make the ENVIRON vector longer with room for TZSTRING. */
2071 for (from
= environ
; *from
; from
++)
2073 envptrs
= from
- environ
+ 2;
2074 newenv
= to
= (char **) xmalloc (envptrs
* sizeof (char *)
2075 + (tzstring
? strlen (tzstring
) + 4 : 0));
2077 /* Add TZSTRING to the end of environ, as a value for TZ. */
2080 char *t
= (char *) (to
+ envptrs
);
2082 strcat (t
, tzstring
);
2086 /* Copy the old environ vector elements into NEWENV,
2087 but don't copy the TZ variable.
2088 So we have only one definition of TZ, which came from TZSTRING. */
2089 for (from
= environ
; *from
; from
++)
2090 if (strncmp (*from
, "TZ=", 3) != 0)
2096 /* If we do have a TZSTRING, NEWENV points to the vector slot where
2097 the TZ variable is stored. If we do not have a TZSTRING,
2098 TO points to the vector slot which has the terminating null. */
2100 #ifdef LOCALTIME_CACHE
2102 /* In SunOS 4.1.3_U1 and 4.1.4, if TZ has a value like
2103 "US/Pacific" that loads a tz file, then changes to a value like
2104 "XXX0" that does not load a tz file, and then changes back to
2105 its original value, the last change is (incorrectly) ignored.
2106 Also, if TZ changes twice in succession to values that do
2107 not load a tz file, tzset can dump core (see Sun bug#1225179).
2108 The following code works around these bugs. */
2112 /* Temporarily set TZ to a value that loads a tz file
2113 and that differs from tzstring. */
2115 *newenv
= (strcmp (tzstring
, set_time_zone_rule_tz1
+ 3) == 0
2116 ? set_time_zone_rule_tz2
: set_time_zone_rule_tz1
);
2122 /* The implied tzstring is unknown, so temporarily set TZ to
2123 two different values that each load a tz file. */
2124 *to
= set_time_zone_rule_tz1
;
2127 *to
= set_time_zone_rule_tz2
;
2132 /* Now TZ has the desired value, and tzset can be invoked safely. */
2139 /* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC
2140 (if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a
2141 type of object is Lisp_String). INHERIT is passed to
2142 INSERT_FROM_STRING_FUNC as the last argument. */
2145 general_insert_function (insert_func
, insert_from_string_func
,
2146 inherit
, nargs
, args
)
2147 void (*insert_func
) P_ ((const unsigned char *, int));
2148 void (*insert_from_string_func
) P_ ((Lisp_Object
, int, int, int, int, int));
2150 register Lisp_Object
*args
;
2152 register int argnum
;
2153 register Lisp_Object val
;
2155 for (argnum
= 0; argnum
< nargs
; argnum
++)
2160 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2163 if (!NILP (current_buffer
->enable_multibyte_characters
))
2164 len
= CHAR_STRING (XFASTINT (val
), str
);
2167 str
[0] = (SINGLE_BYTE_CHAR_P (XINT (val
))
2169 : multibyte_char_to_unibyte (XINT (val
), Qnil
));
2172 (*insert_func
) (str
, len
);
2174 else if (STRINGP (val
))
2176 (*insert_from_string_func
) (val
, 0, 0,
2182 wrong_type_argument (Qchar_or_string_p
, val
);
2194 /* Callers passing one argument to Finsert need not gcpro the
2195 argument "array", since the only element of the array will
2196 not be used after calling insert or insert_from_string, so
2197 we don't care if it gets trashed. */
2199 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
2200 doc
: /* Insert the arguments, either strings or characters, at point.
2201 Point and before-insertion markers move forward to end up
2202 after the inserted text.
2203 Any other markers at the point of insertion remain before the text.
2205 If the current buffer is multibyte, unibyte strings are converted
2206 to multibyte for insertion (see `string-make-multibyte').
2207 If the current buffer is unibyte, multibyte strings are converted
2208 to unibyte for insertion (see `string-make-unibyte').
2210 When operating on binary data, it may be necessary to preserve the
2211 original bytes of a unibyte string when inserting it into a multibyte
2212 buffer; to accomplish this, apply `string-as-multibyte' to the string
2213 and insert the result.
2215 usage: (insert &rest ARGS) */)
2218 register Lisp_Object
*args
;
2220 general_insert_function (insert
, insert_from_string
, 0, nargs
, args
);
2224 DEFUN ("insert-and-inherit", Finsert_and_inherit
, Sinsert_and_inherit
,
2226 doc
: /* Insert the arguments at point, inheriting properties from adjoining text.
2227 Point and before-insertion markers move forward to end up
2228 after the inserted text.
2229 Any other markers at the point of insertion remain before the text.
2231 If the current buffer is multibyte, unibyte strings are converted
2232 to multibyte for insertion (see `unibyte-char-to-multibyte').
2233 If the current buffer is unibyte, multibyte strings are converted
2234 to unibyte for insertion.
2236 usage: (insert-and-inherit &rest ARGS) */)
2239 register Lisp_Object
*args
;
2241 general_insert_function (insert_and_inherit
, insert_from_string
, 1,
2246 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
2247 doc
: /* Insert strings or characters at point, relocating markers after the text.
2248 Point and markers move forward to end up after the inserted text.
2250 If the current buffer is multibyte, unibyte strings are converted
2251 to multibyte for insertion (see `unibyte-char-to-multibyte').
2252 If the current buffer is unibyte, multibyte strings are converted
2253 to unibyte for insertion.
2255 usage: (insert-before-markers &rest ARGS) */)
2258 register Lisp_Object
*args
;
2260 general_insert_function (insert_before_markers
,
2261 insert_from_string_before_markers
, 0,
2266 DEFUN ("insert-before-markers-and-inherit", Finsert_and_inherit_before_markers
,
2267 Sinsert_and_inherit_before_markers
, 0, MANY
, 0,
2268 doc
: /* Insert text at point, relocating markers and inheriting properties.
2269 Point and markers move forward to end up after the inserted text.
2271 If the current buffer is multibyte, unibyte strings are converted
2272 to multibyte for insertion (see `unibyte-char-to-multibyte').
2273 If the current buffer is unibyte, multibyte strings are converted
2274 to unibyte for insertion.
2276 usage: (insert-before-markers-and-inherit &rest ARGS) */)
2279 register Lisp_Object
*args
;
2281 general_insert_function (insert_before_markers_and_inherit
,
2282 insert_from_string_before_markers
, 1,
2287 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 2, 3, 0,
2288 doc
: /* Insert COUNT (second arg) copies of CHARACTER (first arg).
2289 Both arguments are required.
2290 Point, and before-insertion markers, are relocated as in the function `insert'.
2291 The optional third arg INHERIT, if non-nil, says to inherit text properties
2292 from adjoining text, if those properties are sticky. */)
2293 (character
, count
, inherit
)
2294 Lisp_Object character
, count
, inherit
;
2296 register unsigned char *string
;
2297 register int strlen
;
2300 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2302 CHECK_NUMBER (character
);
2303 CHECK_NUMBER (count
);
2305 if (!NILP (current_buffer
->enable_multibyte_characters
))
2306 len
= CHAR_STRING (XFASTINT (character
), str
);
2308 str
[0] = XFASTINT (character
), len
= 1;
2309 n
= XINT (count
) * len
;
2312 strlen
= min (n
, 256 * len
);
2313 string
= (unsigned char *) alloca (strlen
);
2314 for (i
= 0; i
< strlen
; i
++)
2315 string
[i
] = str
[i
% len
];
2319 if (!NILP (inherit
))
2320 insert_and_inherit (string
, strlen
);
2322 insert (string
, strlen
);
2327 if (!NILP (inherit
))
2328 insert_and_inherit (string
, n
);
2336 /* Making strings from buffer contents. */
2338 /* Return a Lisp_String containing the text of the current buffer from
2339 START to END. If text properties are in use and the current buffer
2340 has properties in the range specified, the resulting string will also
2341 have them, if PROPS is nonzero.
2343 We don't want to use plain old make_string here, because it calls
2344 make_uninit_string, which can cause the buffer arena to be
2345 compacted. make_string has no way of knowing that the data has
2346 been moved, and thus copies the wrong data into the string. This
2347 doesn't effect most of the other users of make_string, so it should
2348 be left as is. But we should use this function when conjuring
2349 buffer substrings. */
2352 make_buffer_string (start
, end
, props
)
2356 int start_byte
= CHAR_TO_BYTE (start
);
2357 int end_byte
= CHAR_TO_BYTE (end
);
2359 return make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
);
2362 /* Return a Lisp_String containing the text of the current buffer from
2363 START / START_BYTE to END / END_BYTE.
2365 If text properties are in use and the current buffer
2366 has properties in the range specified, the resulting string will also
2367 have them, if PROPS is nonzero.
2369 We don't want to use plain old make_string here, because it calls
2370 make_uninit_string, which can cause the buffer arena to be
2371 compacted. make_string has no way of knowing that the data has
2372 been moved, and thus copies the wrong data into the string. This
2373 doesn't effect most of the other users of make_string, so it should
2374 be left as is. But we should use this function when conjuring
2375 buffer substrings. */
2378 make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
)
2379 int start
, start_byte
, end
, end_byte
;
2382 Lisp_Object result
, tem
, tem1
;
2384 if (start
< GPT
&& GPT
< end
)
2387 if (! NILP (current_buffer
->enable_multibyte_characters
))
2388 result
= make_uninit_multibyte_string (end
- start
, end_byte
- start_byte
);
2390 result
= make_uninit_string (end
- start
);
2391 bcopy (BYTE_POS_ADDR (start_byte
), SDATA (result
),
2392 end_byte
- start_byte
);
2394 /* If desired, update and copy the text properties. */
2397 update_buffer_properties (start
, end
);
2399 tem
= Fnext_property_change (make_number (start
), Qnil
, make_number (end
));
2400 tem1
= Ftext_properties_at (make_number (start
), Qnil
);
2402 if (XINT (tem
) != end
|| !NILP (tem1
))
2403 copy_intervals_to_string (result
, current_buffer
, start
,
2410 /* Call Vbuffer_access_fontify_functions for the range START ... END
2411 in the current buffer, if necessary. */
2414 update_buffer_properties (start
, end
)
2417 /* If this buffer has some access functions,
2418 call them, specifying the range of the buffer being accessed. */
2419 if (!NILP (Vbuffer_access_fontify_functions
))
2421 Lisp_Object args
[3];
2424 args
[0] = Qbuffer_access_fontify_functions
;
2425 XSETINT (args
[1], start
);
2426 XSETINT (args
[2], end
);
2428 /* But don't call them if we can tell that the work
2429 has already been done. */
2430 if (!NILP (Vbuffer_access_fontified_property
))
2432 tem
= Ftext_property_any (args
[1], args
[2],
2433 Vbuffer_access_fontified_property
,
2436 Frun_hook_with_args (3, args
);
2439 Frun_hook_with_args (3, args
);
2443 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
2444 doc
: /* Return the contents of part of the current buffer as a string.
2445 The two arguments START and END are character positions;
2446 they can be in either order.
2447 The string returned is multibyte if the buffer is multibyte.
2449 This function copies the text properties of that part of the buffer
2450 into the result string; if you don't want the text properties,
2451 use `buffer-substring-no-properties' instead. */)
2453 Lisp_Object start
, end
;
2457 validate_region (&start
, &end
);
2461 return make_buffer_string (b
, e
, 1);
2464 DEFUN ("buffer-substring-no-properties", Fbuffer_substring_no_properties
,
2465 Sbuffer_substring_no_properties
, 2, 2, 0,
2466 doc
: /* Return the characters of part of the buffer, without the text properties.
2467 The two arguments START and END are character positions;
2468 they can be in either order. */)
2470 Lisp_Object start
, end
;
2474 validate_region (&start
, &end
);
2478 return make_buffer_string (b
, e
, 0);
2481 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
2482 doc
: /* Return the contents of the current buffer as a string.
2483 If narrowing is in effect, this function returns only the visible part
2487 return make_buffer_string (BEGV
, ZV
, 1);
2490 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
2492 doc
: /* Insert before point a substring of the contents of BUFFER.
2493 BUFFER may be a buffer or a buffer name.
2494 Arguments START and END are character positions specifying the substring.
2495 They default to the values of (point-min) and (point-max) in BUFFER. */)
2496 (buffer
, start
, end
)
2497 Lisp_Object buffer
, start
, end
;
2499 register int b
, e
, temp
;
2500 register struct buffer
*bp
, *obuf
;
2503 buf
= Fget_buffer (buffer
);
2507 if (NILP (bp
->name
))
2508 error ("Selecting deleted buffer");
2514 CHECK_NUMBER_COERCE_MARKER (start
);
2521 CHECK_NUMBER_COERCE_MARKER (end
);
2526 temp
= b
, b
= e
, e
= temp
;
2528 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
2529 args_out_of_range (start
, end
);
2531 obuf
= current_buffer
;
2532 set_buffer_internal_1 (bp
);
2533 update_buffer_properties (b
, e
);
2534 set_buffer_internal_1 (obuf
);
2536 insert_from_buffer (bp
, b
, e
- b
, 0);
2540 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
2542 doc
: /* Compare two substrings of two buffers; return result as number.
2543 the value is -N if first string is less after N-1 chars,
2544 +N if first string is greater after N-1 chars, or 0 if strings match.
2545 Each substring is represented as three arguments: BUFFER, START and END.
2546 That makes six args in all, three for each substring.
2548 The value of `case-fold-search' in the current buffer
2549 determines whether case is significant or ignored. */)
2550 (buffer1
, start1
, end1
, buffer2
, start2
, end2
)
2551 Lisp_Object buffer1
, start1
, end1
, buffer2
, start2
, end2
;
2553 register int begp1
, endp1
, begp2
, endp2
, temp
;
2554 register struct buffer
*bp1
, *bp2
;
2555 register Lisp_Object trt
2556 = (!NILP (current_buffer
->case_fold_search
)
2557 ? current_buffer
->case_canon_table
: Qnil
);
2559 int i1
, i2
, i1_byte
, i2_byte
;
2561 /* Find the first buffer and its substring. */
2564 bp1
= current_buffer
;
2568 buf1
= Fget_buffer (buffer1
);
2571 bp1
= XBUFFER (buf1
);
2572 if (NILP (bp1
->name
))
2573 error ("Selecting deleted buffer");
2577 begp1
= BUF_BEGV (bp1
);
2580 CHECK_NUMBER_COERCE_MARKER (start1
);
2581 begp1
= XINT (start1
);
2584 endp1
= BUF_ZV (bp1
);
2587 CHECK_NUMBER_COERCE_MARKER (end1
);
2588 endp1
= XINT (end1
);
2592 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
2594 if (!(BUF_BEGV (bp1
) <= begp1
2596 && endp1
<= BUF_ZV (bp1
)))
2597 args_out_of_range (start1
, end1
);
2599 /* Likewise for second substring. */
2602 bp2
= current_buffer
;
2606 buf2
= Fget_buffer (buffer2
);
2609 bp2
= XBUFFER (buf2
);
2610 if (NILP (bp2
->name
))
2611 error ("Selecting deleted buffer");
2615 begp2
= BUF_BEGV (bp2
);
2618 CHECK_NUMBER_COERCE_MARKER (start2
);
2619 begp2
= XINT (start2
);
2622 endp2
= BUF_ZV (bp2
);
2625 CHECK_NUMBER_COERCE_MARKER (end2
);
2626 endp2
= XINT (end2
);
2630 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
2632 if (!(BUF_BEGV (bp2
) <= begp2
2634 && endp2
<= BUF_ZV (bp2
)))
2635 args_out_of_range (start2
, end2
);
2639 i1_byte
= buf_charpos_to_bytepos (bp1
, i1
);
2640 i2_byte
= buf_charpos_to_bytepos (bp2
, i2
);
2642 while (i1
< endp1
&& i2
< endp2
)
2644 /* When we find a mismatch, we must compare the
2645 characters, not just the bytes. */
2650 if (! NILP (bp1
->enable_multibyte_characters
))
2652 c1
= BUF_FETCH_MULTIBYTE_CHAR (bp1
, i1_byte
);
2653 BUF_INC_POS (bp1
, i1_byte
);
2658 c1
= BUF_FETCH_BYTE (bp1
, i1
);
2659 c1
= unibyte_char_to_multibyte (c1
);
2663 if (! NILP (bp2
->enable_multibyte_characters
))
2665 c2
= BUF_FETCH_MULTIBYTE_CHAR (bp2
, i2_byte
);
2666 BUF_INC_POS (bp2
, i2_byte
);
2671 c2
= BUF_FETCH_BYTE (bp2
, i2
);
2672 c2
= unibyte_char_to_multibyte (c2
);
2678 c1
= CHAR_TABLE_TRANSLATE (trt
, c1
);
2679 c2
= CHAR_TABLE_TRANSLATE (trt
, c2
);
2682 return make_number (- 1 - chars
);
2684 return make_number (chars
+ 1);
2689 /* The strings match as far as they go.
2690 If one is shorter, that one is less. */
2691 if (chars
< endp1
- begp1
)
2692 return make_number (chars
+ 1);
2693 else if (chars
< endp2
- begp2
)
2694 return make_number (- chars
- 1);
2696 /* Same length too => they are equal. */
2697 return make_number (0);
2701 subst_char_in_region_unwind (arg
)
2704 return current_buffer
->undo_list
= arg
;
2708 subst_char_in_region_unwind_1 (arg
)
2711 return current_buffer
->filename
= arg
;
2714 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
2715 Ssubst_char_in_region
, 4, 5, 0,
2716 doc
: /* From START to END, replace FROMCHAR with TOCHAR each time it occurs.
2717 If optional arg NOUNDO is non-nil, don't record this change for undo
2718 and don't mark the buffer as really changed.
2719 Both characters must have the same length of multi-byte form. */)
2720 (start
, end
, fromchar
, tochar
, noundo
)
2721 Lisp_Object start
, end
, fromchar
, tochar
, noundo
;
2723 register int pos
, pos_byte
, stop
, i
, len
, end_byte
;
2724 /* Keep track of the first change in the buffer:
2725 if 0 we haven't found it yet.
2726 if < 0 we've found it and we've run the before-change-function.
2727 if > 0 we've actually performed it and the value is its position. */
2729 unsigned char fromstr
[MAX_MULTIBYTE_LENGTH
], tostr
[MAX_MULTIBYTE_LENGTH
];
2731 int count
= SPECPDL_INDEX ();
2732 #define COMBINING_NO 0
2733 #define COMBINING_BEFORE 1
2734 #define COMBINING_AFTER 2
2735 #define COMBINING_BOTH (COMBINING_BEFORE | COMBINING_AFTER)
2736 int maybe_byte_combining
= COMBINING_NO
;
2737 int last_changed
= 0;
2738 int multibyte_p
= !NILP (current_buffer
->enable_multibyte_characters
);
2742 validate_region (&start
, &end
);
2743 CHECK_NUMBER (fromchar
);
2744 CHECK_NUMBER (tochar
);
2748 len
= CHAR_STRING (XFASTINT (fromchar
), fromstr
);
2749 if (CHAR_STRING (XFASTINT (tochar
), tostr
) != len
)
2750 error ("Characters in `subst-char-in-region' have different byte-lengths");
2751 if (!ASCII_BYTE_P (*tostr
))
2753 /* If *TOSTR is in the range 0x80..0x9F and TOCHAR is not a
2754 complete multibyte character, it may be combined with the
2755 after bytes. If it is in the range 0xA0..0xFF, it may be
2756 combined with the before and after bytes. */
2757 if (!CHAR_HEAD_P (*tostr
))
2758 maybe_byte_combining
= COMBINING_BOTH
;
2759 else if (BYTES_BY_CHAR_HEAD (*tostr
) > len
)
2760 maybe_byte_combining
= COMBINING_AFTER
;
2766 fromstr
[0] = XFASTINT (fromchar
);
2767 tostr
[0] = XFASTINT (tochar
);
2771 pos_byte
= CHAR_TO_BYTE (pos
);
2772 stop
= CHAR_TO_BYTE (XINT (end
));
2775 /* If we don't want undo, turn off putting stuff on the list.
2776 That's faster than getting rid of things,
2777 and it prevents even the entry for a first change.
2778 Also inhibit locking the file. */
2779 if (!changed
&& !NILP (noundo
))
2781 record_unwind_protect (subst_char_in_region_unwind
,
2782 current_buffer
->undo_list
);
2783 current_buffer
->undo_list
= Qt
;
2784 /* Don't do file-locking. */
2785 record_unwind_protect (subst_char_in_region_unwind_1
,
2786 current_buffer
->filename
);
2787 current_buffer
->filename
= Qnil
;
2790 if (pos_byte
< GPT_BYTE
)
2791 stop
= min (stop
, GPT_BYTE
);
2794 int pos_byte_next
= pos_byte
;
2796 if (pos_byte
>= stop
)
2798 if (pos_byte
>= end_byte
) break;
2801 p
= BYTE_POS_ADDR (pos_byte
);
2803 INC_POS (pos_byte_next
);
2806 if (pos_byte_next
- pos_byte
== len
2807 && p
[0] == fromstr
[0]
2809 || (p
[1] == fromstr
[1]
2810 && (len
== 2 || (p
[2] == fromstr
[2]
2811 && (len
== 3 || p
[3] == fromstr
[3]))))))
2814 /* We've already seen this and run the before-change-function;
2815 this time we only need to record the actual position. */
2820 modify_region (current_buffer
, pos
, XINT (end
), 0);
2822 if (! NILP (noundo
))
2824 if (MODIFF
- 1 == SAVE_MODIFF
)
2826 if (MODIFF
- 1 == current_buffer
->auto_save_modified
)
2827 current_buffer
->auto_save_modified
++;
2830 /* The before-change-function may have moved the gap
2831 or even modified the buffer so we should start over. */
2835 /* Take care of the case where the new character
2836 combines with neighboring bytes. */
2837 if (maybe_byte_combining
2838 && (maybe_byte_combining
== COMBINING_AFTER
2839 ? (pos_byte_next
< Z_BYTE
2840 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2841 : ((pos_byte_next
< Z_BYTE
2842 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2843 || (pos_byte
> BEG_BYTE
2844 && ! ASCII_BYTE_P (FETCH_BYTE (pos_byte
- 1))))))
2846 Lisp_Object tem
, string
;
2848 struct gcpro gcpro1
;
2850 tem
= current_buffer
->undo_list
;
2853 /* Make a multibyte string containing this single character. */
2854 string
= make_multibyte_string (tostr
, 1, len
);
2855 /* replace_range is less efficient, because it moves the gap,
2856 but it handles combining correctly. */
2857 replace_range (pos
, pos
+ 1, string
,
2859 pos_byte_next
= CHAR_TO_BYTE (pos
);
2860 if (pos_byte_next
> pos_byte
)
2861 /* Before combining happened. We should not increment
2862 POS. So, to cancel the later increment of POS,
2866 INC_POS (pos_byte_next
);
2868 if (! NILP (noundo
))
2869 current_buffer
->undo_list
= tem
;
2876 record_change (pos
, 1);
2877 for (i
= 0; i
< len
; i
++) *p
++ = tostr
[i
];
2879 last_changed
= pos
+ 1;
2881 pos_byte
= pos_byte_next
;
2887 signal_after_change (changed
,
2888 last_changed
- changed
, last_changed
- changed
);
2889 update_compositions (changed
, last_changed
, CHECK_ALL
);
2892 unbind_to (count
, Qnil
);
2896 DEFUN ("translate-region-internal", Ftranslate_region_internal
,
2897 Stranslate_region_internal
, 3, 3, 0,
2898 doc
: /* Internal use only.
2899 From START to END, translate characters according to TABLE.
2900 TABLE is a string; the Nth character in it is the mapping
2901 for the character with code N.
2902 It returns the number of characters changed. */)
2906 register Lisp_Object table
;
2908 register unsigned char *tt
; /* Trans table. */
2909 register int nc
; /* New character. */
2910 int cnt
; /* Number of changes made. */
2911 int size
; /* Size of translate table. */
2912 int pos
, pos_byte
, end_pos
;
2913 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
2914 int string_multibyte
;
2916 validate_region (&start
, &end
);
2917 if (CHAR_TABLE_P (table
))
2924 CHECK_STRING (table
);
2926 if (! multibyte
&& (SCHARS (table
) < SBYTES (table
)))
2927 table
= string_make_unibyte (table
);
2928 string_multibyte
= SCHARS (table
) < SBYTES (table
);
2929 size
= SCHARS (table
);
2934 pos_byte
= CHAR_TO_BYTE (pos
);
2935 end_pos
= XINT (end
);
2936 modify_region (current_buffer
, pos
, XINT (end
), 0);
2939 for (; pos
< end_pos
; )
2941 register unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
2942 unsigned char *str
, buf
[MAX_MULTIBYTE_LENGTH
];
2947 oc
= STRING_CHAR_AND_LENGTH (p
, MAX_MULTIBYTE_LENGTH
, len
);
2954 /* Reload as signal_after_change in last iteration may GC. */
2956 if (string_multibyte
)
2958 str
= tt
+ string_char_to_byte (table
, oc
);
2959 nc
= STRING_CHAR_AND_LENGTH (str
, MAX_MULTIBYTE_LENGTH
,
2965 if (! ASCII_BYTE_P (nc
) && multibyte
)
2967 str_len
= CHAR_STRING (nc
, buf
);
2983 val
= CHAR_TABLE_REF (table
, oc
);
2985 && (c
= XINT (val
), CHAR_VALID_P (c
, 0)))
2988 str_len
= CHAR_STRING (nc
, buf
);
2999 /* This is less efficient, because it moves the gap,
3000 but it should multibyte characters correctly. */
3001 string
= make_multibyte_string (str
, 1, str_len
);
3002 replace_range (pos
, pos
+ 1, string
, 1, 0, 1);
3007 record_change (pos
, 1);
3008 while (str_len
-- > 0)
3010 signal_after_change (pos
, 1, 1);
3011 update_compositions (pos
, pos
+ 1, CHECK_BORDER
);
3020 return make_number (cnt
);
3023 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
3024 doc
: /* Delete the text between point and mark.
3026 When called from a program, expects two arguments,
3027 positions (integers or markers) specifying the stretch to be deleted. */)
3029 Lisp_Object start
, end
;
3031 validate_region (&start
, &end
);
3032 del_range (XINT (start
), XINT (end
));
3036 DEFUN ("delete-and-extract-region", Fdelete_and_extract_region
,
3037 Sdelete_and_extract_region
, 2, 2, 0,
3038 doc
: /* Delete the text between START and END and return it. */)
3040 Lisp_Object start
, end
;
3042 validate_region (&start
, &end
);
3043 if (XINT (start
) == XINT (end
))
3044 return build_string ("");
3045 return del_range_1 (XINT (start
), XINT (end
), 1, 1);
3048 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
3049 doc
: /* Remove restrictions (narrowing) from current buffer.
3050 This allows the buffer's full text to be seen and edited. */)
3053 if (BEG
!= BEGV
|| Z
!= ZV
)
3054 current_buffer
->clip_changed
= 1;
3056 BEGV_BYTE
= BEG_BYTE
;
3057 SET_BUF_ZV_BOTH (current_buffer
, Z
, Z_BYTE
);
3058 /* Changing the buffer bounds invalidates any recorded current column. */
3059 invalidate_current_column ();
3063 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
3064 doc
: /* Restrict editing in this buffer to the current region.
3065 The rest of the text becomes temporarily invisible and untouchable
3066 but is not deleted; if you save the buffer in a file, the invisible
3067 text is included in the file. \\[widen] makes all visible again.
3068 See also `save-restriction'.
3070 When calling from a program, pass two arguments; positions (integers
3071 or markers) bounding the text that should remain visible. */)
3073 register Lisp_Object start
, end
;
3075 CHECK_NUMBER_COERCE_MARKER (start
);
3076 CHECK_NUMBER_COERCE_MARKER (end
);
3078 if (XINT (start
) > XINT (end
))
3081 tem
= start
; start
= end
; end
= tem
;
3084 if (!(BEG
<= XINT (start
) && XINT (start
) <= XINT (end
) && XINT (end
) <= Z
))
3085 args_out_of_range (start
, end
);
3087 if (BEGV
!= XFASTINT (start
) || ZV
!= XFASTINT (end
))
3088 current_buffer
->clip_changed
= 1;
3090 SET_BUF_BEGV (current_buffer
, XFASTINT (start
));
3091 SET_BUF_ZV (current_buffer
, XFASTINT (end
));
3092 if (PT
< XFASTINT (start
))
3093 SET_PT (XFASTINT (start
));
3094 if (PT
> XFASTINT (end
))
3095 SET_PT (XFASTINT (end
));
3096 /* Changing the buffer bounds invalidates any recorded current column. */
3097 invalidate_current_column ();
3102 save_restriction_save ()
3104 if (BEGV
== BEG
&& ZV
== Z
)
3105 /* The common case that the buffer isn't narrowed.
3106 We return just the buffer object, which save_restriction_restore
3107 recognizes as meaning `no restriction'. */
3108 return Fcurrent_buffer ();
3110 /* We have to save a restriction, so return a pair of markers, one
3111 for the beginning and one for the end. */
3113 Lisp_Object beg
, end
;
3115 beg
= buildmark (BEGV
, BEGV_BYTE
);
3116 end
= buildmark (ZV
, ZV_BYTE
);
3118 /* END must move forward if text is inserted at its exact location. */
3119 XMARKER(end
)->insertion_type
= 1;
3121 return Fcons (beg
, end
);
3126 save_restriction_restore (data
)
3130 /* A pair of marks bounding a saved restriction. */
3132 struct Lisp_Marker
*beg
= XMARKER (XCAR (data
));
3133 struct Lisp_Marker
*end
= XMARKER (XCDR (data
));
3134 struct buffer
*buf
= beg
->buffer
; /* END should have the same buffer. */
3136 if (buf
/* Verify marker still points to a buffer. */
3137 && (beg
->charpos
!= BUF_BEGV (buf
) || end
->charpos
!= BUF_ZV (buf
)))
3138 /* The restriction has changed from the saved one, so restore
3139 the saved restriction. */
3141 int pt
= BUF_PT (buf
);
3143 SET_BUF_BEGV_BOTH (buf
, beg
->charpos
, beg
->bytepos
);
3144 SET_BUF_ZV_BOTH (buf
, end
->charpos
, end
->bytepos
);
3146 if (pt
< beg
->charpos
|| pt
> end
->charpos
)
3147 /* The point is outside the new visible range, move it inside. */
3148 SET_BUF_PT_BOTH (buf
,
3149 clip_to_bounds (beg
->charpos
, pt
, end
->charpos
),
3150 clip_to_bounds (beg
->bytepos
, BUF_PT_BYTE (buf
),
3153 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3157 /* A buffer, which means that there was no old restriction. */
3159 struct buffer
*buf
= XBUFFER (data
);
3161 if (buf
/* Verify marker still points to a buffer. */
3162 && (BUF_BEGV (buf
) != BUF_BEG (buf
) || BUF_ZV (buf
) != BUF_Z (buf
)))
3163 /* The buffer has been narrowed, get rid of the narrowing. */
3165 SET_BUF_BEGV_BOTH (buf
, BUF_BEG (buf
), BUF_BEG_BYTE (buf
));
3166 SET_BUF_ZV_BOTH (buf
, BUF_Z (buf
), BUF_Z_BYTE (buf
));
3168 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3175 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
3176 doc
: /* Execute BODY, saving and restoring current buffer's restrictions.
3177 The buffer's restrictions make parts of the beginning and end invisible.
3178 (They are set up with `narrow-to-region' and eliminated with `widen'.)
3179 This special form, `save-restriction', saves the current buffer's restrictions
3180 when it is entered, and restores them when it is exited.
3181 So any `narrow-to-region' within BODY lasts only until the end of the form.
3182 The old restrictions settings are restored
3183 even in case of abnormal exit (throw or error).
3185 The value returned is the value of the last form in BODY.
3187 Note: if you are using both `save-excursion' and `save-restriction',
3188 use `save-excursion' outermost:
3189 (save-excursion (save-restriction ...))
3191 usage: (save-restriction &rest BODY) */)
3195 register Lisp_Object val
;
3196 int count
= SPECPDL_INDEX ();
3198 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
3199 val
= Fprogn (body
);
3200 return unbind_to (count
, val
);
3203 /* Buffer for the most recent text displayed by Fmessage_box. */
3204 static char *message_text
;
3206 /* Allocated length of that buffer. */
3207 static int message_length
;
3209 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
3210 doc
: /* Display a message at the bottom of the screen.
3211 The message also goes into the `*Messages*' buffer.
3212 \(In keyboard macros, that's all it does.)
3215 The first argument is a format control string, and the rest are data
3216 to be formatted under control of the string. See `format' for details.
3218 Note: Use (message "%s" VALUE) to print the value of expressions and
3219 variables to avoid accidentally interpreting `%' as format specifiers.
3221 If the first argument is nil or the empty string, the function clears
3222 any existing message; this lets the minibuffer contents show. See
3223 also `current-message'.
3225 usage: (message FORMAT-STRING &rest ARGS) */)
3231 || (STRINGP (args
[0])
3232 && SBYTES (args
[0]) == 0))
3239 register Lisp_Object val
;
3240 val
= Fformat (nargs
, args
);
3241 message3 (val
, SBYTES (val
), STRING_MULTIBYTE (val
));
3246 DEFUN ("message-box", Fmessage_box
, Smessage_box
, 1, MANY
, 0,
3247 doc
: /* Display a message, in a dialog box if possible.
3248 If a dialog box is not available, use the echo area.
3249 The first argument is a format control string, and the rest are data
3250 to be formatted under control of the string. See `format' for details.
3252 If the first argument is nil or the empty string, clear any existing
3253 message; let the minibuffer contents show.
3255 usage: (message-box FORMAT-STRING &rest ARGS) */)
3267 register Lisp_Object val
;
3268 val
= Fformat (nargs
, args
);
3270 /* The MS-DOS frames support popup menus even though they are
3271 not FRAME_WINDOW_P. */
3272 if (FRAME_WINDOW_P (XFRAME (selected_frame
))
3273 || FRAME_MSDOS_P (XFRAME (selected_frame
)))
3275 Lisp_Object pane
, menu
, obj
;
3276 struct gcpro gcpro1
;
3277 pane
= Fcons (Fcons (build_string ("OK"), Qt
), Qnil
);
3279 menu
= Fcons (val
, pane
);
3280 obj
= Fx_popup_dialog (Qt
, menu
, Qt
);
3284 #endif /* HAVE_MENUS */
3285 /* Copy the data so that it won't move when we GC. */
3288 message_text
= (char *)xmalloc (80);
3289 message_length
= 80;
3291 if (SBYTES (val
) > message_length
)
3293 message_length
= SBYTES (val
);
3294 message_text
= (char *)xrealloc (message_text
, message_length
);
3296 bcopy (SDATA (val
), message_text
, SBYTES (val
));
3297 message2 (message_text
, SBYTES (val
),
3298 STRING_MULTIBYTE (val
));
3303 extern Lisp_Object last_nonmenu_event
;
3306 DEFUN ("message-or-box", Fmessage_or_box
, Smessage_or_box
, 1, MANY
, 0,
3307 doc
: /* Display a message in a dialog box or in the echo area.
3308 If this command was invoked with the mouse, use a dialog box if
3309 `use-dialog-box' is non-nil.
3310 Otherwise, use the echo area.
3311 The first argument is a format control string, and the rest are data
3312 to be formatted under control of the string. See `format' for details.
3314 If the first argument is nil or the empty string, clear any existing
3315 message; let the minibuffer contents show.
3317 usage: (message-or-box FORMAT-STRING &rest ARGS) */)
3323 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3325 return Fmessage_box (nargs
, args
);
3327 return Fmessage (nargs
, args
);
3330 DEFUN ("current-message", Fcurrent_message
, Scurrent_message
, 0, 0, 0,
3331 doc
: /* Return the string currently displayed in the echo area, or nil if none. */)
3334 return current_message ();
3338 DEFUN ("propertize", Fpropertize
, Spropertize
, 1, MANY
, 0,
3339 doc
: /* Return a copy of STRING with text properties added.
3340 First argument is the string to copy.
3341 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
3342 properties to add to the result.
3343 usage: (propertize STRING &rest PROPERTIES) */)
3348 Lisp_Object properties
, string
;
3349 struct gcpro gcpro1
, gcpro2
;
3352 /* Number of args must be odd. */
3353 if ((nargs
& 1) == 0 || nargs
< 1)
3354 error ("Wrong number of arguments");
3356 properties
= string
= Qnil
;
3357 GCPRO2 (properties
, string
);
3359 /* First argument must be a string. */
3360 CHECK_STRING (args
[0]);
3361 string
= Fcopy_sequence (args
[0]);
3363 for (i
= 1; i
< nargs
; i
+= 2)
3364 properties
= Fcons (args
[i
], Fcons (args
[i
+ 1], properties
));
3366 Fadd_text_properties (make_number (0),
3367 make_number (SCHARS (string
)),
3368 properties
, string
);
3369 RETURN_UNGCPRO (string
);
3373 /* Number of bytes that STRING will occupy when put into the result.
3374 MULTIBYTE is nonzero if the result should be multibyte. */
3376 #define CONVERTED_BYTE_SIZE(MULTIBYTE, STRING) \
3377 (((MULTIBYTE) && ! STRING_MULTIBYTE (STRING)) \
3378 ? count_size_as_multibyte (SDATA (STRING), SBYTES (STRING)) \
3381 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
3382 doc
: /* Format a string out of a format-string and arguments.
3383 The first argument is a format control string.
3384 The other arguments are substituted into it to make the result, a string.
3385 It may contain %-sequences meaning to substitute the next argument.
3386 %s means print a string argument. Actually, prints any object, with `princ'.
3387 %d means print as number in decimal (%o octal, %x hex).
3388 %X is like %x, but uses upper case.
3389 %e means print a number in exponential notation.
3390 %f means print a number in decimal-point notation.
3391 %g means print a number in exponential notation
3392 or decimal-point notation, whichever uses fewer characters.
3393 %c means print a number as a single character.
3394 %S means print any object as an s-expression (using `prin1').
3395 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.
3396 Use %% to put a single % into the output.
3398 The basic structure of a %-sequence is
3399 % <flags> <width> <precision> character
3400 where flags is [- #0]+, width is [0-9]+, and precision is .[0-9]+
3402 usage: (format STRING &rest OBJECTS) */)
3405 register Lisp_Object
*args
;
3407 register int n
; /* The number of the next arg to substitute */
3408 register int total
; /* An estimate of the final length */
3410 register unsigned char *format
, *end
, *format_start
;
3412 /* Nonzero if the output should be a multibyte string,
3413 which is true if any of the inputs is one. */
3415 /* When we make a multibyte string, we must pay attention to the
3416 byte combining problem, i.e., a byte may be combined with a
3417 multibyte charcter of the previous string. This flag tells if we
3418 must consider such a situation or not. */
3419 int maybe_combine_byte
;
3420 unsigned char *this_format
;
3421 /* Precision for each spec, or -1, a flag value meaning no precision
3422 was given in that spec. Element 0, corresonding to the format
3423 string itself, will not be used. Element NARGS, corresponding to
3424 no argument, *will* be assigned to in the case that a `%' and `.'
3425 occur after the final format specifier. */
3426 int *precision
= (int *) (alloca((nargs
+ 1) * sizeof (int)));
3429 int arg_intervals
= 0;
3432 /* discarded[I] is 1 if byte I of the format
3433 string was not copied into the output.
3434 It is 2 if byte I was not the first byte of its character. */
3435 char *discarded
= 0;
3437 /* Each element records, for one argument,
3438 the start and end bytepos in the output string,
3439 and whether the argument is a string with intervals.
3440 info[0] is unused. Unused elements have -1 for start. */
3443 int start
, end
, intervals
;
3446 /* It should not be necessary to GCPRO ARGS, because
3447 the caller in the interpreter should take care of that. */
3449 /* Try to determine whether the result should be multibyte.
3450 This is not always right; sometimes the result needs to be multibyte
3451 because of an object that we will pass through prin1,
3452 and in that case, we won't know it here. */
3453 for (n
= 0; n
< nargs
; n
++)
3455 if (STRINGP (args
[n
]) && STRING_MULTIBYTE (args
[n
]))
3457 /* Piggyback on this loop to initialize precision[N]. */
3460 precision
[nargs
] = -1;
3462 CHECK_STRING (args
[0]);
3463 /* We may have to change "%S" to "%s". */
3464 args
[0] = Fcopy_sequence (args
[0]);
3466 /* GC should never happen here, so abort if it does. */
3469 /* If we start out planning a unibyte result,
3470 then discover it has to be multibyte, we jump back to retry.
3471 That can only happen from the first large while loop below. */
3474 format
= SDATA (args
[0]);
3475 format_start
= format
;
3476 end
= format
+ SBYTES (args
[0]);
3479 /* Make room in result for all the non-%-codes in the control string. */
3480 total
= 5 + CONVERTED_BYTE_SIZE (multibyte
, args
[0]) + 1;
3482 /* Allocate the info and discarded tables. */
3484 int nbytes
= (nargs
+1) * sizeof *info
;
3487 info
= (struct info
*) alloca (nbytes
);
3488 bzero (info
, nbytes
);
3489 for (i
= 0; i
<= nargs
; i
++)
3492 SAFE_ALLOCA (discarded
, char *, SBYTES (args
[0]));
3493 bzero (discarded
, SBYTES (args
[0]));
3496 /* Add to TOTAL enough space to hold the converted arguments. */
3499 while (format
!= end
)
3500 if (*format
++ == '%')
3503 int actual_width
= 0;
3504 unsigned char *this_format_start
= format
- 1;
3505 int field_width
= 0;
3507 /* General format specifications look like
3509 '%' [flags] [field-width] [precision] format
3514 field-width ::= [0-9]+
3515 precision ::= '.' [0-9]*
3517 If a field-width is specified, it specifies to which width
3518 the output should be padded with blanks, iff the output
3519 string is shorter than field-width.
3521 If precision is specified, it specifies the number of
3522 digits to print after the '.' for floats, or the max.
3523 number of chars to print from a string. */
3525 while (format
!= end
3526 && (*format
== '-' || *format
== '0' || *format
== '#'
3527 || * format
== ' '))
3530 if (*format
>= '0' && *format
<= '9')
3532 for (field_width
= 0; *format
>= '0' && *format
<= '9'; ++format
)
3533 field_width
= 10 * field_width
+ *format
- '0';
3536 /* N is not incremented for another few lines below, so refer to
3537 element N+1 (which might be precision[NARGS]). */
3541 for (precision
[n
+1] = 0; *format
>= '0' && *format
<= '9'; ++format
)
3542 precision
[n
+1] = 10 * precision
[n
+1] + *format
- '0';
3545 if (format
- this_format_start
+ 1 > longest_format
)
3546 longest_format
= format
- this_format_start
+ 1;
3549 error ("Format string ends in middle of format specifier");
3552 else if (++n
>= nargs
)
3553 error ("Not enough arguments for format string");
3554 else if (*format
== 'S')
3556 /* For `S', prin1 the argument and then treat like a string. */
3557 register Lisp_Object tem
;
3558 tem
= Fprin1_to_string (args
[n
], Qnil
);
3559 if (STRING_MULTIBYTE (tem
) && ! multibyte
)
3565 /* If we restart the loop, we should not come here again
3566 because args[n] is now a string and calling
3567 Fprin1_to_string on it produces superflous double
3568 quotes. So, change "%S" to "%s" now. */
3572 else if (SYMBOLP (args
[n
]))
3574 args
[n
] = SYMBOL_NAME (args
[n
]);
3575 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
3582 else if (STRINGP (args
[n
]))
3585 if (*format
!= 's' && *format
!= 'S')
3586 error ("Format specifier doesn't match argument type");
3587 /* In the case (PRECISION[N] > 0), THISSIZE may not need
3588 to be as large as is calculated here. Easy check for
3589 the case PRECISION = 0. */
3590 thissize
= precision
[n
] ? CONVERTED_BYTE_SIZE (multibyte
, args
[n
]) : 0;
3591 actual_width
= lisp_string_width (args
[n
], -1, NULL
, NULL
);
3593 /* Would get MPV otherwise, since Lisp_Int's `point' to low memory. */
3594 else if (INTEGERP (args
[n
]) && *format
!= 's')
3596 /* The following loop assumes the Lisp type indicates
3597 the proper way to pass the argument.
3598 So make sure we have a flonum if the argument should
3600 if (*format
== 'e' || *format
== 'f' || *format
== 'g')
3601 args
[n
] = Ffloat (args
[n
]);
3603 if (*format
!= 'd' && *format
!= 'o' && *format
!= 'x'
3604 && *format
!= 'i' && *format
!= 'X' && *format
!= 'c')
3605 error ("Invalid format operation %%%c", *format
);
3610 if (! SINGLE_BYTE_CHAR_P (XINT (args
[n
]))
3611 /* Note: No one can remember why we have to treat
3612 the character 0 as a multibyte character here.
3613 But, until it causes a real problem, let's
3615 || XINT (args
[n
]) == 0)
3622 args
[n
] = Fchar_to_string (args
[n
]);
3623 thissize
= SBYTES (args
[n
]);
3625 else if (! ASCII_BYTE_P (XINT (args
[n
])) && multibyte
)
3628 = Fchar_to_string (Funibyte_char_to_multibyte (args
[n
]));
3629 thissize
= SBYTES (args
[n
]);
3633 else if (FLOATP (args
[n
]) && *format
!= 's')
3635 if (! (*format
== 'e' || *format
== 'f' || *format
== 'g'))
3637 if (*format
!= 'd' && *format
!= 'o' && *format
!= 'x'
3638 && *format
!= 'i' && *format
!= 'X' && *format
!= 'c')
3639 error ("Invalid format operation %%%c", *format
);
3640 /* This fails unnecessarily if args[n] is bigger than
3641 most-positive-fixnum but smaller than MAXINT.
3642 These cases are important because we sometimes use floats
3643 to represent such integer values (typically such values
3644 come from UIDs or PIDs). */
3645 /* args[n] = Ftruncate (args[n], Qnil); */
3648 /* Note that we're using sprintf to print floats,
3649 so we have to take into account what that function
3651 /* Filter out flag value of -1. */
3652 thissize
= (MAX_10_EXP
+ 100
3653 + (precision
[n
] > 0 ? precision
[n
] : 0));
3657 /* Anything but a string, convert to a string using princ. */
3658 register Lisp_Object tem
;
3659 tem
= Fprin1_to_string (args
[n
], Qt
);
3660 if (STRING_MULTIBYTE (tem
) && ! multibyte
)
3669 thissize
+= max (0, field_width
- actual_width
);
3670 total
+= thissize
+ 4;
3675 /* Now we can no longer jump to retry.
3676 TOTAL and LONGEST_FORMAT are known for certain. */
3678 this_format
= (unsigned char *) alloca (longest_format
+ 1);
3680 /* Allocate the space for the result.
3681 Note that TOTAL is an overestimate. */
3682 SAFE_ALLOCA (buf
, char *, total
);
3688 /* Scan the format and store result in BUF. */
3689 format
= SDATA (args
[0]);
3690 format_start
= format
;
3691 end
= format
+ SBYTES (args
[0]);
3692 maybe_combine_byte
= 0;
3693 while (format
!= end
)
3699 unsigned char *this_format_start
= format
;
3701 discarded
[format
- format_start
] = 1;
3704 while (index("-0# ", *format
))
3710 discarded
[format
- format_start
] = 1;
3714 minlen
= atoi (format
);
3716 while ((*format
>= '0' && *format
<= '9') || *format
== '.')
3718 discarded
[format
- format_start
] = 1;
3722 if (*format
++ == '%')
3731 discarded
[format
- format_start
- 1] = 1;
3732 info
[n
].start
= nchars
;
3734 if (STRINGP (args
[n
]))
3736 /* handle case (precision[n] >= 0) */
3739 int nbytes
, start
, end
;
3742 /* lisp_string_width ignores a precision of 0, but GNU
3743 libc functions print 0 characters when the precision
3744 is 0. Imitate libc behavior here. Changing
3745 lisp_string_width is the right thing, and will be
3746 done, but meanwhile we work with it. */
3748 if (precision
[n
] == 0)
3749 width
= nchars_string
= nbytes
= 0;
3750 else if (precision
[n
] > 0)
3751 width
= lisp_string_width (args
[n
], precision
[n
], &nchars_string
, &nbytes
);
3753 { /* no precision spec given for this argument */
3754 width
= lisp_string_width (args
[n
], -1, NULL
, NULL
);
3755 nbytes
= SBYTES (args
[n
]);
3756 nchars_string
= SCHARS (args
[n
]);
3759 /* If spec requires it, pad on right with spaces. */
3760 padding
= minlen
- width
;
3762 while (padding
-- > 0)
3768 info
[n
].start
= start
= nchars
;
3769 nchars
+= nchars_string
;
3774 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3775 && STRING_MULTIBYTE (args
[n
])
3776 && !CHAR_HEAD_P (SREF (args
[n
], 0)))
3777 maybe_combine_byte
= 1;
3779 p
+= copy_text (SDATA (args
[n
]), p
,
3781 STRING_MULTIBYTE (args
[n
]), multibyte
);
3783 info
[n
].end
= nchars
;
3786 while (padding
-- > 0)
3792 /* If this argument has text properties, record where
3793 in the result string it appears. */
3794 if (STRING_INTERVALS (args
[n
]))
3795 info
[n
].intervals
= arg_intervals
= 1;
3797 else if (INTEGERP (args
[n
]) || FLOATP (args
[n
]))
3801 bcopy (this_format_start
, this_format
,
3802 format
- this_format_start
);
3803 this_format
[format
- this_format_start
] = 0;
3805 if (INTEGERP (args
[n
]))
3807 if (format
[-1] == 'd')
3808 sprintf (p
, this_format
, XINT (args
[n
]));
3809 /* Don't sign-extend for octal or hex printing. */
3811 sprintf (p
, this_format
, XUINT (args
[n
]));
3813 else if (format
[-1] == 'e' || format
[-1] == 'f' || format
[-1] == 'g')
3814 sprintf (p
, this_format
, XFLOAT_DATA (args
[n
]));
3815 else if (format
[-1] == 'd')
3816 /* Maybe we should use "%1.0f" instead so it also works
3817 for values larger than MAXINT. */
3818 sprintf (p
, this_format
, (EMACS_INT
) XFLOAT_DATA (args
[n
]));
3820 /* Don't sign-extend for octal or hex printing. */
3821 sprintf (p
, this_format
, (EMACS_UINT
) XFLOAT_DATA (args
[n
]));
3825 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3826 && !CHAR_HEAD_P (*((unsigned char *) p
)))
3827 maybe_combine_byte
= 1;
3828 this_nchars
= strlen (p
);
3830 p
+= str_to_multibyte (p
, buf
+ total
- 1 - p
, this_nchars
);
3833 nchars
+= this_nchars
;
3834 info
[n
].end
= nchars
;
3838 else if (STRING_MULTIBYTE (args
[0]))
3840 /* Copy a whole multibyte character. */
3843 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3844 && !CHAR_HEAD_P (*format
))
3845 maybe_combine_byte
= 1;
3847 while (! CHAR_HEAD_P (*format
))
3849 discarded
[format
- format_start
] = 2;
3856 /* Convert a single-byte character to multibyte. */
3857 int len
= copy_text (format
, p
, 1, 0, 1);
3864 *p
++ = *format
++, nchars
++;
3867 if (p
> buf
+ total
)
3870 if (maybe_combine_byte
)
3871 nchars
= multibyte_chars_in_text (buf
, p
- buf
);
3872 val
= make_specified_string (buf
, nchars
, p
- buf
, multibyte
);
3874 /* If we allocated BUF with malloc, free it too. */
3877 /* If the format string has text properties, or any of the string
3878 arguments has text properties, set up text properties of the
3881 if (STRING_INTERVALS (args
[0]) || arg_intervals
)
3883 Lisp_Object len
, new_len
, props
;
3884 struct gcpro gcpro1
;
3886 /* Add text properties from the format string. */
3887 len
= make_number (SCHARS (args
[0]));
3888 props
= text_property_list (args
[0], make_number (0), len
, Qnil
);
3893 int bytepos
= 0, position
= 0, translated
= 0, argn
= 1;
3896 /* Adjust the bounds of each text property
3897 to the proper start and end in the output string. */
3899 /* Put the positions in PROPS in increasing order, so that
3900 we can do (effectively) one scan through the position
3901 space of the format string. */
3902 props
= Fnreverse (props
);
3904 /* BYTEPOS is the byte position in the format string,
3905 POSITION is the untranslated char position in it,
3906 TRANSLATED is the translated char position in BUF,
3907 and ARGN is the number of the next arg we will come to. */
3908 for (list
= props
; CONSP (list
); list
= XCDR (list
))
3915 /* First adjust the property start position. */
3916 pos
= XINT (XCAR (item
));
3918 /* Advance BYTEPOS, POSITION, TRANSLATED and ARGN
3919 up to this position. */
3920 for (; position
< pos
; bytepos
++)
3922 if (! discarded
[bytepos
])
3923 position
++, translated
++;
3924 else if (discarded
[bytepos
] == 1)
3927 if (translated
== info
[argn
].start
)
3929 translated
+= info
[argn
].end
- info
[argn
].start
;
3935 XSETCAR (item
, make_number (translated
));
3937 /* Likewise adjust the property end position. */
3938 pos
= XINT (XCAR (XCDR (item
)));
3940 for (; position
< pos
; bytepos
++)
3942 if (! discarded
[bytepos
])
3943 position
++, translated
++;
3944 else if (discarded
[bytepos
] == 1)
3947 if (translated
== info
[argn
].start
)
3949 translated
+= info
[argn
].end
- info
[argn
].start
;
3955 XSETCAR (XCDR (item
), make_number (translated
));
3958 add_text_properties_from_list (val
, props
, make_number (0));
3961 /* Add text properties from arguments. */
3963 for (n
= 1; n
< nargs
; ++n
)
3964 if (info
[n
].intervals
)
3966 len
= make_number (SCHARS (args
[n
]));
3967 new_len
= make_number (info
[n
].end
- info
[n
].start
);
3968 props
= text_property_list (args
[n
], make_number (0), len
, Qnil
);
3969 extend_property_ranges (props
, len
, new_len
);
3970 /* If successive arguments have properites, be sure that
3971 the value of `composition' property be the copy. */
3972 if (n
> 1 && info
[n
- 1].end
)
3973 make_composition_value_copy (props
);
3974 add_text_properties_from_list (val
, props
,
3975 make_number (info
[n
].start
));
3985 format2 (string1
, arg0
, arg1
)
3987 Lisp_Object arg0
, arg1
;
3989 Lisp_Object args
[3];
3990 args
[0] = build_string (string1
);
3993 return Fformat (3, args
);
3996 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
3997 doc
: /* Return t if two characters match, optionally ignoring case.
3998 Both arguments must be characters (i.e. integers).
3999 Case is ignored if `case-fold-search' is non-nil in the current buffer. */)
4001 register Lisp_Object c1
, c2
;
4007 if (XINT (c1
) == XINT (c2
))
4009 if (NILP (current_buffer
->case_fold_search
))
4012 /* Do these in separate statements,
4013 then compare the variables.
4014 because of the way DOWNCASE uses temp variables. */
4015 i1
= DOWNCASE (XFASTINT (c1
));
4016 i2
= DOWNCASE (XFASTINT (c2
));
4017 return (i1
== i2
? Qt
: Qnil
);
4020 /* Transpose the markers in two regions of the current buffer, and
4021 adjust the ones between them if necessary (i.e.: if the regions
4024 START1, END1 are the character positions of the first region.
4025 START1_BYTE, END1_BYTE are the byte positions.
4026 START2, END2 are the character positions of the second region.
4027 START2_BYTE, END2_BYTE are the byte positions.
4029 Traverses the entire marker list of the buffer to do so, adding an
4030 appropriate amount to some, subtracting from some, and leaving the
4031 rest untouched. Most of this is copied from adjust_markers in insdel.c.
4033 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
4036 transpose_markers (start1
, end1
, start2
, end2
,
4037 start1_byte
, end1_byte
, start2_byte
, end2_byte
)
4038 register int start1
, end1
, start2
, end2
;
4039 register int start1_byte
, end1_byte
, start2_byte
, end2_byte
;
4041 register int amt1
, amt1_byte
, amt2
, amt2_byte
, diff
, diff_byte
, mpos
;
4042 register struct Lisp_Marker
*marker
;
4044 /* Update point as if it were a marker. */
4048 TEMP_SET_PT_BOTH (PT
+ (end2
- end1
),
4049 PT_BYTE
+ (end2_byte
- end1_byte
));
4050 else if (PT
< start2
)
4051 TEMP_SET_PT_BOTH (PT
+ (end2
- start2
) - (end1
- start1
),
4052 (PT_BYTE
+ (end2_byte
- start2_byte
)
4053 - (end1_byte
- start1_byte
)));
4055 TEMP_SET_PT_BOTH (PT
- (start2
- start1
),
4056 PT_BYTE
- (start2_byte
- start1_byte
));
4058 /* We used to adjust the endpoints here to account for the gap, but that
4059 isn't good enough. Even if we assume the caller has tried to move the
4060 gap out of our way, it might still be at start1 exactly, for example;
4061 and that places it `inside' the interval, for our purposes. The amount
4062 of adjustment is nontrivial if there's a `denormalized' marker whose
4063 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
4064 the dirty work to Fmarker_position, below. */
4066 /* The difference between the region's lengths */
4067 diff
= (end2
- start2
) - (end1
- start1
);
4068 diff_byte
= (end2_byte
- start2_byte
) - (end1_byte
- start1_byte
);
4070 /* For shifting each marker in a region by the length of the other
4071 region plus the distance between the regions. */
4072 amt1
= (end2
- start2
) + (start2
- end1
);
4073 amt2
= (end1
- start1
) + (start2
- end1
);
4074 amt1_byte
= (end2_byte
- start2_byte
) + (start2_byte
- end1_byte
);
4075 amt2_byte
= (end1_byte
- start1_byte
) + (start2_byte
- end1_byte
);
4077 for (marker
= BUF_MARKERS (current_buffer
); marker
; marker
= marker
->next
)
4079 mpos
= marker
->bytepos
;
4080 if (mpos
>= start1_byte
&& mpos
< end2_byte
)
4082 if (mpos
< end1_byte
)
4084 else if (mpos
< start2_byte
)
4088 marker
->bytepos
= mpos
;
4090 mpos
= marker
->charpos
;
4091 if (mpos
>= start1
&& mpos
< end2
)
4095 else if (mpos
< start2
)
4100 marker
->charpos
= mpos
;
4104 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
4105 doc
: /* Transpose region STARTR1 to ENDR1 with STARTR2 to ENDR2.
4106 The regions may not be overlapping, because the size of the buffer is
4107 never changed in a transposition.
4109 Optional fifth arg LEAVE-MARKERS, if non-nil, means don't update
4110 any markers that happen to be located in the regions.
4112 Transposing beyond buffer boundaries is an error. */)
4113 (startr1
, endr1
, startr2
, endr2
, leave_markers
)
4114 Lisp_Object startr1
, endr1
, startr2
, endr2
, leave_markers
;
4116 register int start1
, end1
, start2
, end2
;
4117 int start1_byte
, start2_byte
, len1_byte
, len2_byte
;
4118 int gap
, len1
, len_mid
, len2
;
4119 unsigned char *start1_addr
, *start2_addr
, *temp
;
4121 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
;
4122 cur_intv
= BUF_INTERVALS (current_buffer
);
4124 validate_region (&startr1
, &endr1
);
4125 validate_region (&startr2
, &endr2
);
4127 start1
= XFASTINT (startr1
);
4128 end1
= XFASTINT (endr1
);
4129 start2
= XFASTINT (startr2
);
4130 end2
= XFASTINT (endr2
);
4133 /* Swap the regions if they're reversed. */
4136 register int glumph
= start1
;
4144 len1
= end1
- start1
;
4145 len2
= end2
- start2
;
4148 error ("Transposed regions overlap");
4149 else if (start1
== end1
|| start2
== end2
)
4150 error ("Transposed region has length 0");
4152 /* The possibilities are:
4153 1. Adjacent (contiguous) regions, or separate but equal regions
4154 (no, really equal, in this case!), or
4155 2. Separate regions of unequal size.
4157 The worst case is usually No. 2. It means that (aside from
4158 potential need for getting the gap out of the way), there also
4159 needs to be a shifting of the text between the two regions. So
4160 if they are spread far apart, we are that much slower... sigh. */
4162 /* It must be pointed out that the really studly thing to do would
4163 be not to move the gap at all, but to leave it in place and work
4164 around it if necessary. This would be extremely efficient,
4165 especially considering that people are likely to do
4166 transpositions near where they are working interactively, which
4167 is exactly where the gap would be found. However, such code
4168 would be much harder to write and to read. So, if you are
4169 reading this comment and are feeling squirrely, by all means have
4170 a go! I just didn't feel like doing it, so I will simply move
4171 the gap the minimum distance to get it out of the way, and then
4172 deal with an unbroken array. */
4174 /* Make sure the gap won't interfere, by moving it out of the text
4175 we will operate on. */
4176 if (start1
< gap
&& gap
< end2
)
4178 if (gap
- start1
< end2
- gap
)
4184 start1_byte
= CHAR_TO_BYTE (start1
);
4185 start2_byte
= CHAR_TO_BYTE (start2
);
4186 len1_byte
= CHAR_TO_BYTE (end1
) - start1_byte
;
4187 len2_byte
= CHAR_TO_BYTE (end2
) - start2_byte
;
4189 #ifdef BYTE_COMBINING_DEBUG
4192 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4193 len2_byte
, start1
, start1_byte
)
4194 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4195 len1_byte
, end2
, start2_byte
+ len2_byte
)
4196 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4197 len1_byte
, end2
, start2_byte
+ len2_byte
))
4202 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4203 len2_byte
, start1
, start1_byte
)
4204 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4205 len1_byte
, start2
, start2_byte
)
4206 || count_combining_after (BYTE_POS_ADDR (start2_byte
),
4207 len2_byte
, end1
, start1_byte
+ len1_byte
)
4208 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4209 len1_byte
, end2
, start2_byte
+ len2_byte
))
4214 /* Hmmm... how about checking to see if the gap is large
4215 enough to use as the temporary storage? That would avoid an
4216 allocation... interesting. Later, don't fool with it now. */
4218 /* Working without memmove, for portability (sigh), so must be
4219 careful of overlapping subsections of the array... */
4221 if (end1
== start2
) /* adjacent regions */
4223 modify_region (current_buffer
, start1
, end2
, 0);
4224 record_change (start1
, len1
+ len2
);
4226 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4227 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4228 Fset_text_properties (make_number (start1
), make_number (end2
),
4231 /* First region smaller than second. */
4232 if (len1_byte
< len2_byte
)
4236 SAFE_ALLOCA (temp
, unsigned char *, len2_byte
);
4238 /* Don't precompute these addresses. We have to compute them
4239 at the last minute, because the relocating allocator might
4240 have moved the buffer around during the xmalloc. */
4241 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4242 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4244 bcopy (start2_addr
, temp
, len2_byte
);
4245 bcopy (start1_addr
, start1_addr
+ len2_byte
, len1_byte
);
4246 bcopy (temp
, start1_addr
, len2_byte
);
4250 /* First region not smaller than second. */
4254 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4255 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4256 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4257 bcopy (start1_addr
, temp
, len1_byte
);
4258 bcopy (start2_addr
, start1_addr
, len2_byte
);
4259 bcopy (temp
, start1_addr
+ len2_byte
, len1_byte
);
4262 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
4263 len1
, current_buffer
, 0);
4264 graft_intervals_into_buffer (tmp_interval2
, start1
,
4265 len2
, current_buffer
, 0);
4266 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4267 update_compositions (start1
+ len2
, end2
, CHECK_TAIL
);
4269 /* Non-adjacent regions, because end1 != start2, bleagh... */
4272 len_mid
= start2_byte
- (start1_byte
+ len1_byte
);
4274 if (len1_byte
== len2_byte
)
4275 /* Regions are same size, though, how nice. */
4279 modify_region (current_buffer
, start1
, end1
, 0);
4280 modify_region (current_buffer
, start2
, end2
, 0);
4281 record_change (start1
, len1
);
4282 record_change (start2
, len2
);
4283 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4284 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4285 Fset_text_properties (make_number (start1
), make_number (end1
),
4287 Fset_text_properties (make_number (start2
), make_number (end2
),
4290 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4291 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4292 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4293 bcopy (start1_addr
, temp
, len1_byte
);
4294 bcopy (start2_addr
, start1_addr
, len2_byte
);
4295 bcopy (temp
, start2_addr
, len1_byte
);
4298 graft_intervals_into_buffer (tmp_interval1
, start2
,
4299 len1
, current_buffer
, 0);
4300 graft_intervals_into_buffer (tmp_interval2
, start1
,
4301 len2
, current_buffer
, 0);
4304 else if (len1_byte
< len2_byte
) /* Second region larger than first */
4305 /* Non-adjacent & unequal size, area between must also be shifted. */
4309 modify_region (current_buffer
, start1
, end2
, 0);
4310 record_change (start1
, (end2
- start1
));
4311 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4312 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4313 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4314 Fset_text_properties (make_number (start1
), make_number (end2
),
4317 /* holds region 2 */
4318 SAFE_ALLOCA (temp
, unsigned char *, len2_byte
);
4319 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4320 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4321 bcopy (start2_addr
, temp
, len2_byte
);
4322 bcopy (start1_addr
, start1_addr
+ len_mid
+ len2_byte
, len1_byte
);
4323 safe_bcopy (start1_addr
+ len1_byte
, start1_addr
+ len2_byte
, len_mid
);
4324 bcopy (temp
, start1_addr
, len2_byte
);
4327 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4328 len1
, current_buffer
, 0);
4329 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4330 len_mid
, current_buffer
, 0);
4331 graft_intervals_into_buffer (tmp_interval2
, start1
,
4332 len2
, current_buffer
, 0);
4335 /* Second region smaller than first. */
4339 record_change (start1
, (end2
- start1
));
4340 modify_region (current_buffer
, start1
, end2
, 0);
4342 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4343 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4344 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4345 Fset_text_properties (make_number (start1
), make_number (end2
),
4348 /* holds region 1 */
4349 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4350 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4351 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4352 bcopy (start1_addr
, temp
, len1_byte
);
4353 bcopy (start2_addr
, start1_addr
, len2_byte
);
4354 bcopy (start1_addr
+ len1_byte
, start1_addr
+ len2_byte
, len_mid
);
4355 bcopy (temp
, start1_addr
+ len2_byte
+ len_mid
, len1_byte
);
4358 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4359 len1
, current_buffer
, 0);
4360 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4361 len_mid
, current_buffer
, 0);
4362 graft_intervals_into_buffer (tmp_interval2
, start1
,
4363 len2
, current_buffer
, 0);
4366 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4367 update_compositions (end2
- len1
, end2
, CHECK_BORDER
);
4370 /* When doing multiple transpositions, it might be nice
4371 to optimize this. Perhaps the markers in any one buffer
4372 should be organized in some sorted data tree. */
4373 if (NILP (leave_markers
))
4375 transpose_markers (start1
, end1
, start2
, end2
,
4376 start1_byte
, start1_byte
+ len1_byte
,
4377 start2_byte
, start2_byte
+ len2_byte
);
4378 fix_start_end_in_overlays (start1
, end2
);
4390 Qbuffer_access_fontify_functions
4391 = intern ("buffer-access-fontify-functions");
4392 staticpro (&Qbuffer_access_fontify_functions
);
4394 DEFVAR_LISP ("inhibit-field-text-motion", &Vinhibit_field_text_motion
,
4395 doc
: /* Non-nil means text motion commands don't notice fields. */);
4396 Vinhibit_field_text_motion
= Qnil
;
4398 DEFVAR_LISP ("buffer-access-fontify-functions",
4399 &Vbuffer_access_fontify_functions
,
4400 doc
: /* List of functions called by `buffer-substring' to fontify if necessary.
4401 Each function is called with two arguments which specify the range
4402 of the buffer being accessed. */);
4403 Vbuffer_access_fontify_functions
= Qnil
;
4407 extern Lisp_Object Vprin1_to_string_buffer
;
4408 obuf
= Fcurrent_buffer ();
4409 /* Do this here, because init_buffer_once is too early--it won't work. */
4410 Fset_buffer (Vprin1_to_string_buffer
);
4411 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
4412 Fset (Fmake_local_variable (intern ("buffer-access-fontify-functions")),
4417 DEFVAR_LISP ("buffer-access-fontified-property",
4418 &Vbuffer_access_fontified_property
,
4419 doc
: /* Property which (if non-nil) indicates text has been fontified.
4420 `buffer-substring' need not call the `buffer-access-fontify-functions'
4421 functions if all the text being accessed has this property. */);
4422 Vbuffer_access_fontified_property
= Qnil
;
4424 DEFVAR_LISP ("system-name", &Vsystem_name
,
4425 doc
: /* The host name of the machine Emacs is running on. */);
4427 DEFVAR_LISP ("user-full-name", &Vuser_full_name
,
4428 doc
: /* The full name of the user logged in. */);
4430 DEFVAR_LISP ("user-login-name", &Vuser_login_name
,
4431 doc
: /* The user's name, taken from environment variables if possible. */);
4433 DEFVAR_LISP ("user-real-login-name", &Vuser_real_login_name
,
4434 doc
: /* The user's name, based upon the real uid only. */);
4436 DEFVAR_LISP ("operating-system-release", &Voperating_system_release
,
4437 doc
: /* The release of the operating system Emacs is running on. */);
4439 defsubr (&Spropertize
);
4440 defsubr (&Schar_equal
);
4441 defsubr (&Sgoto_char
);
4442 defsubr (&Sstring_to_char
);
4443 defsubr (&Schar_to_string
);
4444 defsubr (&Sbuffer_substring
);
4445 defsubr (&Sbuffer_substring_no_properties
);
4446 defsubr (&Sbuffer_string
);
4448 defsubr (&Spoint_marker
);
4449 defsubr (&Smark_marker
);
4451 defsubr (&Sregion_beginning
);
4452 defsubr (&Sregion_end
);
4454 staticpro (&Qfield
);
4455 Qfield
= intern ("field");
4456 staticpro (&Qboundary
);
4457 Qboundary
= intern ("boundary");
4458 defsubr (&Sfield_beginning
);
4459 defsubr (&Sfield_end
);
4460 defsubr (&Sfield_string
);
4461 defsubr (&Sfield_string_no_properties
);
4462 defsubr (&Sdelete_field
);
4463 defsubr (&Sconstrain_to_field
);
4465 defsubr (&Sline_beginning_position
);
4466 defsubr (&Sline_end_position
);
4468 /* defsubr (&Smark); */
4469 /* defsubr (&Sset_mark); */
4470 defsubr (&Ssave_excursion
);
4471 defsubr (&Ssave_current_buffer
);
4473 defsubr (&Sbufsize
);
4474 defsubr (&Spoint_max
);
4475 defsubr (&Spoint_min
);
4476 defsubr (&Spoint_min_marker
);
4477 defsubr (&Spoint_max_marker
);
4478 defsubr (&Sgap_position
);
4479 defsubr (&Sgap_size
);
4480 defsubr (&Sposition_bytes
);
4481 defsubr (&Sbyte_to_position
);
4487 defsubr (&Sfollowing_char
);
4488 defsubr (&Sprevious_char
);
4489 defsubr (&Schar_after
);
4490 defsubr (&Schar_before
);
4492 defsubr (&Sinsert_before_markers
);
4493 defsubr (&Sinsert_and_inherit
);
4494 defsubr (&Sinsert_and_inherit_before_markers
);
4495 defsubr (&Sinsert_char
);
4497 defsubr (&Suser_login_name
);
4498 defsubr (&Suser_real_login_name
);
4499 defsubr (&Suser_uid
);
4500 defsubr (&Suser_real_uid
);
4501 defsubr (&Suser_full_name
);
4502 defsubr (&Semacs_pid
);
4503 defsubr (&Scurrent_time
);
4504 defsubr (&Sget_internal_run_time
);
4505 defsubr (&Sformat_time_string
);
4506 defsubr (&Sfloat_time
);
4507 defsubr (&Sdecode_time
);
4508 defsubr (&Sencode_time
);
4509 defsubr (&Scurrent_time_string
);
4510 defsubr (&Scurrent_time_zone
);
4511 defsubr (&Sset_time_zone_rule
);
4512 defsubr (&Ssystem_name
);
4513 defsubr (&Smessage
);
4514 defsubr (&Smessage_box
);
4515 defsubr (&Smessage_or_box
);
4516 defsubr (&Scurrent_message
);
4519 defsubr (&Sinsert_buffer_substring
);
4520 defsubr (&Scompare_buffer_substrings
);
4521 defsubr (&Ssubst_char_in_region
);
4522 defsubr (&Stranslate_region_internal
);
4523 defsubr (&Sdelete_region
);
4524 defsubr (&Sdelete_and_extract_region
);
4526 defsubr (&Snarrow_to_region
);
4527 defsubr (&Ssave_restriction
);
4528 defsubr (&Stranspose_regions
);
4531 /* arch-tag: fc3827d8-6f60-4067-b11e-c3218031b018
4532 (do not change this comment) */