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 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"
55 #include "character.h"
62 #define MAX_10_EXP DBL_MAX_10_EXP
64 #define MAX_10_EXP 310
72 extern char **environ
;
75 #define TM_YEAR_BASE 1900
77 /* Nonzero if TM_YEAR is a struct tm's tm_year value that causes
78 asctime to have well-defined behavior. */
79 #ifndef TM_YEAR_IN_ASCTIME_RANGE
80 # define TM_YEAR_IN_ASCTIME_RANGE(tm_year) \
81 (1000 - TM_YEAR_BASE <= (tm_year) && (tm_year) <= 9999 - TM_YEAR_BASE)
84 extern size_t emacs_strftimeu
P_ ((char *, size_t, const char *,
85 const struct tm
*, int));
86 static int tm_diff
P_ ((struct tm
*, struct tm
*));
87 static void find_field
P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
, int *, Lisp_Object
, int *));
88 static void update_buffer_properties
P_ ((int, int));
89 static Lisp_Object region_limit
P_ ((int));
90 int lisp_time_argument
P_ ((Lisp_Object
, time_t *, int *));
91 static size_t emacs_memftimeu
P_ ((char *, size_t, const char *,
92 size_t, const struct tm
*, int));
93 static void general_insert_function
P_ ((void (*) (const unsigned char *, int),
94 void (*) (Lisp_Object
, int, int, int,
96 int, int, Lisp_Object
*));
97 static Lisp_Object subst_char_in_region_unwind
P_ ((Lisp_Object
));
98 static Lisp_Object subst_char_in_region_unwind_1
P_ ((Lisp_Object
));
99 static void transpose_markers
P_ ((int, int, int, int, int, int, int, int));
102 extern char *index
P_ ((const char *, int));
105 Lisp_Object Vbuffer_access_fontify_functions
;
106 Lisp_Object Qbuffer_access_fontify_functions
;
107 Lisp_Object Vbuffer_access_fontified_property
;
109 Lisp_Object Fuser_full_name
P_ ((Lisp_Object
));
111 /* Non-nil means don't stop at field boundary in text motion commands. */
113 Lisp_Object Vinhibit_field_text_motion
;
115 /* Some static data, and a function to initialize it for each run */
117 Lisp_Object Vsystem_name
;
118 Lisp_Object Vuser_real_login_name
; /* login name of current user ID */
119 Lisp_Object Vuser_full_name
; /* full name of current user */
120 Lisp_Object Vuser_login_name
; /* user name from LOGNAME or USER */
121 Lisp_Object Voperating_system_release
; /* Operating System Release */
123 /* Symbol for the text property used to mark fields. */
127 /* A special value for Qfield properties. */
129 Lisp_Object Qboundary
;
136 register unsigned char *p
;
137 struct passwd
*pw
; /* password entry for the current user */
140 /* Set up system_name even when dumping. */
144 /* Don't bother with this on initial start when just dumping out */
147 #endif /* not CANNOT_DUMP */
149 pw
= (struct passwd
*) getpwuid (getuid ());
151 /* We let the real user name default to "root" because that's quite
152 accurate on MSDOG and because it lets Emacs find the init file.
153 (The DVX libraries override the Djgpp libraries here.) */
154 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "root");
156 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "unknown");
159 /* Get the effective user name, by consulting environment variables,
160 or the effective uid if those are unset. */
161 user_name
= (char *) getenv ("LOGNAME");
164 user_name
= (char *) getenv ("USERNAME"); /* it's USERNAME on NT */
165 #else /* WINDOWSNT */
166 user_name
= (char *) getenv ("USER");
167 #endif /* WINDOWSNT */
170 pw
= (struct passwd
*) getpwuid (geteuid ());
171 user_name
= (char *) (pw
? pw
->pw_name
: "unknown");
173 Vuser_login_name
= build_string (user_name
);
175 /* If the user name claimed in the environment vars differs from
176 the real uid, use the claimed name to find the full name. */
177 tem
= Fstring_equal (Vuser_login_name
, Vuser_real_login_name
);
178 Vuser_full_name
= Fuser_full_name (NILP (tem
)? make_number (geteuid())
181 p
= (unsigned char *) getenv ("NAME");
183 Vuser_full_name
= build_string (p
);
184 else if (NILP (Vuser_full_name
))
185 Vuser_full_name
= build_string ("unknown");
187 #ifdef HAVE_SYS_UTSNAME_H
191 Voperating_system_release
= build_string (uts
.release
);
194 Voperating_system_release
= Qnil
;
198 DEFUN ("char-to-string", Fchar_to_string
, Schar_to_string
, 1, 1, 0,
199 doc
: /* Convert arg CHAR to a string containing that character.
200 usage: (char-to-string CHAR) */)
202 Lisp_Object character
;
205 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
207 CHECK_NUMBER (character
);
209 len
= CHAR_STRING (XFASTINT (character
), str
);
210 return make_string_from_bytes (str
, 1, len
);
213 DEFUN ("string-to-char", Fstring_to_char
, Sstring_to_char
, 1, 1, 0,
214 doc
: /* Convert arg STRING to a character, the first character of that string.
215 A multibyte character is handled correctly. */)
217 register Lisp_Object string
;
219 register Lisp_Object val
;
220 CHECK_STRING (string
);
223 if (STRING_MULTIBYTE (string
))
224 XSETFASTINT (val
, STRING_CHAR (SDATA (string
), SBYTES (string
)));
226 XSETFASTINT (val
, SREF (string
, 0));
229 XSETFASTINT (val
, 0);
234 buildmark (charpos
, bytepos
)
235 int charpos
, bytepos
;
237 register Lisp_Object mark
;
238 mark
= Fmake_marker ();
239 set_marker_both (mark
, Qnil
, charpos
, bytepos
);
243 DEFUN ("point", Fpoint
, Spoint
, 0, 0, 0,
244 doc
: /* Return value of point, as an integer.
245 Beginning of buffer is position (point-min). */)
249 XSETFASTINT (temp
, PT
);
253 DEFUN ("point-marker", Fpoint_marker
, Spoint_marker
, 0, 0, 0,
254 doc
: /* Return value of point, as a marker object. */)
257 return buildmark (PT
, PT_BYTE
);
261 clip_to_bounds (lower
, num
, upper
)
262 int lower
, num
, upper
;
266 else if (num
> upper
)
272 DEFUN ("goto-char", Fgoto_char
, Sgoto_char
, 1, 1, "NGoto char: ",
273 doc
: /* Set point to POSITION, a number or marker.
274 Beginning of buffer is position (point-min), end is (point-max). */)
276 register Lisp_Object position
;
280 if (MARKERP (position
)
281 && current_buffer
== XMARKER (position
)->buffer
)
283 pos
= marker_position (position
);
285 SET_PT_BOTH (BEGV
, BEGV_BYTE
);
287 SET_PT_BOTH (ZV
, ZV_BYTE
);
289 SET_PT_BOTH (pos
, marker_byte_position (position
));
294 CHECK_NUMBER_COERCE_MARKER (position
);
296 pos
= clip_to_bounds (BEGV
, XINT (position
), ZV
);
302 /* Return the start or end position of the region.
303 BEGINNINGP non-zero means return the start.
304 If there is no region active, signal an error. */
307 region_limit (beginningp
)
310 extern Lisp_Object Vmark_even_if_inactive
; /* Defined in callint.c. */
313 if (!NILP (Vtransient_mark_mode
)
314 && NILP (Vmark_even_if_inactive
)
315 && NILP (current_buffer
->mark_active
))
316 Fsignal (Qmark_inactive
, Qnil
);
318 m
= Fmarker_position (current_buffer
->mark
);
320 error ("The mark is not set now, so there is no region");
322 if ((PT
< XFASTINT (m
)) == (beginningp
!= 0))
323 m
= make_number (PT
);
327 DEFUN ("region-beginning", Fregion_beginning
, Sregion_beginning
, 0, 0, 0,
328 doc
: /* Return position of beginning of region, as an integer. */)
331 return region_limit (1);
334 DEFUN ("region-end", Fregion_end
, Sregion_end
, 0, 0, 0,
335 doc
: /* Return position of end of region, as an integer. */)
338 return region_limit (0);
341 DEFUN ("mark-marker", Fmark_marker
, Smark_marker
, 0, 0, 0,
342 doc
: /* Return this buffer's mark, as a marker object.
343 Watch out! Moving this marker changes the mark position.
344 If you set the marker not to point anywhere, the buffer will have no mark. */)
347 return current_buffer
->mark
;
351 /* Find all the overlays in the current buffer that touch position POS.
352 Return the number found, and store them in a vector in VEC
356 overlays_around (pos
, vec
, len
)
361 Lisp_Object overlay
, start
, end
;
362 struct Lisp_Overlay
*tail
;
363 int startpos
, endpos
;
366 for (tail
= current_buffer
->overlays_before
; tail
; tail
= tail
->next
)
368 XSETMISC (overlay
, tail
);
370 end
= OVERLAY_END (overlay
);
371 endpos
= OVERLAY_POSITION (end
);
374 start
= OVERLAY_START (overlay
);
375 startpos
= OVERLAY_POSITION (start
);
380 /* Keep counting overlays even if we can't return them all. */
385 for (tail
= current_buffer
->overlays_after
; tail
; tail
= tail
->next
)
387 XSETMISC (overlay
, tail
);
389 start
= OVERLAY_START (overlay
);
390 startpos
= OVERLAY_POSITION (start
);
393 end
= OVERLAY_END (overlay
);
394 endpos
= OVERLAY_POSITION (end
);
406 /* Return the value of property PROP, in OBJECT at POSITION.
407 It's the value of PROP that a char inserted at POSITION would get.
408 OBJECT is optional and defaults to the current buffer.
409 If OBJECT is a buffer, then overlay properties are considered as well as
411 If OBJECT is a window, then that window's buffer is used, but
412 window-specific overlays are considered only if they are associated
415 get_pos_property (position
, prop
, object
)
416 Lisp_Object position
, object
;
417 register Lisp_Object prop
;
419 CHECK_NUMBER_COERCE_MARKER (position
);
422 XSETBUFFER (object
, current_buffer
);
423 else if (WINDOWP (object
))
424 object
= XWINDOW (object
)->buffer
;
426 if (!BUFFERP (object
))
427 /* pos-property only makes sense in buffers right now, since strings
428 have no overlays and no notion of insertion for which stickiness
430 return Fget_text_property (position
, prop
, object
);
433 int posn
= XINT (position
);
435 Lisp_Object
*overlay_vec
, tem
;
436 struct buffer
*obuf
= current_buffer
;
438 set_buffer_temp (XBUFFER (object
));
440 /* First try with room for 40 overlays. */
442 overlay_vec
= (Lisp_Object
*) alloca (noverlays
* sizeof (Lisp_Object
));
443 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
445 /* If there are more than 40,
446 make enough space for all, and try again. */
449 overlay_vec
= (Lisp_Object
*) alloca (noverlays
* sizeof (Lisp_Object
));
450 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
452 noverlays
= sort_overlays (overlay_vec
, noverlays
, NULL
);
454 set_buffer_temp (obuf
);
456 /* Now check the overlays in order of decreasing priority. */
457 while (--noverlays
>= 0)
459 Lisp_Object ol
= overlay_vec
[noverlays
];
460 tem
= Foverlay_get (ol
, prop
);
463 /* Check the overlay is indeed active at point. */
464 Lisp_Object start
= OVERLAY_START (ol
), finish
= OVERLAY_END (ol
);
465 if ((OVERLAY_POSITION (start
) == posn
466 && XMARKER (start
)->insertion_type
== 1)
467 || (OVERLAY_POSITION (finish
) == posn
468 && XMARKER (finish
)->insertion_type
== 0))
469 ; /* The overlay will not cover a char inserted at point. */
477 { /* Now check the text-properties. */
478 int stickiness
= text_property_stickiness (prop
, position
, object
);
480 return Fget_text_property (position
, prop
, object
);
481 else if (stickiness
< 0
482 && XINT (position
) > BUF_BEGV (XBUFFER (object
)))
483 return Fget_text_property (make_number (XINT (position
) - 1),
491 /* Find the field surrounding POS in *BEG and *END. If POS is nil,
492 the value of point is used instead. If BEG or END is null,
493 means don't store the beginning or end of the field.
495 BEG_LIMIT and END_LIMIT serve to limit the ranged of the returned
496 results; they do not effect boundary behavior.
498 If MERGE_AT_BOUNDARY is nonzero, then if POS is at the very first
499 position of a field, then the beginning of the previous field is
500 returned instead of the beginning of POS's field (since the end of a
501 field is actually also the beginning of the next input field, this
502 behavior is sometimes useful). Additionally in the MERGE_AT_BOUNDARY
503 true case, if two fields are separated by a field with the special
504 value `boundary', and POS lies within it, then the two separated
505 fields are considered to be adjacent, and POS between them, when
506 finding the beginning and ending of the "merged" field.
508 Either BEG or END may be 0, in which case the corresponding value
512 find_field (pos
, merge_at_boundary
, beg_limit
, beg
, end_limit
, end
)
514 Lisp_Object merge_at_boundary
;
515 Lisp_Object beg_limit
, end_limit
;
518 /* Fields right before and after the point. */
519 Lisp_Object before_field
, after_field
;
520 /* 1 if POS counts as the start of a field. */
521 int at_field_start
= 0;
522 /* 1 if POS counts as the end of a field. */
523 int at_field_end
= 0;
526 XSETFASTINT (pos
, PT
);
528 CHECK_NUMBER_COERCE_MARKER (pos
);
531 = get_char_property_and_overlay (pos
, Qfield
, Qnil
, NULL
);
533 = (XFASTINT (pos
) > BEGV
534 ? get_char_property_and_overlay (make_number (XINT (pos
) - 1),
536 /* Using nil here would be a more obvious choice, but it would
537 fail when the buffer starts with a non-sticky field. */
540 /* See if we need to handle the case where MERGE_AT_BOUNDARY is nil
541 and POS is at beginning of a field, which can also be interpreted
542 as the end of the previous field. Note that the case where if
543 MERGE_AT_BOUNDARY is non-nil (see function comment) is actually the
544 more natural one; then we avoid treating the beginning of a field
546 if (NILP (merge_at_boundary
))
548 Lisp_Object field
= get_pos_property (pos
, Qfield
, Qnil
);
549 if (!EQ (field
, after_field
))
551 if (!EQ (field
, before_field
))
553 if (NILP (field
) && at_field_start
&& at_field_end
)
554 /* If an inserted char would have a nil field while the surrounding
555 text is non-nil, we're probably not looking at a
556 zero-length field, but instead at a non-nil field that's
557 not intended for editing (such as comint's prompts). */
558 at_field_end
= at_field_start
= 0;
561 /* Note about special `boundary' fields:
563 Consider the case where the point (`.') is between the fields `x' and `y':
567 In this situation, if merge_at_boundary is true, we consider the
568 `x' and `y' fields as forming one big merged field, and so the end
569 of the field is the end of `y'.
571 However, if `x' and `y' are separated by a special `boundary' field
572 (a field with a `field' char-property of 'boundary), then we ignore
573 this special field when merging adjacent fields. Here's the same
574 situation, but with a `boundary' field between the `x' and `y' fields:
578 Here, if point is at the end of `x', the beginning of `y', or
579 anywhere in-between (within the `boundary' field), we merge all
580 three fields and consider the beginning as being the beginning of
581 the `x' field, and the end as being the end of the `y' field. */
586 /* POS is at the edge of a field, and we should consider it as
587 the beginning of the following field. */
588 *beg
= XFASTINT (pos
);
590 /* Find the previous field boundary. */
593 if (!NILP (merge_at_boundary
) && EQ (before_field
, Qboundary
))
594 /* Skip a `boundary' field. */
595 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
598 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
600 *beg
= NILP (p
) ? BEGV
: XFASTINT (p
);
607 /* POS is at the edge of a field, and we should consider it as
608 the end of the previous field. */
609 *end
= XFASTINT (pos
);
611 /* Find the next field boundary. */
613 if (!NILP (merge_at_boundary
) && EQ (after_field
, Qboundary
))
614 /* Skip a `boundary' field. */
615 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
618 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
620 *end
= NILP (pos
) ? ZV
: XFASTINT (pos
);
626 DEFUN ("delete-field", Fdelete_field
, Sdelete_field
, 0, 1, 0,
627 doc
: /* Delete the field surrounding POS.
628 A field is a region of text with the same `field' property.
629 If POS is nil, the value of point is used for POS. */)
634 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
636 del_range (beg
, end
);
640 DEFUN ("field-string", Ffield_string
, Sfield_string
, 0, 1, 0,
641 doc
: /* Return the contents of the field surrounding POS as a string.
642 A field is a region of text with the same `field' property.
643 If POS is nil, the value of point is used for POS. */)
648 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
649 return make_buffer_string (beg
, end
, 1);
652 DEFUN ("field-string-no-properties", Ffield_string_no_properties
, Sfield_string_no_properties
, 0, 1, 0,
653 doc
: /* Return the contents of the field around POS, without text-properties.
654 A field is a region of text with the same `field' property.
655 If POS is nil, the value of point is used for POS. */)
660 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
661 return make_buffer_string (beg
, end
, 0);
664 DEFUN ("field-beginning", Ffield_beginning
, Sfield_beginning
, 0, 3, 0,
665 doc
: /* Return the beginning of the field surrounding POS.
666 A field is a region of text with the same `field' property.
667 If POS is nil, the value of point is used for POS.
668 If ESCAPE-FROM-EDGE is non-nil and POS is at the beginning of its
669 field, then the beginning of the *previous* field is returned.
670 If LIMIT is non-nil, it is a buffer position; if the beginning of the field
671 is before LIMIT, then LIMIT will be returned instead. */)
672 (pos
, escape_from_edge
, limit
)
673 Lisp_Object pos
, escape_from_edge
, limit
;
676 find_field (pos
, escape_from_edge
, limit
, &beg
, Qnil
, 0);
677 return make_number (beg
);
680 DEFUN ("field-end", Ffield_end
, Sfield_end
, 0, 3, 0,
681 doc
: /* Return the end of the field surrounding POS.
682 A field is a region of text with the same `field' property.
683 If POS is nil, the value of point is used for POS.
684 If ESCAPE-FROM-EDGE is non-nil and POS is at the end of its field,
685 then the end of the *following* field is returned.
686 If LIMIT is non-nil, it is a buffer position; if the end of the field
687 is after LIMIT, then LIMIT will be returned instead. */)
688 (pos
, escape_from_edge
, limit
)
689 Lisp_Object pos
, escape_from_edge
, limit
;
692 find_field (pos
, escape_from_edge
, Qnil
, 0, limit
, &end
);
693 return make_number (end
);
696 DEFUN ("constrain-to-field", Fconstrain_to_field
, Sconstrain_to_field
, 2, 5, 0,
697 doc
: /* Return the position closest to NEW-POS that is in the same field as OLD-POS.
699 A field is a region of text with the same `field' property.
700 If NEW-POS is nil, then the current point is used instead, and set to the
701 constrained position if that is different.
703 If OLD-POS is at the boundary of two fields, then the allowable
704 positions for NEW-POS depends on the value of the optional argument
705 ESCAPE-FROM-EDGE: If ESCAPE-FROM-EDGE is nil, then NEW-POS is
706 constrained to the field that has the same `field' char-property
707 as any new characters inserted at OLD-POS, whereas if ESCAPE-FROM-EDGE
708 is non-nil, NEW-POS is constrained to the union of the two adjacent
709 fields. Additionally, if two fields are separated by another field with
710 the special value `boundary', then any point within this special field is
711 also considered to be `on the boundary'.
713 If the optional argument ONLY-IN-LINE is non-nil and constraining
714 NEW-POS would move it to a different line, NEW-POS is returned
715 unconstrained. This useful for commands that move by line, like
716 \\[next-line] or \\[beginning-of-line], which should generally respect field boundaries
717 only in the case where they can still move to the right line.
719 If the optional argument INHIBIT-CAPTURE-PROPERTY is non-nil, and OLD-POS has
720 a non-nil property of that name, then any field boundaries are ignored.
722 Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */)
723 (new_pos
, old_pos
, escape_from_edge
, only_in_line
, inhibit_capture_property
)
724 Lisp_Object new_pos
, old_pos
;
725 Lisp_Object escape_from_edge
, only_in_line
, inhibit_capture_property
;
727 /* If non-zero, then the original point, before re-positioning. */
730 Lisp_Object prev_old
, prev_new
;
733 /* Use the current point, and afterwards, set it. */
736 XSETFASTINT (new_pos
, PT
);
739 CHECK_NUMBER_COERCE_MARKER (new_pos
);
740 CHECK_NUMBER_COERCE_MARKER (old_pos
);
742 fwd
= (XFASTINT (new_pos
) > XFASTINT (old_pos
));
744 prev_old
= make_number (XFASTINT (old_pos
) - 1);
745 prev_new
= make_number (XFASTINT (new_pos
) - 1);
747 if (NILP (Vinhibit_field_text_motion
)
748 && !EQ (new_pos
, old_pos
)
749 && (!NILP (Fget_char_property (new_pos
, Qfield
, Qnil
))
750 || !NILP (Fget_char_property (old_pos
, Qfield
, Qnil
))
751 /* To recognize field boundaries, we must also look at the
752 previous positions; we could use `get_pos_property'
753 instead, but in itself that would fail inside non-sticky
754 fields (like comint prompts). */
755 || (XFASTINT (new_pos
) > BEGV
756 && !NILP (Fget_char_property (prev_new
, Qfield
, Qnil
)))
757 || (XFASTINT (old_pos
) > BEGV
758 && !NILP (Fget_char_property (prev_old
, Qfield
, Qnil
))))
759 && (NILP (inhibit_capture_property
)
760 /* Field boundaries are again a problem; but now we must
761 decide the case exactly, so we need to call
762 `get_pos_property' as well. */
763 || (NILP (get_pos_property (old_pos
, inhibit_capture_property
, Qnil
))
764 && (XFASTINT (old_pos
) <= BEGV
765 || NILP (Fget_char_property (old_pos
, inhibit_capture_property
, Qnil
))
766 || NILP (Fget_char_property (prev_old
, inhibit_capture_property
, Qnil
))))))
767 /* It is possible that NEW_POS is not within the same field as
768 OLD_POS; try to move NEW_POS so that it is. */
771 Lisp_Object field_bound
;
774 field_bound
= Ffield_end (old_pos
, escape_from_edge
, new_pos
);
776 field_bound
= Ffield_beginning (old_pos
, escape_from_edge
, new_pos
);
778 if (/* See if ESCAPE_FROM_EDGE caused FIELD_BOUND to jump to the
779 other side of NEW_POS, which would mean that NEW_POS is
780 already acceptable, and it's not necessary to constrain it
782 ((XFASTINT (field_bound
) < XFASTINT (new_pos
)) ? fwd
: !fwd
)
783 /* NEW_POS should be constrained, but only if either
784 ONLY_IN_LINE is nil (in which case any constraint is OK),
785 or NEW_POS and FIELD_BOUND are on the same line (in which
786 case the constraint is OK even if ONLY_IN_LINE is non-nil). */
787 && (NILP (only_in_line
)
788 /* This is the ONLY_IN_LINE case, check that NEW_POS and
789 FIELD_BOUND are on the same line by seeing whether
790 there's an intervening newline or not. */
791 || (scan_buffer ('\n',
792 XFASTINT (new_pos
), XFASTINT (field_bound
),
793 fwd
? -1 : 1, &shortage
, 1),
795 /* Constrain NEW_POS to FIELD_BOUND. */
796 new_pos
= field_bound
;
798 if (orig_point
&& XFASTINT (new_pos
) != orig_point
)
799 /* The NEW_POS argument was originally nil, so automatically set PT. */
800 SET_PT (XFASTINT (new_pos
));
807 DEFUN ("line-beginning-position",
808 Fline_beginning_position
, Sline_beginning_position
, 0, 1, 0,
809 doc
: /* Return the character position of the first character on the current line.
810 With argument N not nil or 1, move forward N - 1 lines first.
811 If scan reaches end of buffer, return that position.
813 This function constrains the returned position to the current field
814 unless that would be on a different line than the original,
815 unconstrained result. If N is nil or 1, and a front-sticky field
816 starts at point, the scan stops as soon as it starts. To ignore field
817 boundaries bind `inhibit-field-text-motion' to t.
819 This function does not move point. */)
823 int orig
, orig_byte
, end
;
824 int count
= SPECPDL_INDEX ();
825 specbind (Qinhibit_point_motion_hooks
, Qt
);
834 Fforward_line (make_number (XINT (n
) - 1));
837 SET_PT_BOTH (orig
, orig_byte
);
839 unbind_to (count
, Qnil
);
841 /* Return END constrained to the current input field. */
842 return Fconstrain_to_field (make_number (end
), make_number (orig
),
843 XINT (n
) != 1 ? Qt
: Qnil
,
847 DEFUN ("line-end-position", Fline_end_position
, Sline_end_position
, 0, 1, 0,
848 doc
: /* Return the character position of the last character on the current line.
849 With argument N not nil or 1, move forward N - 1 lines first.
850 If scan reaches end of buffer, return that position.
852 This function constrains the returned position to the current field
853 unless that would be on a different line than the original,
854 unconstrained result. If N is nil or 1, and a rear-sticky field ends
855 at point, the scan stops as soon as it starts. To ignore field
856 boundaries bind `inhibit-field-text-motion' to t.
858 This function does not move point. */)
870 end_pos
= find_before_next_newline (orig
, 0, XINT (n
) - (XINT (n
) <= 0));
872 /* Return END_POS constrained to the current input field. */
873 return Fconstrain_to_field (make_number (end_pos
), make_number (orig
),
879 save_excursion_save ()
881 int visible
= (XBUFFER (XWINDOW (selected_window
)->buffer
)
884 return Fcons (Fpoint_marker (),
885 Fcons (Fcopy_marker (current_buffer
->mark
, Qnil
),
886 Fcons (visible
? Qt
: Qnil
,
887 Fcons (current_buffer
->mark_active
,
892 save_excursion_restore (info
)
895 Lisp_Object tem
, tem1
, omark
, nmark
;
896 struct gcpro gcpro1
, gcpro2
, gcpro3
;
899 tem
= Fmarker_buffer (XCAR (info
));
900 /* If buffer being returned to is now deleted, avoid error */
901 /* Otherwise could get error here while unwinding to top level
903 /* In that case, Fmarker_buffer returns nil now. */
907 omark
= nmark
= Qnil
;
908 GCPRO3 (info
, omark
, nmark
);
915 unchain_marker (XMARKER (tem
));
920 omark
= Fmarker_position (current_buffer
->mark
);
921 Fset_marker (current_buffer
->mark
, tem
, Fcurrent_buffer ());
922 nmark
= Fmarker_position (tem
);
923 unchain_marker (XMARKER (tem
));
927 visible_p
= !NILP (XCAR (info
));
929 #if 0 /* We used to make the current buffer visible in the selected window
930 if that was true previously. That avoids some anomalies.
931 But it creates others, and it wasn't documented, and it is simpler
932 and cleaner never to alter the window/buffer connections. */
935 && current_buffer
!= XBUFFER (XWINDOW (selected_window
)->buffer
))
936 Fswitch_to_buffer (Fcurrent_buffer (), Qnil
);
942 tem1
= current_buffer
->mark_active
;
943 current_buffer
->mark_active
= tem
;
945 if (!NILP (Vrun_hooks
))
947 /* If mark is active now, and either was not active
948 or was at a different place, run the activate hook. */
949 if (! NILP (current_buffer
->mark_active
))
951 if (! EQ (omark
, nmark
))
952 call1 (Vrun_hooks
, intern ("activate-mark-hook"));
954 /* If mark has ceased to be active, run deactivate hook. */
955 else if (! NILP (tem1
))
956 call1 (Vrun_hooks
, intern ("deactivate-mark-hook"));
959 /* If buffer was visible in a window, and a different window was
960 selected, and the old selected window is still showing this
961 buffer, restore point in that window. */
964 && !EQ (tem
, selected_window
)
965 && (tem1
= XWINDOW (tem
)->buffer
,
966 (/* Window is live... */
968 /* ...and it shows the current buffer. */
969 && XBUFFER (tem1
) == current_buffer
)))
970 Fset_window_point (tem
, make_number (PT
));
976 DEFUN ("save-excursion", Fsave_excursion
, Ssave_excursion
, 0, UNEVALLED
, 0,
977 doc
: /* Save point, mark, and current buffer; execute BODY; restore those things.
978 Executes BODY just like `progn'.
979 The values of point, mark and the current buffer are restored
980 even in case of abnormal exit (throw or error).
981 The state of activation of the mark is also restored.
983 This construct does not save `deactivate-mark', and therefore
984 functions that change the buffer will still cause deactivation
985 of the mark at the end of the command. To prevent that, bind
986 `deactivate-mark' with `let'.
988 usage: (save-excursion &rest BODY) */)
992 register Lisp_Object val
;
993 int count
= SPECPDL_INDEX ();
995 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
998 return unbind_to (count
, val
);
1001 DEFUN ("save-current-buffer", Fsave_current_buffer
, Ssave_current_buffer
, 0, UNEVALLED
, 0,
1002 doc
: /* Save the current buffer; execute BODY; restore the current buffer.
1003 Executes BODY just like `progn'.
1004 usage: (save-current-buffer &rest BODY) */)
1009 int count
= SPECPDL_INDEX ();
1011 record_unwind_protect (set_buffer_if_live
, Fcurrent_buffer ());
1013 val
= Fprogn (args
);
1014 return unbind_to (count
, val
);
1017 DEFUN ("buffer-size", Fbufsize
, Sbufsize
, 0, 1, 0,
1018 doc
: /* Return the number of characters in the current buffer.
1019 If BUFFER, return the number of characters in that buffer instead. */)
1024 return make_number (Z
- BEG
);
1027 CHECK_BUFFER (buffer
);
1028 return make_number (BUF_Z (XBUFFER (buffer
))
1029 - BUF_BEG (XBUFFER (buffer
)));
1033 DEFUN ("point-min", Fpoint_min
, Spoint_min
, 0, 0, 0,
1034 doc
: /* Return the minimum permissible value of point in the current buffer.
1035 This is 1, unless narrowing (a buffer restriction) is in effect. */)
1039 XSETFASTINT (temp
, BEGV
);
1043 DEFUN ("point-min-marker", Fpoint_min_marker
, Spoint_min_marker
, 0, 0, 0,
1044 doc
: /* Return a marker to the minimum permissible value of point in this buffer.
1045 This is the beginning, unless narrowing (a buffer restriction) is in effect. */)
1048 return buildmark (BEGV
, BEGV_BYTE
);
1051 DEFUN ("point-max", Fpoint_max
, Spoint_max
, 0, 0, 0,
1052 doc
: /* Return the maximum permissible value of point in the current buffer.
1053 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1054 is in effect, in which case it is less. */)
1058 XSETFASTINT (temp
, ZV
);
1062 DEFUN ("point-max-marker", Fpoint_max_marker
, Spoint_max_marker
, 0, 0, 0,
1063 doc
: /* Return a marker to the maximum permissible value of point in this buffer.
1064 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1065 is in effect, in which case it is less. */)
1068 return buildmark (ZV
, ZV_BYTE
);
1071 DEFUN ("gap-position", Fgap_position
, Sgap_position
, 0, 0, 0,
1072 doc
: /* Return the position of the gap, in the current buffer.
1073 See also `gap-size'. */)
1077 XSETFASTINT (temp
, GPT
);
1081 DEFUN ("gap-size", Fgap_size
, Sgap_size
, 0, 0, 0,
1082 doc
: /* Return the size of the current buffer's gap.
1083 See also `gap-position'. */)
1087 XSETFASTINT (temp
, GAP_SIZE
);
1091 DEFUN ("position-bytes", Fposition_bytes
, Sposition_bytes
, 1, 1, 0,
1092 doc
: /* Return the byte position for character position POSITION.
1093 If POSITION is out of range, the value is nil. */)
1095 Lisp_Object position
;
1097 CHECK_NUMBER_COERCE_MARKER (position
);
1098 if (XINT (position
) < BEG
|| XINT (position
) > Z
)
1100 return make_number (CHAR_TO_BYTE (XINT (position
)));
1103 DEFUN ("byte-to-position", Fbyte_to_position
, Sbyte_to_position
, 1, 1, 0,
1104 doc
: /* Return the character position for byte position BYTEPOS.
1105 If BYTEPOS is out of range, the value is nil. */)
1107 Lisp_Object bytepos
;
1109 CHECK_NUMBER (bytepos
);
1110 if (XINT (bytepos
) < BEG_BYTE
|| XINT (bytepos
) > Z_BYTE
)
1112 return make_number (BYTE_TO_CHAR (XINT (bytepos
)));
1115 DEFUN ("following-char", Ffollowing_char
, Sfollowing_char
, 0, 0, 0,
1116 doc
: /* Return the character following point, as a number.
1117 At the end of the buffer or accessible region, return 0. */)
1122 XSETFASTINT (temp
, 0);
1124 XSETFASTINT (temp
, FETCH_CHAR (PT_BYTE
));
1128 DEFUN ("preceding-char", Fprevious_char
, Sprevious_char
, 0, 0, 0,
1129 doc
: /* Return the character preceding point, as a number.
1130 At the beginning of the buffer or accessible region, return 0. */)
1135 XSETFASTINT (temp
, 0);
1136 else if (!NILP (current_buffer
->enable_multibyte_characters
))
1140 XSETFASTINT (temp
, FETCH_CHAR (pos
));
1143 XSETFASTINT (temp
, FETCH_BYTE (PT_BYTE
- 1));
1147 DEFUN ("bobp", Fbobp
, Sbobp
, 0, 0, 0,
1148 doc
: /* Return t if point is at the beginning of the buffer.
1149 If the buffer is narrowed, this means the beginning of the narrowed part. */)
1157 DEFUN ("eobp", Feobp
, Seobp
, 0, 0, 0,
1158 doc
: /* Return t if point is at the end of the buffer.
1159 If the buffer is narrowed, this means the end of the narrowed part. */)
1167 DEFUN ("bolp", Fbolp
, Sbolp
, 0, 0, 0,
1168 doc
: /* Return t if point is at the beginning of a line. */)
1171 if (PT
== BEGV
|| FETCH_BYTE (PT_BYTE
- 1) == '\n')
1176 DEFUN ("eolp", Feolp
, Seolp
, 0, 0, 0,
1177 doc
: /* Return t if point is at the end of a line.
1178 `End of a line' includes point being at the end of the buffer. */)
1181 if (PT
== ZV
|| FETCH_BYTE (PT_BYTE
) == '\n')
1186 DEFUN ("char-after", Fchar_after
, Schar_after
, 0, 1, 0,
1187 doc
: /* Return character in current buffer at position POS.
1188 POS is an integer or a marker and defaults to point.
1189 If POS is out of range, the value is nil. */)
1193 register int pos_byte
;
1198 XSETFASTINT (pos
, PT
);
1203 pos_byte
= marker_byte_position (pos
);
1204 if (pos_byte
< BEGV_BYTE
|| pos_byte
>= ZV_BYTE
)
1209 CHECK_NUMBER_COERCE_MARKER (pos
);
1210 if (XINT (pos
) < BEGV
|| XINT (pos
) >= ZV
)
1213 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1216 return make_number (FETCH_CHAR (pos_byte
));
1219 DEFUN ("char-before", Fchar_before
, Schar_before
, 0, 1, 0,
1220 doc
: /* Return character in current buffer preceding position POS.
1221 POS is an integer or a marker and defaults to point.
1222 If POS is out of range, the value is nil. */)
1226 register Lisp_Object val
;
1227 register int pos_byte
;
1232 XSETFASTINT (pos
, PT
);
1237 pos_byte
= marker_byte_position (pos
);
1239 if (pos_byte
<= BEGV_BYTE
|| pos_byte
> ZV_BYTE
)
1244 CHECK_NUMBER_COERCE_MARKER (pos
);
1246 if (XINT (pos
) <= BEGV
|| XINT (pos
) > ZV
)
1249 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1252 if (!NILP (current_buffer
->enable_multibyte_characters
))
1255 XSETFASTINT (val
, FETCH_CHAR (pos_byte
));
1260 XSETFASTINT (val
, FETCH_BYTE (pos_byte
));
1265 DEFUN ("user-login-name", Fuser_login_name
, Suser_login_name
, 0, 1, 0,
1266 doc
: /* Return the name under which the user logged in, as a string.
1267 This is based on the effective uid, not the real uid.
1268 Also, if the environment variables LOGNAME or USER are set,
1269 that determines the value of this function.
1271 If optional argument UID is an integer, return the login name of the user
1272 with that uid, or nil if there is no such user. */)
1278 /* Set up the user name info if we didn't do it before.
1279 (That can happen if Emacs is dumpable
1280 but you decide to run `temacs -l loadup' and not dump. */
1281 if (INTEGERP (Vuser_login_name
))
1285 return Vuser_login_name
;
1288 pw
= (struct passwd
*) getpwuid (XINT (uid
));
1289 return (pw
? build_string (pw
->pw_name
) : Qnil
);
1292 DEFUN ("user-real-login-name", Fuser_real_login_name
, Suser_real_login_name
,
1294 doc
: /* Return the name of the user's real uid, as a string.
1295 This ignores the environment variables LOGNAME and USER, so it differs from
1296 `user-login-name' when running under `su'. */)
1299 /* Set up the user name info if we didn't do it before.
1300 (That can happen if Emacs is dumpable
1301 but you decide to run `temacs -l loadup' and not dump. */
1302 if (INTEGERP (Vuser_login_name
))
1304 return Vuser_real_login_name
;
1307 DEFUN ("user-uid", Fuser_uid
, Suser_uid
, 0, 0, 0,
1308 doc
: /* Return the effective uid of Emacs.
1309 Value is an integer or float, depending on the value. */)
1312 return make_fixnum_or_float (geteuid ());
1315 DEFUN ("user-real-uid", Fuser_real_uid
, Suser_real_uid
, 0, 0, 0,
1316 doc
: /* Return the real uid of Emacs.
1317 Value is an integer or float, depending on the value. */)
1320 return make_fixnum_or_float (getuid ());
1323 DEFUN ("user-full-name", Fuser_full_name
, Suser_full_name
, 0, 1, 0,
1324 doc
: /* Return the full name of the user logged in, as a string.
1325 If the full name corresponding to Emacs's userid is not known,
1328 If optional argument UID is an integer or float, return the full name
1329 of the user with that uid, or nil if there is no such user.
1330 If UID is a string, return the full name of the user with that login
1331 name, or nil if there is no such user. */)
1336 register unsigned char *p
, *q
;
1340 return Vuser_full_name
;
1341 else if (NUMBERP (uid
))
1342 pw
= (struct passwd
*) getpwuid ((uid_t
) XFLOATINT (uid
));
1343 else if (STRINGP (uid
))
1344 pw
= (struct passwd
*) getpwnam (SDATA (uid
));
1346 error ("Invalid UID specification");
1351 p
= (unsigned char *) USER_FULL_NAME
;
1352 /* Chop off everything after the first comma. */
1353 q
= (unsigned char *) index (p
, ',');
1354 full
= make_string (p
, q
? q
- p
: strlen (p
));
1356 #ifdef AMPERSAND_FULL_NAME
1358 q
= (unsigned char *) index (p
, '&');
1359 /* Substitute the login name for the &, upcasing the first character. */
1362 register unsigned char *r
;
1365 login
= Fuser_login_name (make_number (pw
->pw_uid
));
1366 r
= (unsigned char *) alloca (strlen (p
) + SCHARS (login
) + 1);
1367 bcopy (p
, r
, q
- p
);
1369 strcat (r
, SDATA (login
));
1370 r
[q
- p
] = UPCASE (r
[q
- p
]);
1372 full
= build_string (r
);
1374 #endif /* AMPERSAND_FULL_NAME */
1379 DEFUN ("system-name", Fsystem_name
, Ssystem_name
, 0, 0, 0,
1380 doc
: /* Return the name of the machine you are running on, as a string. */)
1383 return Vsystem_name
;
1386 /* For the benefit of callers who don't want to include lisp.h */
1391 if (STRINGP (Vsystem_name
))
1392 return (char *) SDATA (Vsystem_name
);
1398 get_operating_system_release()
1400 if (STRINGP (Voperating_system_release
))
1401 return (char *) SDATA (Voperating_system_release
);
1406 DEFUN ("emacs-pid", Femacs_pid
, Semacs_pid
, 0, 0, 0,
1407 doc
: /* Return the process ID of Emacs, as an integer. */)
1410 return make_number (getpid ());
1413 DEFUN ("current-time", Fcurrent_time
, Scurrent_time
, 0, 0, 0,
1414 doc
: /* Return the current time, as the number of seconds since 1970-01-01 00:00:00.
1415 The time is returned as a list of three integers. The first has the
1416 most significant 16 bits of the seconds, while the second has the
1417 least significant 16 bits. The third integer gives the microsecond
1420 The microsecond count is zero on systems that do not provide
1421 resolution finer than a second. */)
1425 Lisp_Object result
[3];
1428 XSETINT (result
[0], (EMACS_SECS (t
) >> 16) & 0xffff);
1429 XSETINT (result
[1], (EMACS_SECS (t
) >> 0) & 0xffff);
1430 XSETINT (result
[2], EMACS_USECS (t
));
1432 return Flist (3, result
);
1435 DEFUN ("get-internal-run-time", Fget_internal_run_time
, Sget_internal_run_time
,
1437 doc
: /* Return the current run time used by Emacs.
1438 The time is returned as a list of three integers. The first has the
1439 most significant 16 bits of the seconds, while the second has the
1440 least significant 16 bits. The third integer gives the microsecond
1443 On systems that can't determine the run time, get-internal-run-time
1444 does the same thing as current-time. The microsecond count is zero on
1445 systems that do not provide resolution finer than a second. */)
1448 #ifdef HAVE_GETRUSAGE
1449 struct rusage usage
;
1450 Lisp_Object result
[3];
1453 if (getrusage (RUSAGE_SELF
, &usage
) < 0)
1454 /* This shouldn't happen. What action is appropriate? */
1455 Fsignal (Qerror
, Qnil
);
1457 /* Sum up user time and system time. */
1458 secs
= usage
.ru_utime
.tv_sec
+ usage
.ru_stime
.tv_sec
;
1459 usecs
= usage
.ru_utime
.tv_usec
+ usage
.ru_stime
.tv_usec
;
1460 if (usecs
>= 1000000)
1466 XSETINT (result
[0], (secs
>> 16) & 0xffff);
1467 XSETINT (result
[1], (secs
>> 0) & 0xffff);
1468 XSETINT (result
[2], usecs
);
1470 return Flist (3, result
);
1472 return Fcurrent_time ();
1478 lisp_time_argument (specified_time
, result
, usec
)
1479 Lisp_Object specified_time
;
1483 if (NILP (specified_time
))
1490 *usec
= EMACS_USECS (t
);
1491 *result
= EMACS_SECS (t
);
1495 return time (result
) != -1;
1499 Lisp_Object high
, low
;
1500 high
= Fcar (specified_time
);
1501 CHECK_NUMBER (high
);
1502 low
= Fcdr (specified_time
);
1507 Lisp_Object usec_l
= Fcdr (low
);
1509 usec_l
= Fcar (usec_l
);
1514 CHECK_NUMBER (usec_l
);
1515 *usec
= XINT (usec_l
);
1523 *result
= (XINT (high
) << 16) + (XINT (low
) & 0xffff);
1524 return *result
>> 16 == XINT (high
);
1528 DEFUN ("float-time", Ffloat_time
, Sfloat_time
, 0, 1, 0,
1529 doc
: /* Return the current time, as a float number of seconds since the epoch.
1530 If SPECIFIED-TIME is given, it is the time to convert to float
1531 instead of the current time. The argument should have the form
1532 (HIGH LOW . IGNORED). Thus, you can use times obtained from
1533 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
1534 have the form (HIGH . LOW), but this is considered obsolete.
1536 WARNING: Since the result is floating point, it may not be exact.
1537 Do not use this function if precise time stamps are required. */)
1539 Lisp_Object specified_time
;
1544 if (! lisp_time_argument (specified_time
, &sec
, &usec
))
1545 error ("Invalid time specification");
1547 return make_float ((sec
* 1e6
+ usec
) / 1e6
);
1550 /* Write information into buffer S of size MAXSIZE, according to the
1551 FORMAT of length FORMAT_LEN, using time information taken from *TP.
1552 Default to Universal Time if UT is nonzero, local time otherwise.
1553 Return the number of bytes written, not including the terminating
1554 '\0'. If S is NULL, nothing will be written anywhere; so to
1555 determine how many bytes would be written, use NULL for S and
1556 ((size_t) -1) for MAXSIZE.
1558 This function behaves like emacs_strftimeu, except it allows null
1561 emacs_memftimeu (s
, maxsize
, format
, format_len
, tp
, ut
)
1566 const struct tm
*tp
;
1571 /* Loop through all the null-terminated strings in the format
1572 argument. Normally there's just one null-terminated string, but
1573 there can be arbitrarily many, concatenated together, if the
1574 format contains '\0' bytes. emacs_strftimeu stops at the first
1575 '\0' byte so we must invoke it separately for each such string. */
1584 result
= emacs_strftimeu (s
, maxsize
, format
, tp
, ut
);
1588 if (result
== 0 && s
[0] != '\0')
1593 maxsize
-= result
+ 1;
1595 len
= strlen (format
);
1596 if (len
== format_len
)
1600 format_len
-= len
+ 1;
1604 DEFUN ("format-time-string", Fformat_time_string
, Sformat_time_string
, 1, 3, 0,
1605 doc
: /* Use FORMAT-STRING to format the time TIME, or now if omitted.
1606 TIME is specified as (HIGH LOW . IGNORED), as returned by
1607 `current-time' or `file-attributes'. The obsolete form (HIGH . LOW)
1608 is also still accepted.
1609 The third, optional, argument UNIVERSAL, if non-nil, means describe TIME
1610 as Universal Time; nil means describe TIME in the local time zone.
1611 The value is a copy of FORMAT-STRING, but with certain constructs replaced
1612 by text that describes the specified date and time in TIME:
1614 %Y is the year, %y within the century, %C the century.
1615 %G is the year corresponding to the ISO week, %g within the century.
1616 %m is the numeric month.
1617 %b and %h are the locale's abbreviated month name, %B the full name.
1618 %d is the day of the month, zero-padded, %e is blank-padded.
1619 %u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.
1620 %a is the locale's abbreviated name of the day of week, %A the full name.
1621 %U is the week number starting on Sunday, %W starting on Monday,
1622 %V according to ISO 8601.
1623 %j is the day of the year.
1625 %H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H
1626 only blank-padded, %l is like %I blank-padded.
1627 %p is the locale's equivalent of either AM or PM.
1630 %Z is the time zone name, %z is the numeric form.
1631 %s is the number of seconds since 1970-01-01 00:00:00 +0000.
1633 %c is the locale's date and time format.
1634 %x is the locale's "preferred" date format.
1635 %D is like "%m/%d/%y".
1637 %R is like "%H:%M", %T is like "%H:%M:%S", %r is like "%I:%M:%S %p".
1638 %X is the locale's "preferred" time format.
1640 Finally, %n is a newline, %t is a tab, %% is a literal %.
1642 Certain flags and modifiers are available with some format controls.
1643 The flags are `_', `-', `^' and `#'. For certain characters X,
1644 %_X is like %X, but padded with blanks; %-X is like %X,
1645 but without padding. %^X is like %X, but with all textual
1646 characters up-cased; %#X is like %X, but with letter-case of
1647 all textual characters reversed.
1648 %NX (where N stands for an integer) is like %X,
1649 but takes up at least N (a number) positions.
1650 The modifiers are `E' and `O'. For certain characters X,
1651 %EX is a locale's alternative version of %X;
1652 %OX is like %X, but uses the locale's number symbols.
1654 For example, to produce full ISO 8601 format, use "%Y-%m-%dT%T%z". */)
1655 (format_string
, time
, universal
)
1656 Lisp_Object format_string
, time
, universal
;
1661 int ut
= ! NILP (universal
);
1663 CHECK_STRING (format_string
);
1665 if (! lisp_time_argument (time
, &value
, NULL
))
1666 error ("Invalid time specification");
1668 format_string
= code_convert_string_norecord (format_string
,
1669 Vlocale_coding_system
, 1);
1671 /* This is probably enough. */
1672 size
= SBYTES (format_string
) * 6 + 50;
1674 tm
= ut
? gmtime (&value
) : localtime (&value
);
1676 error ("Specified time is not representable");
1678 synchronize_system_time_locale ();
1682 char *buf
= (char *) alloca (size
+ 1);
1686 result
= emacs_memftimeu (buf
, size
, SDATA (format_string
),
1687 SBYTES (format_string
),
1689 if ((result
> 0 && result
< size
) || (result
== 0 && buf
[0] == '\0'))
1690 return code_convert_string_norecord (make_string (buf
, result
),
1691 Vlocale_coding_system
, 0);
1693 /* If buffer was too small, make it bigger and try again. */
1694 result
= emacs_memftimeu (NULL
, (size_t) -1,
1695 SDATA (format_string
),
1696 SBYTES (format_string
),
1702 DEFUN ("decode-time", Fdecode_time
, Sdecode_time
, 0, 1, 0,
1703 doc
: /* Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST ZONE).
1704 The optional SPECIFIED-TIME should be a list of (HIGH LOW . IGNORED),
1705 as from `current-time' and `file-attributes', or `nil' to use the
1706 current time. The obsolete form (HIGH . LOW) is also still accepted.
1707 The list has the following nine members: SEC is an integer between 0
1708 and 60; SEC is 60 for a leap second, which only some operating systems
1709 support. MINUTE is an integer between 0 and 59. HOUR is an integer
1710 between 0 and 23. DAY is an integer between 1 and 31. MONTH is an
1711 integer between 1 and 12. YEAR is an integer indicating the
1712 four-digit year. DOW is the day of week, an integer between 0 and 6,
1713 where 0 is Sunday. DST is t if daylight savings time is effect,
1714 otherwise nil. ZONE is an integer indicating the number of seconds
1715 east of Greenwich. (Note that Common Lisp has different meanings for
1718 Lisp_Object specified_time
;
1722 struct tm
*decoded_time
;
1723 Lisp_Object list_args
[9];
1725 if (! lisp_time_argument (specified_time
, &time_spec
, NULL
))
1726 error ("Invalid time specification");
1728 decoded_time
= localtime (&time_spec
);
1730 error ("Specified time is not representable");
1731 XSETFASTINT (list_args
[0], decoded_time
->tm_sec
);
1732 XSETFASTINT (list_args
[1], decoded_time
->tm_min
);
1733 XSETFASTINT (list_args
[2], decoded_time
->tm_hour
);
1734 XSETFASTINT (list_args
[3], decoded_time
->tm_mday
);
1735 XSETFASTINT (list_args
[4], decoded_time
->tm_mon
+ 1);
1736 /* On 64-bit machines an int is narrower than EMACS_INT, thus the
1737 cast below avoids overflow in int arithmetics. */
1738 XSETINT (list_args
[5], TM_YEAR_BASE
+ (EMACS_INT
) decoded_time
->tm_year
);
1739 XSETFASTINT (list_args
[6], decoded_time
->tm_wday
);
1740 list_args
[7] = (decoded_time
->tm_isdst
)? Qt
: Qnil
;
1742 /* Make a copy, in case gmtime modifies the struct. */
1743 save_tm
= *decoded_time
;
1744 decoded_time
= gmtime (&time_spec
);
1745 if (decoded_time
== 0)
1746 list_args
[8] = Qnil
;
1748 XSETINT (list_args
[8], tm_diff (&save_tm
, decoded_time
));
1749 return Flist (9, list_args
);
1752 DEFUN ("encode-time", Fencode_time
, Sencode_time
, 6, MANY
, 0,
1753 doc
: /* Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.
1754 This is the reverse operation of `decode-time', which see.
1755 ZONE defaults to the current time zone rule. This can
1756 be a string or t (as from `set-time-zone-rule'), or it can be a list
1757 \(as from `current-time-zone') or an integer (as from `decode-time')
1758 applied without consideration for daylight savings time.
1760 You can pass more than 7 arguments; then the first six arguments
1761 are used as SECOND through YEAR, and the *last* argument is used as ZONE.
1762 The intervening arguments are ignored.
1763 This feature lets (apply 'encode-time (decode-time ...)) work.
1765 Out-of-range values for SECOND, MINUTE, HOUR, DAY, or MONTH are allowed;
1766 for example, a DAY of 0 means the day preceding the given month.
1767 Year numbers less than 100 are treated just like other year numbers.
1768 If you want them to stand for years in this century, you must do that yourself.
1770 Years before 1970 are not guaranteed to work. On some systems,
1771 year values as low as 1901 do work.
1773 usage: (encode-time SECOND MINUTE HOUR DAY MONTH YEAR &optional ZONE) */)
1776 register Lisp_Object
*args
;
1780 Lisp_Object zone
= (nargs
> 6 ? args
[nargs
- 1] : Qnil
);
1782 CHECK_NUMBER (args
[0]); /* second */
1783 CHECK_NUMBER (args
[1]); /* minute */
1784 CHECK_NUMBER (args
[2]); /* hour */
1785 CHECK_NUMBER (args
[3]); /* day */
1786 CHECK_NUMBER (args
[4]); /* month */
1787 CHECK_NUMBER (args
[5]); /* year */
1789 tm
.tm_sec
= XINT (args
[0]);
1790 tm
.tm_min
= XINT (args
[1]);
1791 tm
.tm_hour
= XINT (args
[2]);
1792 tm
.tm_mday
= XINT (args
[3]);
1793 tm
.tm_mon
= XINT (args
[4]) - 1;
1794 tm
.tm_year
= XINT (args
[5]) - TM_YEAR_BASE
;
1800 time
= mktime (&tm
);
1805 char **oldenv
= environ
, **newenv
;
1809 else if (STRINGP (zone
))
1810 tzstring
= (char *) SDATA (zone
);
1811 else if (INTEGERP (zone
))
1813 int abszone
= abs (XINT (zone
));
1814 sprintf (tzbuf
, "XXX%s%d:%02d:%02d", "-" + (XINT (zone
) < 0),
1815 abszone
/ (60*60), (abszone
/60) % 60, abszone
% 60);
1819 error ("Invalid time zone specification");
1821 /* Set TZ before calling mktime; merely adjusting mktime's returned
1822 value doesn't suffice, since that would mishandle leap seconds. */
1823 set_time_zone_rule (tzstring
);
1825 time
= mktime (&tm
);
1827 /* Restore TZ to previous value. */
1831 #ifdef LOCALTIME_CACHE
1836 if (time
== (time_t) -1)
1837 error ("Specified time is not representable");
1839 return make_time (time
);
1842 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
, 0, 1, 0,
1843 doc
: /* Return the current time, as a human-readable string.
1844 Programs can use this function to decode a time,
1845 since the number of columns in each field is fixed
1846 if the year is in the range 1000-9999.
1847 The format is `Sun Sep 16 01:03:52 1973'.
1848 However, see also the functions `decode-time' and `format-time-string'
1849 which provide a much more powerful and general facility.
1851 If SPECIFIED-TIME is given, it is a time to format instead of the
1852 current time. The argument should have the form (HIGH LOW . IGNORED).
1853 Thus, you can use times obtained from `current-time' and from
1854 `file-attributes'. SPECIFIED-TIME can also have the form (HIGH . LOW),
1855 but this is considered obsolete. */)
1857 Lisp_Object specified_time
;
1863 if (! lisp_time_argument (specified_time
, &value
, NULL
))
1864 error ("Invalid time specification");
1866 /* Convert to a string, checking for out-of-range time stamps.
1867 Don't use 'ctime', as that might dump core if VALUE is out of
1869 tm
= localtime (&value
);
1870 if (! (tm
&& TM_YEAR_IN_ASCTIME_RANGE (tm
->tm_year
) && (tem
= asctime (tm
))))
1871 error ("Specified time is not representable");
1873 /* Remove the trailing newline. */
1874 tem
[strlen (tem
) - 1] = '\0';
1876 return build_string (tem
);
1879 /* Yield A - B, measured in seconds.
1880 This function is copied from the GNU C Library. */
1885 /* Compute intervening leap days correctly even if year is negative.
1886 Take care to avoid int overflow in leap day calculations,
1887 but it's OK to assume that A and B are close to each other. */
1888 int a4
= (a
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (a
->tm_year
& 3);
1889 int b4
= (b
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (b
->tm_year
& 3);
1890 int a100
= a4
/ 25 - (a4
% 25 < 0);
1891 int b100
= b4
/ 25 - (b4
% 25 < 0);
1892 int a400
= a100
>> 2;
1893 int b400
= b100
>> 2;
1894 int intervening_leap_days
= (a4
- b4
) - (a100
- b100
) + (a400
- b400
);
1895 int years
= a
->tm_year
- b
->tm_year
;
1896 int days
= (365 * years
+ intervening_leap_days
1897 + (a
->tm_yday
- b
->tm_yday
));
1898 return (60 * (60 * (24 * days
+ (a
->tm_hour
- b
->tm_hour
))
1899 + (a
->tm_min
- b
->tm_min
))
1900 + (a
->tm_sec
- b
->tm_sec
));
1903 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 1, 0,
1904 doc
: /* Return the offset and name for the local time zone.
1905 This returns a list of the form (OFFSET NAME).
1906 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).
1907 A negative value means west of Greenwich.
1908 NAME is a string giving the name of the time zone.
1909 If SPECIFIED-TIME is given, the time zone offset is determined from it
1910 instead of using the current time. The argument should have the form
1911 (HIGH LOW . IGNORED). Thus, you can use times obtained from
1912 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
1913 have the form (HIGH . LOW), but this is considered obsolete.
1915 Some operating systems cannot provide all this information to Emacs;
1916 in this case, `current-time-zone' returns a list containing nil for
1917 the data it can't find. */)
1919 Lisp_Object specified_time
;
1925 if (lisp_time_argument (specified_time
, &value
, NULL
)
1926 && (t
= gmtime (&value
)) != 0
1927 && (gmt
= *t
, t
= localtime (&value
)) != 0)
1929 int offset
= tm_diff (t
, &gmt
);
1934 s
= (char *)t
->tm_zone
;
1935 #else /* not HAVE_TM_ZONE */
1937 if (t
->tm_isdst
== 0 || t
->tm_isdst
== 1)
1938 s
= tzname
[t
->tm_isdst
];
1940 #endif /* not HAVE_TM_ZONE */
1942 #if defined HAVE_TM_ZONE || defined HAVE_TZNAME
1945 /* On Japanese w32, we can get a Japanese string as time
1946 zone name. Don't accept that. */
1948 for (p
= s
; *p
&& (isalnum ((unsigned char)*p
) || *p
== ' '); ++p
)
1957 /* No local time zone name is available; use "+-NNNN" instead. */
1958 int am
= (offset
< 0 ? -offset
: offset
) / 60;
1959 sprintf (buf
, "%c%02d%02d", (offset
< 0 ? '-' : '+'), am
/60, am
%60);
1962 return Fcons (make_number (offset
), Fcons (build_string (s
), Qnil
));
1965 return Fmake_list (make_number (2), Qnil
);
1968 /* This holds the value of `environ' produced by the previous
1969 call to Fset_time_zone_rule, or 0 if Fset_time_zone_rule
1970 has never been called. */
1971 static char **environbuf
;
1973 DEFUN ("set-time-zone-rule", Fset_time_zone_rule
, Sset_time_zone_rule
, 1, 1, 0,
1974 doc
: /* Set the local time zone using TZ, a string specifying a time zone rule.
1975 If TZ is nil, use implementation-defined default time zone information.
1976 If TZ is t, use Universal Time. */)
1984 else if (EQ (tz
, Qt
))
1989 tzstring
= (char *) SDATA (tz
);
1992 set_time_zone_rule (tzstring
);
1995 environbuf
= environ
;
2000 #ifdef LOCALTIME_CACHE
2002 /* These two values are known to load tz files in buggy implementations,
2003 i.e. Solaris 1 executables running under either Solaris 1 or Solaris 2.
2004 Their values shouldn't matter in non-buggy implementations.
2005 We don't use string literals for these strings,
2006 since if a string in the environment is in readonly
2007 storage, it runs afoul of bugs in SVR4 and Solaris 2.3.
2008 See Sun bugs 1113095 and 1114114, ``Timezone routines
2009 improperly modify environment''. */
2011 static char set_time_zone_rule_tz1
[] = "TZ=GMT+0";
2012 static char set_time_zone_rule_tz2
[] = "TZ=GMT+1";
2016 /* Set the local time zone rule to TZSTRING.
2017 This allocates memory into `environ', which it is the caller's
2018 responsibility to free. */
2021 set_time_zone_rule (tzstring
)
2025 char **from
, **to
, **newenv
;
2027 /* Make the ENVIRON vector longer with room for TZSTRING. */
2028 for (from
= environ
; *from
; from
++)
2030 envptrs
= from
- environ
+ 2;
2031 newenv
= to
= (char **) xmalloc (envptrs
* sizeof (char *)
2032 + (tzstring
? strlen (tzstring
) + 4 : 0));
2034 /* Add TZSTRING to the end of environ, as a value for TZ. */
2037 char *t
= (char *) (to
+ envptrs
);
2039 strcat (t
, tzstring
);
2043 /* Copy the old environ vector elements into NEWENV,
2044 but don't copy the TZ variable.
2045 So we have only one definition of TZ, which came from TZSTRING. */
2046 for (from
= environ
; *from
; from
++)
2047 if (strncmp (*from
, "TZ=", 3) != 0)
2053 /* If we do have a TZSTRING, NEWENV points to the vector slot where
2054 the TZ variable is stored. If we do not have a TZSTRING,
2055 TO points to the vector slot which has the terminating null. */
2057 #ifdef LOCALTIME_CACHE
2059 /* In SunOS 4.1.3_U1 and 4.1.4, if TZ has a value like
2060 "US/Pacific" that loads a tz file, then changes to a value like
2061 "XXX0" that does not load a tz file, and then changes back to
2062 its original value, the last change is (incorrectly) ignored.
2063 Also, if TZ changes twice in succession to values that do
2064 not load a tz file, tzset can dump core (see Sun bug#1225179).
2065 The following code works around these bugs. */
2069 /* Temporarily set TZ to a value that loads a tz file
2070 and that differs from tzstring. */
2072 *newenv
= (strcmp (tzstring
, set_time_zone_rule_tz1
+ 3) == 0
2073 ? set_time_zone_rule_tz2
: set_time_zone_rule_tz1
);
2079 /* The implied tzstring is unknown, so temporarily set TZ to
2080 two different values that each load a tz file. */
2081 *to
= set_time_zone_rule_tz1
;
2084 *to
= set_time_zone_rule_tz2
;
2089 /* Now TZ has the desired value, and tzset can be invoked safely. */
2096 /* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC
2097 (if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a
2098 type of object is Lisp_String). INHERIT is passed to
2099 INSERT_FROM_STRING_FUNC as the last argument. */
2102 general_insert_function (insert_func
, insert_from_string_func
,
2103 inherit
, nargs
, args
)
2104 void (*insert_func
) P_ ((const unsigned char *, int));
2105 void (*insert_from_string_func
) P_ ((Lisp_Object
, int, int, int, int, int));
2107 register Lisp_Object
*args
;
2109 register int argnum
;
2110 register Lisp_Object val
;
2112 for (argnum
= 0; argnum
< nargs
; argnum
++)
2118 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2121 if (!NILP (current_buffer
->enable_multibyte_characters
))
2122 len
= CHAR_STRING (XFASTINT (val
), str
);
2125 str
[0] = (ASCII_CHAR_P (XINT (val
))
2127 : multibyte_char_to_unibyte (XINT (val
), Qnil
));
2130 (*insert_func
) (str
, len
);
2132 else if (STRINGP (val
))
2134 (*insert_from_string_func
) (val
, 0, 0,
2141 val
= wrong_type_argument (Qchar_or_string_p
, val
);
2155 /* Callers passing one argument to Finsert need not gcpro the
2156 argument "array", since the only element of the array will
2157 not be used after calling insert or insert_from_string, so
2158 we don't care if it gets trashed. */
2160 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
2161 doc
: /* Insert the arguments, either strings or characters, at point.
2162 Point and before-insertion markers move forward to end up
2163 after the inserted text.
2164 Any other markers at the point of insertion remain before the text.
2166 If the current buffer is multibyte, unibyte strings are converted
2167 to multibyte for insertion (see `string-make-multibyte').
2168 If the current buffer is unibyte, multibyte strings are converted
2169 to unibyte for insertion (see `string-make-unibyte').
2171 When operating on binary data, it may be necessary to preserve the
2172 original bytes of a unibyte string when inserting it into a multibyte
2173 buffer; to accomplish this, apply `string-as-multibyte' to the string
2174 and insert the result.
2176 usage: (insert &rest ARGS) */)
2179 register Lisp_Object
*args
;
2181 general_insert_function (insert
, insert_from_string
, 0, nargs
, args
);
2185 DEFUN ("insert-and-inherit", Finsert_and_inherit
, Sinsert_and_inherit
,
2187 doc
: /* Insert the arguments at point, inheriting properties from adjoining text.
2188 Point and before-insertion markers move forward to end up
2189 after the inserted text.
2190 Any other markers at the point of insertion remain before the text.
2192 If the current buffer is multibyte, unibyte strings are converted
2193 to multibyte for insertion (see `unibyte-char-to-multibyte').
2194 If the current buffer is unibyte, multibyte strings are converted
2195 to unibyte for insertion.
2197 usage: (insert-and-inherit &rest ARGS) */)
2200 register Lisp_Object
*args
;
2202 general_insert_function (insert_and_inherit
, insert_from_string
, 1,
2207 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
2208 doc
: /* Insert strings or characters at point, relocating markers after the text.
2209 Point and markers move forward to end up after the inserted text.
2211 If the current buffer is multibyte, unibyte strings are converted
2212 to multibyte for insertion (see `unibyte-char-to-multibyte').
2213 If the current buffer is unibyte, multibyte strings are converted
2214 to unibyte for insertion.
2216 usage: (insert-before-markers &rest ARGS) */)
2219 register Lisp_Object
*args
;
2221 general_insert_function (insert_before_markers
,
2222 insert_from_string_before_markers
, 0,
2227 DEFUN ("insert-before-markers-and-inherit", Finsert_and_inherit_before_markers
,
2228 Sinsert_and_inherit_before_markers
, 0, MANY
, 0,
2229 doc
: /* Insert text at point, relocating markers and inheriting properties.
2230 Point and markers move forward to end up after the inserted text.
2232 If the current buffer is multibyte, unibyte strings are converted
2233 to multibyte for insertion (see `unibyte-char-to-multibyte').
2234 If the current buffer is unibyte, multibyte strings are converted
2235 to unibyte for insertion.
2237 usage: (insert-before-markers-and-inherit &rest ARGS) */)
2240 register Lisp_Object
*args
;
2242 general_insert_function (insert_before_markers_and_inherit
,
2243 insert_from_string_before_markers
, 1,
2248 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 2, 3, 0,
2249 doc
: /* Insert COUNT (second arg) copies of CHARACTER (first arg).
2250 Both arguments are required.
2251 Point, and before-insertion markers, are relocated as in the function `insert'.
2252 The optional third arg INHERIT, if non-nil, says to inherit text properties
2253 from adjoining text, if those properties are sticky. */)
2254 (character
, count
, inherit
)
2255 Lisp_Object character
, count
, inherit
;
2257 register unsigned char *string
;
2258 register int strlen
;
2261 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2263 CHECK_NUMBER (character
);
2264 CHECK_NUMBER (count
);
2266 if (!NILP (current_buffer
->enable_multibyte_characters
))
2267 len
= CHAR_STRING (XFASTINT (character
), str
);
2269 str
[0] = XFASTINT (character
), len
= 1;
2270 n
= XINT (count
) * len
;
2273 strlen
= min (n
, 256 * len
);
2274 string
= (unsigned char *) alloca (strlen
);
2275 for (i
= 0; i
< strlen
; i
++)
2276 string
[i
] = str
[i
% len
];
2280 if (!NILP (inherit
))
2281 insert_and_inherit (string
, strlen
);
2283 insert (string
, strlen
);
2288 if (!NILP (inherit
))
2289 insert_and_inherit (string
, n
);
2296 DEFUN ("insert-byte", Finsert_byte
, Sinsert_byte
, 2, 3, 0,
2297 doc
: /* Insert COUNT (second arg) copies of BYTE (first arg).
2298 Both arguments are required.
2299 BYTE is a number of the range 0..255.
2301 If BYTE is 128..255 and the current buffer is multibyte, the
2302 corresponding eight-bit character is inserted.
2304 Point, and before-insertion markers, are relocated as in the function `insert'.
2305 The optional third arg INHERIT, if non-nil, says to inherit text properties
2306 from adjoining text, if those properties are sticky. */)
2307 (byte
, count
, inherit
)
2308 Lisp_Object byte
, count
, inherit
;
2310 CHECK_NUMBER (byte
);
2311 if (XINT (byte
) < 0 || XINT (byte
) > 255)
2312 args_out_of_range_3 (byte
, make_number (0), make_number (255));
2313 if (XINT (byte
) >= 128
2314 && ! NILP (current_buffer
->enable_multibyte_characters
))
2315 XSETFASTINT (byte
, BYTE8_TO_CHAR (XINT (byte
)));
2316 return Finsert_char (byte
, count
, inherit
);
2320 /* Making strings from buffer contents. */
2322 /* Return a Lisp_String containing the text of the current buffer from
2323 START to END. If text properties are in use and the current buffer
2324 has properties in the range specified, the resulting string will also
2325 have them, if PROPS is nonzero.
2327 We don't want to use plain old make_string here, because it calls
2328 make_uninit_string, which can cause the buffer arena to be
2329 compacted. make_string has no way of knowing that the data has
2330 been moved, and thus copies the wrong data into the string. This
2331 doesn't effect most of the other users of make_string, so it should
2332 be left as is. But we should use this function when conjuring
2333 buffer substrings. */
2336 make_buffer_string (start
, end
, props
)
2340 int start_byte
= CHAR_TO_BYTE (start
);
2341 int end_byte
= CHAR_TO_BYTE (end
);
2343 return make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
);
2346 /* Return a Lisp_String containing the text of the current buffer from
2347 START / START_BYTE to END / END_BYTE.
2349 If text properties are in use and the current buffer
2350 has properties in the range specified, the resulting string will also
2351 have them, if PROPS is nonzero.
2353 We don't want to use plain old make_string here, because it calls
2354 make_uninit_string, which can cause the buffer arena to be
2355 compacted. make_string has no way of knowing that the data has
2356 been moved, and thus copies the wrong data into the string. This
2357 doesn't effect most of the other users of make_string, so it should
2358 be left as is. But we should use this function when conjuring
2359 buffer substrings. */
2362 make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
)
2363 int start
, start_byte
, end
, end_byte
;
2366 Lisp_Object result
, tem
, tem1
;
2368 if (start
< GPT
&& GPT
< end
)
2371 if (! NILP (current_buffer
->enable_multibyte_characters
))
2372 result
= make_uninit_multibyte_string (end
- start
, end_byte
- start_byte
);
2374 result
= make_uninit_string (end
- start
);
2375 bcopy (BYTE_POS_ADDR (start_byte
), SDATA (result
),
2376 end_byte
- start_byte
);
2378 /* If desired, update and copy the text properties. */
2381 update_buffer_properties (start
, end
);
2383 tem
= Fnext_property_change (make_number (start
), Qnil
, make_number (end
));
2384 tem1
= Ftext_properties_at (make_number (start
), Qnil
);
2386 if (XINT (tem
) != end
|| !NILP (tem1
))
2387 copy_intervals_to_string (result
, current_buffer
, start
,
2394 /* Call Vbuffer_access_fontify_functions for the range START ... END
2395 in the current buffer, if necessary. */
2398 update_buffer_properties (start
, end
)
2401 /* If this buffer has some access functions,
2402 call them, specifying the range of the buffer being accessed. */
2403 if (!NILP (Vbuffer_access_fontify_functions
))
2405 Lisp_Object args
[3];
2408 args
[0] = Qbuffer_access_fontify_functions
;
2409 XSETINT (args
[1], start
);
2410 XSETINT (args
[2], end
);
2412 /* But don't call them if we can tell that the work
2413 has already been done. */
2414 if (!NILP (Vbuffer_access_fontified_property
))
2416 tem
= Ftext_property_any (args
[1], args
[2],
2417 Vbuffer_access_fontified_property
,
2420 Frun_hook_with_args (3, args
);
2423 Frun_hook_with_args (3, args
);
2427 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
2428 doc
: /* Return the contents of part of the current buffer as a string.
2429 The two arguments START and END are character positions;
2430 they can be in either order.
2431 The string returned is multibyte if the buffer is multibyte.
2433 This function copies the text properties of that part of the buffer
2434 into the result string; if you don't want the text properties,
2435 use `buffer-substring-no-properties' instead. */)
2437 Lisp_Object start
, end
;
2441 validate_region (&start
, &end
);
2445 return make_buffer_string (b
, e
, 1);
2448 DEFUN ("buffer-substring-no-properties", Fbuffer_substring_no_properties
,
2449 Sbuffer_substring_no_properties
, 2, 2, 0,
2450 doc
: /* Return the characters of part of the buffer, without the text properties.
2451 The two arguments START and END are character positions;
2452 they can be in either order. */)
2454 Lisp_Object start
, end
;
2458 validate_region (&start
, &end
);
2462 return make_buffer_string (b
, e
, 0);
2465 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
2466 doc
: /* Return the contents of the current buffer as a string.
2467 If narrowing is in effect, this function returns only the visible part
2471 return make_buffer_string (BEGV
, ZV
, 1);
2474 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
2476 doc
: /* Insert before point a substring of the contents of BUFFER.
2477 BUFFER may be a buffer or a buffer name.
2478 Arguments START and END are character positions specifying the substring.
2479 They default to the values of (point-min) and (point-max) in BUFFER. */)
2480 (buffer
, start
, end
)
2481 Lisp_Object buffer
, start
, end
;
2483 register int b
, e
, temp
;
2484 register struct buffer
*bp
, *obuf
;
2487 buf
= Fget_buffer (buffer
);
2491 if (NILP (bp
->name
))
2492 error ("Selecting deleted buffer");
2498 CHECK_NUMBER_COERCE_MARKER (start
);
2505 CHECK_NUMBER_COERCE_MARKER (end
);
2510 temp
= b
, b
= e
, e
= temp
;
2512 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
2513 args_out_of_range (start
, end
);
2515 obuf
= current_buffer
;
2516 set_buffer_internal_1 (bp
);
2517 update_buffer_properties (b
, e
);
2518 set_buffer_internal_1 (obuf
);
2520 insert_from_buffer (bp
, b
, e
- b
, 0);
2524 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
2526 doc
: /* Compare two substrings of two buffers; return result as number.
2527 the value is -N if first string is less after N-1 chars,
2528 +N if first string is greater after N-1 chars, or 0 if strings match.
2529 Each substring is represented as three arguments: BUFFER, START and END.
2530 That makes six args in all, three for each substring.
2532 The value of `case-fold-search' in the current buffer
2533 determines whether case is significant or ignored. */)
2534 (buffer1
, start1
, end1
, buffer2
, start2
, end2
)
2535 Lisp_Object buffer1
, start1
, end1
, buffer2
, start2
, end2
;
2537 register int begp1
, endp1
, begp2
, endp2
, temp
;
2538 register struct buffer
*bp1
, *bp2
;
2539 register Lisp_Object trt
2540 = (!NILP (current_buffer
->case_fold_search
)
2541 ? current_buffer
->case_canon_table
: Qnil
);
2543 int i1
, i2
, i1_byte
, i2_byte
;
2545 /* Find the first buffer and its substring. */
2548 bp1
= current_buffer
;
2552 buf1
= Fget_buffer (buffer1
);
2555 bp1
= XBUFFER (buf1
);
2556 if (NILP (bp1
->name
))
2557 error ("Selecting deleted buffer");
2561 begp1
= BUF_BEGV (bp1
);
2564 CHECK_NUMBER_COERCE_MARKER (start1
);
2565 begp1
= XINT (start1
);
2568 endp1
= BUF_ZV (bp1
);
2571 CHECK_NUMBER_COERCE_MARKER (end1
);
2572 endp1
= XINT (end1
);
2576 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
2578 if (!(BUF_BEGV (bp1
) <= begp1
2580 && endp1
<= BUF_ZV (bp1
)))
2581 args_out_of_range (start1
, end1
);
2583 /* Likewise for second substring. */
2586 bp2
= current_buffer
;
2590 buf2
= Fget_buffer (buffer2
);
2593 bp2
= XBUFFER (buf2
);
2594 if (NILP (bp2
->name
))
2595 error ("Selecting deleted buffer");
2599 begp2
= BUF_BEGV (bp2
);
2602 CHECK_NUMBER_COERCE_MARKER (start2
);
2603 begp2
= XINT (start2
);
2606 endp2
= BUF_ZV (bp2
);
2609 CHECK_NUMBER_COERCE_MARKER (end2
);
2610 endp2
= XINT (end2
);
2614 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
2616 if (!(BUF_BEGV (bp2
) <= begp2
2618 && endp2
<= BUF_ZV (bp2
)))
2619 args_out_of_range (start2
, end2
);
2623 i1_byte
= buf_charpos_to_bytepos (bp1
, i1
);
2624 i2_byte
= buf_charpos_to_bytepos (bp2
, i2
);
2626 while (i1
< endp1
&& i2
< endp2
)
2628 /* When we find a mismatch, we must compare the
2629 characters, not just the bytes. */
2634 if (! NILP (bp1
->enable_multibyte_characters
))
2636 c1
= BUF_FETCH_MULTIBYTE_CHAR (bp1
, i1_byte
);
2637 BUF_INC_POS (bp1
, i1_byte
);
2642 c1
= BUF_FETCH_BYTE (bp1
, i1
);
2643 c1
= unibyte_char_to_multibyte (c1
);
2647 if (! NILP (bp2
->enable_multibyte_characters
))
2649 c2
= BUF_FETCH_MULTIBYTE_CHAR (bp2
, i2_byte
);
2650 BUF_INC_POS (bp2
, i2_byte
);
2655 c2
= BUF_FETCH_BYTE (bp2
, i2
);
2656 c2
= unibyte_char_to_multibyte (c2
);
2662 c1
= CHAR_TABLE_TRANSLATE (trt
, c1
);
2663 c2
= CHAR_TABLE_TRANSLATE (trt
, c2
);
2666 return make_number (- 1 - chars
);
2668 return make_number (chars
+ 1);
2673 /* The strings match as far as they go.
2674 If one is shorter, that one is less. */
2675 if (chars
< endp1
- begp1
)
2676 return make_number (chars
+ 1);
2677 else if (chars
< endp2
- begp2
)
2678 return make_number (- chars
- 1);
2680 /* Same length too => they are equal. */
2681 return make_number (0);
2685 subst_char_in_region_unwind (arg
)
2688 return current_buffer
->undo_list
= arg
;
2692 subst_char_in_region_unwind_1 (arg
)
2695 return current_buffer
->filename
= arg
;
2698 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
2699 Ssubst_char_in_region
, 4, 5, 0,
2700 doc
: /* From START to END, replace FROMCHAR with TOCHAR each time it occurs.
2701 If optional arg NOUNDO is non-nil, don't record this change for undo
2702 and don't mark the buffer as really changed.
2703 Both characters must have the same length of multi-byte form. */)
2704 (start
, end
, fromchar
, tochar
, noundo
)
2705 Lisp_Object start
, end
, fromchar
, tochar
, noundo
;
2707 register int pos
, pos_byte
, stop
, i
, len
, end_byte
;
2709 unsigned char fromstr
[MAX_MULTIBYTE_LENGTH
], tostr
[MAX_MULTIBYTE_LENGTH
];
2711 int count
= SPECPDL_INDEX ();
2712 #define COMBINING_NO 0
2713 #define COMBINING_BEFORE 1
2714 #define COMBINING_AFTER 2
2715 #define COMBINING_BOTH (COMBINING_BEFORE | COMBINING_AFTER)
2716 int maybe_byte_combining
= COMBINING_NO
;
2717 int last_changed
= 0;
2718 int multibyte_p
= !NILP (current_buffer
->enable_multibyte_characters
);
2720 validate_region (&start
, &end
);
2721 CHECK_NUMBER (fromchar
);
2722 CHECK_NUMBER (tochar
);
2726 len
= CHAR_STRING (XFASTINT (fromchar
), fromstr
);
2727 if (CHAR_STRING (XFASTINT (tochar
), tostr
) != len
)
2728 error ("Characters in `subst-char-in-region' have different byte-lengths");
2729 if (!ASCII_BYTE_P (*tostr
))
2731 /* If *TOSTR is in the range 0x80..0x9F and TOCHAR is not a
2732 complete multibyte character, it may be combined with the
2733 after bytes. If it is in the range 0xA0..0xFF, it may be
2734 combined with the before and after bytes. */
2735 if (!CHAR_HEAD_P (*tostr
))
2736 maybe_byte_combining
= COMBINING_BOTH
;
2737 else if (BYTES_BY_CHAR_HEAD (*tostr
) > len
)
2738 maybe_byte_combining
= COMBINING_AFTER
;
2744 fromstr
[0] = XFASTINT (fromchar
);
2745 tostr
[0] = XFASTINT (tochar
);
2749 pos_byte
= CHAR_TO_BYTE (pos
);
2750 stop
= CHAR_TO_BYTE (XINT (end
));
2753 /* If we don't want undo, turn off putting stuff on the list.
2754 That's faster than getting rid of things,
2755 and it prevents even the entry for a first change.
2756 Also inhibit locking the file. */
2759 record_unwind_protect (subst_char_in_region_unwind
,
2760 current_buffer
->undo_list
);
2761 current_buffer
->undo_list
= Qt
;
2762 /* Don't do file-locking. */
2763 record_unwind_protect (subst_char_in_region_unwind_1
,
2764 current_buffer
->filename
);
2765 current_buffer
->filename
= Qnil
;
2768 if (pos_byte
< GPT_BYTE
)
2769 stop
= min (stop
, GPT_BYTE
);
2772 int pos_byte_next
= pos_byte
;
2774 if (pos_byte
>= stop
)
2776 if (pos_byte
>= end_byte
) break;
2779 p
= BYTE_POS_ADDR (pos_byte
);
2781 INC_POS (pos_byte_next
);
2784 if (pos_byte_next
- pos_byte
== len
2785 && p
[0] == fromstr
[0]
2787 || (p
[1] == fromstr
[1]
2788 && (len
== 2 || (p
[2] == fromstr
[2]
2789 && (len
== 3 || p
[3] == fromstr
[3]))))))
2794 modify_region (current_buffer
, changed
, XINT (end
));
2796 if (! NILP (noundo
))
2798 if (MODIFF
- 1 == SAVE_MODIFF
)
2800 if (MODIFF
- 1 == current_buffer
->auto_save_modified
)
2801 current_buffer
->auto_save_modified
++;
2805 /* Take care of the case where the new character
2806 combines with neighboring bytes. */
2807 if (maybe_byte_combining
2808 && (maybe_byte_combining
== COMBINING_AFTER
2809 ? (pos_byte_next
< Z_BYTE
2810 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2811 : ((pos_byte_next
< Z_BYTE
2812 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2813 || (pos_byte
> BEG_BYTE
2814 && ! ASCII_BYTE_P (FETCH_BYTE (pos_byte
- 1))))))
2816 Lisp_Object tem
, string
;
2818 struct gcpro gcpro1
;
2820 tem
= current_buffer
->undo_list
;
2823 /* Make a multibyte string containing this single character. */
2824 string
= make_multibyte_string (tostr
, 1, len
);
2825 /* replace_range is less efficient, because it moves the gap,
2826 but it handles combining correctly. */
2827 replace_range (pos
, pos
+ 1, string
,
2829 pos_byte_next
= CHAR_TO_BYTE (pos
);
2830 if (pos_byte_next
> pos_byte
)
2831 /* Before combining happened. We should not increment
2832 POS. So, to cancel the later increment of POS,
2836 INC_POS (pos_byte_next
);
2838 if (! NILP (noundo
))
2839 current_buffer
->undo_list
= tem
;
2846 record_change (pos
, 1);
2847 for (i
= 0; i
< len
; i
++) *p
++ = tostr
[i
];
2849 last_changed
= pos
+ 1;
2851 pos_byte
= pos_byte_next
;
2857 signal_after_change (changed
,
2858 last_changed
- changed
, last_changed
- changed
);
2859 update_compositions (changed
, last_changed
, CHECK_ALL
);
2862 unbind_to (count
, Qnil
);
2867 static Lisp_Object check_translation
P_ ((int, int, int, Lisp_Object
));
2869 /* Helper function for Ftranslate_region_internal.
2871 Check if a character sequence at POS (POS_BYTE) matches an element
2872 of VAL. VAL is a list (([FROM-CHAR ...] . TO) ...). If a matching
2873 element is found, return it. Otherwise return Qnil. */
2876 check_translation (pos
, pos_byte
, end
, val
)
2877 int pos
, pos_byte
, end
;
2880 int buf_size
= 16, buf_used
= 0;
2881 int *buf
= alloca (sizeof (int) * buf_size
);
2883 for (; CONSP (val
); val
= XCDR (val
))
2892 if (! VECTORP (elt
))
2895 if (len
<= end
- pos
)
2897 for (i
= 0; i
< len
; i
++)
2901 unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
2904 if (buf_used
== buf_size
)
2909 newbuf
= alloca (sizeof (int) * buf_size
);
2910 memcpy (newbuf
, buf
, sizeof (int) * buf_used
);
2913 buf
[buf_used
++] = STRING_CHAR_AND_LENGTH (p
, 0, len
);
2916 if (XINT (AREF (elt
, i
)) != buf
[i
])
2927 DEFUN ("translate-region-internal", Ftranslate_region_internal
,
2928 Stranslate_region_internal
, 3, 3, 0,
2929 doc
: /* Internal use only.
2930 From START to END, translate characters according to TABLE.
2931 TABLE is a string or a char-table; the Nth character in it is the
2932 mapping for the character with code N.
2933 It returns the number of characters changed. */)
2937 register Lisp_Object table
;
2939 register unsigned char *tt
; /* Trans table. */
2940 register int nc
; /* New character. */
2941 int cnt
; /* Number of changes made. */
2942 int size
; /* Size of translate table. */
2943 int pos
, pos_byte
, end_pos
;
2944 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
2945 int string_multibyte
;
2948 validate_region (&start
, &end
);
2949 if (CHAR_TABLE_P (table
))
2951 if (! EQ (XCHAR_TABLE (table
)->purpose
, Qtranslation_table
))
2952 error ("Not a translation table");
2958 CHECK_STRING (table
);
2960 if (! multibyte
&& (SCHARS (table
) < SBYTES (table
)))
2961 table
= string_make_unibyte (table
);
2962 string_multibyte
= SCHARS (table
) < SBYTES (table
);
2963 size
= SBYTES (table
);
2968 pos_byte
= CHAR_TO_BYTE (pos
);
2969 end_pos
= XINT (end
);
2970 modify_region (current_buffer
, pos
, end_pos
);
2973 for (; pos
< end_pos
; )
2975 register unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
2976 unsigned char *str
, buf
[MAX_MULTIBYTE_LENGTH
];
2982 oc
= STRING_CHAR_AND_LENGTH (p
, MAX_MULTIBYTE_LENGTH
, len
);
2989 /* Reload as signal_after_change in last iteration may GC. */
2991 if (string_multibyte
)
2993 str
= tt
+ string_char_to_byte (table
, oc
);
2994 nc
= STRING_CHAR_AND_LENGTH (str
, MAX_MULTIBYTE_LENGTH
,
3000 if (! ASCII_BYTE_P (nc
) && multibyte
)
3002 str_len
= BYTE8_STRING (nc
, buf
);
3017 val
= CHAR_TABLE_REF (table
, oc
);
3018 if (CHARACTERP (val
)
3019 && (c
= XINT (val
), CHAR_VALID_P (c
, 0)))
3022 str_len
= CHAR_STRING (nc
, buf
);
3025 else if (VECTORP (val
) || (CONSP (val
)))
3027 /* VAL is [TO_CHAR ...] or (([FROM-CHAR ...] . TO) ...)
3028 where TO is TO-CHAR or [TO-CHAR ...]. */
3033 if (nc
!= oc
&& nc
>= 0)
3035 /* Simple one char to one char translation. */
3040 /* This is less efficient, because it moves the gap,
3041 but it should handle multibyte characters correctly. */
3042 string
= make_multibyte_string (str
, 1, str_len
);
3043 replace_range (pos
, pos
+ 1, string
, 1, 0, 1);
3048 record_change (pos
, 1);
3049 while (str_len
-- > 0)
3051 signal_after_change (pos
, 1, 1);
3052 update_compositions (pos
, pos
+ 1, CHECK_BORDER
);
3062 val
= check_translation (pos
, pos_byte
, end_pos
, val
);
3069 /* VAL is ([FROM-CHAR ...] . TO). */
3070 len
= ASIZE (XCAR (val
));
3080 string
= Fmake_string (make_number (ASIZE (val
)),
3082 for (i
= 1; i
< ASIZE (val
); i
++)
3083 Faset (string
, make_number (i
), AREF (val
, i
));
3087 string
= Fmake_string (make_number (1), val
);
3089 replace_range (pos
, pos
+ len
, string
, 1, 0, 1);
3090 pos_byte
+= SBYTES (string
);
3091 pos
+= SCHARS (string
);
3092 cnt
+= SCHARS (string
);
3093 end_pos
+= SCHARS (string
) - len
;
3101 return make_number (cnt
);
3104 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
3105 doc
: /* Delete the text between point and mark.
3107 When called from a program, expects two arguments,
3108 positions (integers or markers) specifying the stretch to be deleted. */)
3110 Lisp_Object start
, end
;
3112 validate_region (&start
, &end
);
3113 del_range (XINT (start
), XINT (end
));
3117 DEFUN ("delete-and-extract-region", Fdelete_and_extract_region
,
3118 Sdelete_and_extract_region
, 2, 2, 0,
3119 doc
: /* Delete the text between START and END and return it. */)
3121 Lisp_Object start
, end
;
3123 validate_region (&start
, &end
);
3124 if (XINT (start
) == XINT (end
))
3125 return build_string ("");
3126 return del_range_1 (XINT (start
), XINT (end
), 1, 1);
3129 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
3130 doc
: /* Remove restrictions (narrowing) from current buffer.
3131 This allows the buffer's full text to be seen and edited. */)
3134 if (BEG
!= BEGV
|| Z
!= ZV
)
3135 current_buffer
->clip_changed
= 1;
3137 BEGV_BYTE
= BEG_BYTE
;
3138 SET_BUF_ZV_BOTH (current_buffer
, Z
, Z_BYTE
);
3139 /* Changing the buffer bounds invalidates any recorded current column. */
3140 invalidate_current_column ();
3144 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
3145 doc
: /* Restrict editing in this buffer to the current region.
3146 The rest of the text becomes temporarily invisible and untouchable
3147 but is not deleted; if you save the buffer in a file, the invisible
3148 text is included in the file. \\[widen] makes all visible again.
3149 See also `save-restriction'.
3151 When calling from a program, pass two arguments; positions (integers
3152 or markers) bounding the text that should remain visible. */)
3154 register Lisp_Object start
, end
;
3156 CHECK_NUMBER_COERCE_MARKER (start
);
3157 CHECK_NUMBER_COERCE_MARKER (end
);
3159 if (XINT (start
) > XINT (end
))
3162 tem
= start
; start
= end
; end
= tem
;
3165 if (!(BEG
<= XINT (start
) && XINT (start
) <= XINT (end
) && XINT (end
) <= Z
))
3166 args_out_of_range (start
, end
);
3168 if (BEGV
!= XFASTINT (start
) || ZV
!= XFASTINT (end
))
3169 current_buffer
->clip_changed
= 1;
3171 SET_BUF_BEGV (current_buffer
, XFASTINT (start
));
3172 SET_BUF_ZV (current_buffer
, XFASTINT (end
));
3173 if (PT
< XFASTINT (start
))
3174 SET_PT (XFASTINT (start
));
3175 if (PT
> XFASTINT (end
))
3176 SET_PT (XFASTINT (end
));
3177 /* Changing the buffer bounds invalidates any recorded current column. */
3178 invalidate_current_column ();
3183 save_restriction_save ()
3185 if (BEGV
== BEG
&& ZV
== Z
)
3186 /* The common case that the buffer isn't narrowed.
3187 We return just the buffer object, which save_restriction_restore
3188 recognizes as meaning `no restriction'. */
3189 return Fcurrent_buffer ();
3191 /* We have to save a restriction, so return a pair of markers, one
3192 for the beginning and one for the end. */
3194 Lisp_Object beg
, end
;
3196 beg
= buildmark (BEGV
, BEGV_BYTE
);
3197 end
= buildmark (ZV
, ZV_BYTE
);
3199 /* END must move forward if text is inserted at its exact location. */
3200 XMARKER(end
)->insertion_type
= 1;
3202 return Fcons (beg
, end
);
3207 save_restriction_restore (data
)
3211 /* A pair of marks bounding a saved restriction. */
3213 struct Lisp_Marker
*beg
= XMARKER (XCAR (data
));
3214 struct Lisp_Marker
*end
= XMARKER (XCDR (data
));
3215 struct buffer
*buf
= beg
->buffer
; /* END should have the same buffer. */
3217 if (buf
/* Verify marker still points to a buffer. */
3218 && (beg
->charpos
!= BUF_BEGV (buf
) || end
->charpos
!= BUF_ZV (buf
)))
3219 /* The restriction has changed from the saved one, so restore
3220 the saved restriction. */
3222 int pt
= BUF_PT (buf
);
3224 SET_BUF_BEGV_BOTH (buf
, beg
->charpos
, beg
->bytepos
);
3225 SET_BUF_ZV_BOTH (buf
, end
->charpos
, end
->bytepos
);
3227 if (pt
< beg
->charpos
|| pt
> end
->charpos
)
3228 /* The point is outside the new visible range, move it inside. */
3229 SET_BUF_PT_BOTH (buf
,
3230 clip_to_bounds (beg
->charpos
, pt
, end
->charpos
),
3231 clip_to_bounds (beg
->bytepos
, BUF_PT_BYTE (buf
),
3234 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3238 /* A buffer, which means that there was no old restriction. */
3240 struct buffer
*buf
= XBUFFER (data
);
3242 if (buf
/* Verify marker still points to a buffer. */
3243 && (BUF_BEGV (buf
) != BUF_BEG (buf
) || BUF_ZV (buf
) != BUF_Z (buf
)))
3244 /* The buffer has been narrowed, get rid of the narrowing. */
3246 SET_BUF_BEGV_BOTH (buf
, BUF_BEG (buf
), BUF_BEG_BYTE (buf
));
3247 SET_BUF_ZV_BOTH (buf
, BUF_Z (buf
), BUF_Z_BYTE (buf
));
3249 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3256 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
3257 doc
: /* Execute BODY, saving and restoring current buffer's restrictions.
3258 The buffer's restrictions make parts of the beginning and end invisible.
3259 (They are set up with `narrow-to-region' and eliminated with `widen'.)
3260 This special form, `save-restriction', saves the current buffer's restrictions
3261 when it is entered, and restores them when it is exited.
3262 So any `narrow-to-region' within BODY lasts only until the end of the form.
3263 The old restrictions settings are restored
3264 even in case of abnormal exit (throw or error).
3266 The value returned is the value of the last form in BODY.
3268 Note: if you are using both `save-excursion' and `save-restriction',
3269 use `save-excursion' outermost:
3270 (save-excursion (save-restriction ...))
3272 usage: (save-restriction &rest BODY) */)
3276 register Lisp_Object val
;
3277 int count
= SPECPDL_INDEX ();
3279 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
3280 val
= Fprogn (body
);
3281 return unbind_to (count
, val
);
3284 /* Buffer for the most recent text displayed by Fmessage_box. */
3285 static char *message_text
;
3287 /* Allocated length of that buffer. */
3288 static int message_length
;
3290 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
3291 doc
: /* Print a one-line message at the bottom of the screen.
3292 The message also goes into the `*Messages*' buffer.
3293 \(In keyboard macros, that's all it does.)
3295 The first argument is a format control string, and the rest are data
3296 to be formatted under control of the string. See `format' for details.
3298 If the first argument is nil or the empty string, the function clears
3299 any existing message; this lets the minibuffer contents show. See
3300 also `current-message'.
3302 usage: (message FORMAT-STRING &rest ARGS) */)
3308 || (STRINGP (args
[0])
3309 && SBYTES (args
[0]) == 0))
3316 register Lisp_Object val
;
3317 val
= Fformat (nargs
, args
);
3318 message3 (val
, SBYTES (val
), STRING_MULTIBYTE (val
));
3323 DEFUN ("message-box", Fmessage_box
, Smessage_box
, 1, MANY
, 0,
3324 doc
: /* Display a message, in a dialog box if possible.
3325 If a dialog box is not available, use the echo area.
3326 The first argument is a format control string, and the rest are data
3327 to be formatted under control of the string. See `format' for details.
3329 If the first argument is nil or the empty string, clear any existing
3330 message; let the minibuffer contents show.
3332 usage: (message-box FORMAT-STRING &rest ARGS) */)
3344 register Lisp_Object val
;
3345 val
= Fformat (nargs
, args
);
3347 /* The MS-DOS frames support popup menus even though they are
3348 not FRAME_WINDOW_P. */
3349 if (FRAME_WINDOW_P (XFRAME (selected_frame
))
3350 || FRAME_MSDOS_P (XFRAME (selected_frame
)))
3352 Lisp_Object pane
, menu
, obj
;
3353 struct gcpro gcpro1
;
3354 pane
= Fcons (Fcons (build_string ("OK"), Qt
), Qnil
);
3356 menu
= Fcons (val
, pane
);
3357 obj
= Fx_popup_dialog (Qt
, menu
, Qt
);
3361 #endif /* HAVE_MENUS */
3362 /* Copy the data so that it won't move when we GC. */
3365 message_text
= (char *)xmalloc (80);
3366 message_length
= 80;
3368 if (SBYTES (val
) > message_length
)
3370 message_length
= SBYTES (val
);
3371 message_text
= (char *)xrealloc (message_text
, message_length
);
3373 bcopy (SDATA (val
), message_text
, SBYTES (val
));
3374 message2 (message_text
, SBYTES (val
),
3375 STRING_MULTIBYTE (val
));
3380 extern Lisp_Object last_nonmenu_event
;
3383 DEFUN ("message-or-box", Fmessage_or_box
, Smessage_or_box
, 1, MANY
, 0,
3384 doc
: /* Display a message in a dialog box or in the echo area.
3385 If this command was invoked with the mouse, use a dialog box if
3386 `use-dialog-box' is non-nil.
3387 Otherwise, use the echo area.
3388 The first argument is a format control string, and the rest are data
3389 to be formatted under control of the string. See `format' for details.
3391 If the first argument is nil or the empty string, clear any existing
3392 message; let the minibuffer contents show.
3394 usage: (message-or-box FORMAT-STRING &rest ARGS) */)
3400 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3402 return Fmessage_box (nargs
, args
);
3404 return Fmessage (nargs
, args
);
3407 DEFUN ("current-message", Fcurrent_message
, Scurrent_message
, 0, 0, 0,
3408 doc
: /* Return the string currently displayed in the echo area, or nil if none. */)
3411 return current_message ();
3415 DEFUN ("propertize", Fpropertize
, Spropertize
, 1, MANY
, 0,
3416 doc
: /* Return a copy of STRING with text properties added.
3417 First argument is the string to copy.
3418 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
3419 properties to add to the result.
3420 usage: (propertize STRING &rest PROPERTIES) */)
3425 Lisp_Object properties
, string
;
3426 struct gcpro gcpro1
, gcpro2
;
3429 /* Number of args must be odd. */
3430 if ((nargs
& 1) == 0 || nargs
< 1)
3431 error ("Wrong number of arguments");
3433 properties
= string
= Qnil
;
3434 GCPRO2 (properties
, string
);
3436 /* First argument must be a string. */
3437 CHECK_STRING (args
[0]);
3438 string
= Fcopy_sequence (args
[0]);
3440 for (i
= 1; i
< nargs
; i
+= 2)
3441 properties
= Fcons (args
[i
], Fcons (args
[i
+ 1], properties
));
3443 Fadd_text_properties (make_number (0),
3444 make_number (SCHARS (string
)),
3445 properties
, string
);
3446 RETURN_UNGCPRO (string
);
3450 /* Number of bytes that STRING will occupy when put into the result.
3451 MULTIBYTE is nonzero if the result should be multibyte. */
3453 #define CONVERTED_BYTE_SIZE(MULTIBYTE, STRING) \
3454 (((MULTIBYTE) && ! STRING_MULTIBYTE (STRING)) \
3455 ? count_size_as_multibyte (SDATA (STRING), SBYTES (STRING)) \
3458 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
3459 doc
: /* Format a string out of a format-string and arguments.
3460 The first argument is a format control string.
3461 The other arguments are substituted into it to make the result, a string.
3462 It may contain %-sequences meaning to substitute the next argument.
3463 %s means print a string argument. Actually, prints any object, with `princ'.
3464 %d means print as number in decimal (%o octal, %x hex).
3465 %X is like %x, but uses upper case.
3466 %e means print a number in exponential notation.
3467 %f means print a number in decimal-point notation.
3468 %g means print a number in exponential notation
3469 or decimal-point notation, whichever uses fewer characters.
3470 %c means print a number as a single character.
3471 %S means print any object as an s-expression (using `prin1').
3472 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.
3473 Use %% to put a single % into the output.
3475 The basic structure of a %-sequence is
3476 % <flags> <width> <precision> character
3477 where flags is [- #0]+, width is [0-9]+, and precision is .[0-9]+
3479 usage: (format STRING &rest OBJECTS) */)
3482 register Lisp_Object
*args
;
3484 register int n
; /* The number of the next arg to substitute */
3485 register int total
; /* An estimate of the final length */
3487 register unsigned char *format
, *end
, *format_start
;
3489 /* Nonzero if the output should be a multibyte string,
3490 which is true if any of the inputs is one. */
3492 /* When we make a multibyte string, we must pay attention to the
3493 byte combining problem, i.e., a byte may be combined with a
3494 multibyte charcter of the previous string. This flag tells if we
3495 must consider such a situation or not. */
3496 int maybe_combine_byte
;
3497 unsigned char *this_format
;
3498 /* Precision for each spec, or -1, a flag value meaning no precision
3499 was given in that spec. Element 0, corresonding to the format
3500 string itself, will not be used. Element NARGS, corresponding to
3501 no argument, *will* be assigned to in the case that a `%' and `.'
3502 occur after the final format specifier. */
3503 int *precision
= (int *) (alloca((nargs
+ 1) * sizeof (int)));
3506 int arg_intervals
= 0;
3509 /* discarded[I] is 1 if byte I of the format
3510 string was not copied into the output.
3511 It is 2 if byte I was not the first byte of its character. */
3512 char *discarded
= 0;
3514 /* Each element records, for one argument,
3515 the start and end bytepos in the output string,
3516 and whether the argument is a string with intervals.
3517 info[0] is unused. Unused elements have -1 for start. */
3520 int start
, end
, intervals
;
3523 /* It should not be necessary to GCPRO ARGS, because
3524 the caller in the interpreter should take care of that. */
3526 /* Try to determine whether the result should be multibyte.
3527 This is not always right; sometimes the result needs to be multibyte
3528 because of an object that we will pass through prin1,
3529 and in that case, we won't know it here. */
3530 for (n
= 0; n
< nargs
; n
++)
3532 if (STRINGP (args
[n
]) && STRING_MULTIBYTE (args
[n
]))
3534 /* Piggyback on this loop to initialize precision[N]. */
3537 precision
[nargs
] = -1;
3539 CHECK_STRING (args
[0]);
3540 /* We may have to change "%S" to "%s". */
3541 args
[0] = Fcopy_sequence (args
[0]);
3543 /* GC should never happen here, so abort if it does. */
3546 /* If we start out planning a unibyte result,
3547 then discover it has to be multibyte, we jump back to retry.
3548 That can only happen from the first large while loop below. */
3551 format
= SDATA (args
[0]);
3552 format_start
= format
;
3553 end
= format
+ SBYTES (args
[0]);
3556 /* Make room in result for all the non-%-codes in the control string. */
3557 total
= 5 + CONVERTED_BYTE_SIZE (multibyte
, args
[0]) + 1;
3559 /* Allocate the info and discarded tables. */
3561 int nbytes
= (nargs
+1) * sizeof *info
;
3564 info
= (struct info
*) alloca (nbytes
);
3565 bzero (info
, nbytes
);
3566 for (i
= 0; i
<= nargs
; i
++)
3569 SAFE_ALLOCA (discarded
, char *, SBYTES (args
[0]));
3570 bzero (discarded
, SBYTES (args
[0]));
3573 /* Add to TOTAL enough space to hold the converted arguments. */
3576 while (format
!= end
)
3577 if (*format
++ == '%')
3580 int actual_width
= 0;
3581 unsigned char *this_format_start
= format
- 1;
3582 int field_width
= 0;
3584 /* General format specifications look like
3586 '%' [flags] [field-width] [precision] format
3591 field-width ::= [0-9]+
3592 precision ::= '.' [0-9]*
3594 If a field-width is specified, it specifies to which width
3595 the output should be padded with blanks, iff the output
3596 string is shorter than field-width.
3598 If precision is specified, it specifies the number of
3599 digits to print after the '.' for floats, or the max.
3600 number of chars to print from a string. */
3602 while (format
!= end
3603 && (*format
== '-' || *format
== '0' || *format
== '#'
3604 || * format
== ' '))
3607 if (*format
>= '0' && *format
<= '9')
3609 for (field_width
= 0; *format
>= '0' && *format
<= '9'; ++format
)
3610 field_width
= 10 * field_width
+ *format
- '0';
3613 /* N is not incremented for another few lines below, so refer to
3614 element N+1 (which might be precision[NARGS]). */
3618 for (precision
[n
+1] = 0; *format
>= '0' && *format
<= '9'; ++format
)
3619 precision
[n
+1] = 10 * precision
[n
+1] + *format
- '0';
3622 if (format
- this_format_start
+ 1 > longest_format
)
3623 longest_format
= format
- this_format_start
+ 1;
3626 error ("Format string ends in middle of format specifier");
3629 else if (++n
>= nargs
)
3630 error ("Not enough arguments for format string");
3631 else if (*format
== 'S')
3633 /* For `S', prin1 the argument and then treat like a string. */
3634 register Lisp_Object tem
;
3635 tem
= Fprin1_to_string (args
[n
], Qnil
);
3636 if (STRING_MULTIBYTE (tem
) && ! multibyte
)
3642 /* If we restart the loop, we should not come here again
3643 because args[n] is now a string and calling
3644 Fprin1_to_string on it produces superflous double
3645 quotes. So, change "%S" to "%s" now. */
3649 else if (SYMBOLP (args
[n
]))
3651 args
[n
] = SYMBOL_NAME (args
[n
]);
3652 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
3659 else if (STRINGP (args
[n
]))
3662 if (*format
!= 's' && *format
!= 'S')
3663 error ("Format specifier doesn't match argument type");
3664 /* In the case (PRECISION[N] > 0), THISSIZE may not need
3665 to be as large as is calculated here. Easy check for
3666 the case PRECISION = 0. */
3667 thissize
= precision
[n
] ? CONVERTED_BYTE_SIZE (multibyte
, args
[n
]) : 0;
3668 actual_width
= lisp_string_width (args
[n
], -1, NULL
, NULL
);
3670 /* Would get MPV otherwise, since Lisp_Int's `point' to low memory. */
3671 else if (INTEGERP (args
[n
]) && *format
!= 's')
3673 /* The following loop assumes the Lisp type indicates
3674 the proper way to pass the argument.
3675 So make sure we have a flonum if the argument should
3677 if (*format
== 'e' || *format
== 'f' || *format
== 'g')
3678 args
[n
] = Ffloat (args
[n
]);
3680 if (*format
!= 'd' && *format
!= 'o' && *format
!= 'x'
3681 && *format
!= 'i' && *format
!= 'X' && *format
!= 'c')
3682 error ("Invalid format operation %%%c", *format
);
3687 if (! ASCII_CHAR_P (XINT (args
[n
]))
3688 /* Note: No one can remeber why we have to treat
3689 the character 0 as a multibyte character here.
3690 But, until it causes a real problem, let's
3692 || XINT (args
[n
]) == 0)
3699 args
[n
] = Fchar_to_string (args
[n
]);
3700 thissize
= SBYTES (args
[n
]);
3702 else if (! ASCII_BYTE_P (XINT (args
[n
])) && multibyte
)
3705 = Fchar_to_string (Funibyte_char_to_multibyte (args
[n
]));
3706 thissize
= SBYTES (args
[n
]);
3710 else if (FLOATP (args
[n
]) && *format
!= 's')
3712 if (! (*format
== 'e' || *format
== 'f' || *format
== 'g'))
3714 if (*format
!= 'd' && *format
!= 'o' && *format
!= 'x'
3715 && *format
!= 'i' && *format
!= 'X' && *format
!= 'c')
3716 error ("Invalid format operation %%%c", *format
);
3717 args
[n
] = Ftruncate (args
[n
], Qnil
);
3720 /* Note that we're using sprintf to print floats,
3721 so we have to take into account what that function
3723 /* Filter out flag value of -1. */
3724 thissize
= (MAX_10_EXP
+ 100
3725 + (precision
[n
] > 0 ? precision
[n
] : 0));
3729 /* Anything but a string, convert to a string using princ. */
3730 register Lisp_Object tem
;
3731 tem
= Fprin1_to_string (args
[n
], Qt
);
3732 if (STRING_MULTIBYTE (tem
) && ! multibyte
)
3741 thissize
+= max (0, field_width
- actual_width
);
3742 total
+= thissize
+ 4;
3747 /* Now we can no longer jump to retry.
3748 TOTAL and LONGEST_FORMAT are known for certain. */
3750 this_format
= (unsigned char *) alloca (longest_format
+ 1);
3752 /* Allocate the space for the result.
3753 Note that TOTAL is an overestimate. */
3754 SAFE_ALLOCA (buf
, char *, total
);
3760 /* Scan the format and store result in BUF. */
3761 format
= SDATA (args
[0]);
3762 format_start
= format
;
3763 end
= format
+ SBYTES (args
[0]);
3764 maybe_combine_byte
= 0;
3765 while (format
!= end
)
3771 unsigned char *this_format_start
= format
;
3773 discarded
[format
- format_start
] = 1;
3776 while (index("-0# ", *format
))
3782 discarded
[format
- format_start
] = 1;
3786 minlen
= atoi (format
);
3788 while ((*format
>= '0' && *format
<= '9') || *format
== '.')
3790 discarded
[format
- format_start
] = 1;
3794 if (*format
++ == '%')
3803 discarded
[format
- format_start
- 1] = 1;
3804 info
[n
].start
= nchars
;
3806 if (STRINGP (args
[n
]))
3808 /* handle case (precision[n] >= 0) */
3811 int nbytes
, start
, end
;
3814 /* lisp_string_width ignores a precision of 0, but GNU
3815 libc functions print 0 characters when the precision
3816 is 0. Imitate libc behavior here. Changing
3817 lisp_string_width is the right thing, and will be
3818 done, but meanwhile we work with it. */
3820 if (precision
[n
] == 0)
3821 width
= nchars_string
= nbytes
= 0;
3822 else if (precision
[n
] > 0)
3823 width
= lisp_string_width (args
[n
], precision
[n
], &nchars_string
, &nbytes
);
3825 { /* no precision spec given for this argument */
3826 width
= lisp_string_width (args
[n
], -1, NULL
, NULL
);
3827 nbytes
= SBYTES (args
[n
]);
3828 nchars_string
= SCHARS (args
[n
]);
3831 /* If spec requires it, pad on right with spaces. */
3832 padding
= minlen
- width
;
3834 while (padding
-- > 0)
3840 info
[n
].start
= start
= nchars
;
3841 nchars
+= nchars_string
;
3846 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3847 && STRING_MULTIBYTE (args
[n
])
3848 && !CHAR_HEAD_P (SREF (args
[n
], 0)))
3849 maybe_combine_byte
= 1;
3851 p
+= copy_text (SDATA (args
[n
]), p
,
3853 STRING_MULTIBYTE (args
[n
]), multibyte
);
3855 info
[n
].end
= nchars
;
3858 while (padding
-- > 0)
3864 /* If this argument has text properties, record where
3865 in the result string it appears. */
3866 if (STRING_INTERVALS (args
[n
]))
3867 info
[n
].intervals
= arg_intervals
= 1;
3869 else if (INTEGERP (args
[n
]) || FLOATP (args
[n
]))
3873 bcopy (this_format_start
, this_format
,
3874 format
- this_format_start
);
3875 this_format
[format
- this_format_start
] = 0;
3877 if (INTEGERP (args
[n
]))
3878 sprintf (p
, this_format
, XINT (args
[n
]));
3880 sprintf (p
, this_format
, XFLOAT_DATA (args
[n
]));
3884 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3885 && !CHAR_HEAD_P (*((unsigned char *) p
)))
3886 maybe_combine_byte
= 1;
3887 this_nchars
= strlen (p
);
3889 p
+= str_to_multibyte (p
, buf
+ total
- 1 - p
, this_nchars
);
3892 nchars
+= this_nchars
;
3893 info
[n
].end
= nchars
;
3897 else if (STRING_MULTIBYTE (args
[0]))
3899 /* Copy a whole multibyte character. */
3902 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3903 && !CHAR_HEAD_P (*format
))
3904 maybe_combine_byte
= 1;
3906 while (! CHAR_HEAD_P (*format
))
3908 discarded
[format
- format_start
] = 2;
3915 /* Convert a single-byte character to multibyte. */
3916 int len
= copy_text (format
, p
, 1, 0, 1);
3923 *p
++ = *format
++, nchars
++;
3926 if (p
> buf
+ total
)
3929 if (maybe_combine_byte
)
3930 nchars
= multibyte_chars_in_text (buf
, p
- buf
);
3931 val
= make_specified_string (buf
, nchars
, p
- buf
, multibyte
);
3933 /* If we allocated BUF with malloc, free it too. */
3936 /* If the format string has text properties, or any of the string
3937 arguments has text properties, set up text properties of the
3940 if (STRING_INTERVALS (args
[0]) || arg_intervals
)
3942 Lisp_Object len
, new_len
, props
;
3943 struct gcpro gcpro1
;
3945 /* Add text properties from the format string. */
3946 len
= make_number (SCHARS (args
[0]));
3947 props
= text_property_list (args
[0], make_number (0), len
, Qnil
);
3952 int bytepos
= 0, position
= 0, translated
= 0, argn
= 1;
3955 /* Adjust the bounds of each text property
3956 to the proper start and end in the output string. */
3958 /* Put the positions in PROPS in increasing order, so that
3959 we can do (effectively) one scan through the position
3960 space of the format string. */
3961 props
= Fnreverse (props
);
3963 /* BYTEPOS is the byte position in the format string,
3964 POSITION is the untranslated char position in it,
3965 TRANSLATED is the translated char position in BUF,
3966 and ARGN is the number of the next arg we will come to. */
3967 for (list
= props
; CONSP (list
); list
= XCDR (list
))
3974 /* First adjust the property start position. */
3975 pos
= XINT (XCAR (item
));
3977 /* Advance BYTEPOS, POSITION, TRANSLATED and ARGN
3978 up to this position. */
3979 for (; position
< pos
; bytepos
++)
3981 if (! discarded
[bytepos
])
3982 position
++, translated
++;
3983 else if (discarded
[bytepos
] == 1)
3986 if (translated
== info
[argn
].start
)
3988 translated
+= info
[argn
].end
- info
[argn
].start
;
3994 XSETCAR (item
, make_number (translated
));
3996 /* Likewise adjust the property end position. */
3997 pos
= XINT (XCAR (XCDR (item
)));
3999 for (; bytepos
< pos
; bytepos
++)
4001 if (! discarded
[bytepos
])
4002 position
++, translated
++;
4003 else if (discarded
[bytepos
] == 1)
4006 if (translated
== info
[argn
].start
)
4008 translated
+= info
[argn
].end
- info
[argn
].start
;
4014 XSETCAR (XCDR (item
), make_number (translated
));
4017 add_text_properties_from_list (val
, props
, make_number (0));
4020 /* Add text properties from arguments. */
4022 for (n
= 1; n
< nargs
; ++n
)
4023 if (info
[n
].intervals
)
4025 len
= make_number (SCHARS (args
[n
]));
4026 new_len
= make_number (info
[n
].end
- info
[n
].start
);
4027 props
= text_property_list (args
[n
], make_number (0), len
, Qnil
);
4028 extend_property_ranges (props
, len
, new_len
);
4029 /* If successive arguments have properites, be sure that
4030 the value of `composition' property be the copy. */
4031 if (n
> 1 && info
[n
- 1].end
)
4032 make_composition_value_copy (props
);
4033 add_text_properties_from_list (val
, props
,
4034 make_number (info
[n
].start
));
4044 format2 (string1
, arg0
, arg1
)
4046 Lisp_Object arg0
, arg1
;
4048 Lisp_Object args
[3];
4049 args
[0] = build_string (string1
);
4052 return Fformat (3, args
);
4055 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
4056 doc
: /* Return t if two characters match, optionally ignoring case.
4057 Both arguments must be characters (i.e. integers).
4058 Case is ignored if `case-fold-search' is non-nil in the current buffer. */)
4060 register Lisp_Object c1
, c2
;
4066 if (XINT (c1
) == XINT (c2
))
4068 if (NILP (current_buffer
->case_fold_search
))
4071 /* Do these in separate statements,
4072 then compare the variables.
4073 because of the way DOWNCASE uses temp variables. */
4075 if (NILP (current_buffer
->enable_multibyte_characters
)
4076 && ! ASCII_CHAR_P (i1
))
4078 MAKE_CHAR_MULTIBYTE (i1
);
4081 if (NILP (current_buffer
->enable_multibyte_characters
)
4082 && ! ASCII_CHAR_P (i2
))
4084 MAKE_CHAR_MULTIBYTE (i2
);
4088 return (i1
== i2
? Qt
: Qnil
);
4091 /* Transpose the markers in two regions of the current buffer, and
4092 adjust the ones between them if necessary (i.e.: if the regions
4095 START1, END1 are the character positions of the first region.
4096 START1_BYTE, END1_BYTE are the byte positions.
4097 START2, END2 are the character positions of the second region.
4098 START2_BYTE, END2_BYTE are the byte positions.
4100 Traverses the entire marker list of the buffer to do so, adding an
4101 appropriate amount to some, subtracting from some, and leaving the
4102 rest untouched. Most of this is copied from adjust_markers in insdel.c.
4104 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
4107 transpose_markers (start1
, end1
, start2
, end2
,
4108 start1_byte
, end1_byte
, start2_byte
, end2_byte
)
4109 register int start1
, end1
, start2
, end2
;
4110 register int start1_byte
, end1_byte
, start2_byte
, end2_byte
;
4112 register int amt1
, amt1_byte
, amt2
, amt2_byte
, diff
, diff_byte
, mpos
;
4113 register struct Lisp_Marker
*marker
;
4115 /* Update point as if it were a marker. */
4119 TEMP_SET_PT_BOTH (PT
+ (end2
- end1
),
4120 PT_BYTE
+ (end2_byte
- end1_byte
));
4121 else if (PT
< start2
)
4122 TEMP_SET_PT_BOTH (PT
+ (end2
- start2
) - (end1
- start1
),
4123 (PT_BYTE
+ (end2_byte
- start2_byte
)
4124 - (end1_byte
- start1_byte
)));
4126 TEMP_SET_PT_BOTH (PT
- (start2
- start1
),
4127 PT_BYTE
- (start2_byte
- start1_byte
));
4129 /* We used to adjust the endpoints here to account for the gap, but that
4130 isn't good enough. Even if we assume the caller has tried to move the
4131 gap out of our way, it might still be at start1 exactly, for example;
4132 and that places it `inside' the interval, for our purposes. The amount
4133 of adjustment is nontrivial if there's a `denormalized' marker whose
4134 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
4135 the dirty work to Fmarker_position, below. */
4137 /* The difference between the region's lengths */
4138 diff
= (end2
- start2
) - (end1
- start1
);
4139 diff_byte
= (end2_byte
- start2_byte
) - (end1_byte
- start1_byte
);
4141 /* For shifting each marker in a region by the length of the other
4142 region plus the distance between the regions. */
4143 amt1
= (end2
- start2
) + (start2
- end1
);
4144 amt2
= (end1
- start1
) + (start2
- end1
);
4145 amt1_byte
= (end2_byte
- start2_byte
) + (start2_byte
- end1_byte
);
4146 amt2_byte
= (end1_byte
- start1_byte
) + (start2_byte
- end1_byte
);
4148 for (marker
= BUF_MARKERS (current_buffer
); marker
; marker
= marker
->next
)
4150 mpos
= marker
->bytepos
;
4151 if (mpos
>= start1_byte
&& mpos
< end2_byte
)
4153 if (mpos
< end1_byte
)
4155 else if (mpos
< start2_byte
)
4159 marker
->bytepos
= mpos
;
4161 mpos
= marker
->charpos
;
4162 if (mpos
>= start1
&& mpos
< end2
)
4166 else if (mpos
< start2
)
4171 marker
->charpos
= mpos
;
4175 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
4176 doc
: /* Transpose region STARTR1 to ENDR1 with STARTR2 to ENDR2.
4177 The regions may not be overlapping, because the size of the buffer is
4178 never changed in a transposition.
4180 Optional fifth arg LEAVE-MARKERS, if non-nil, means don't update
4181 any markers that happen to be located in the regions.
4183 Transposing beyond buffer boundaries is an error. */)
4184 (startr1
, endr1
, startr2
, endr2
, leave_markers
)
4185 Lisp_Object startr1
, endr1
, startr2
, endr2
, leave_markers
;
4187 register int start1
, end1
, start2
, end2
;
4188 int start1_byte
, start2_byte
, len1_byte
, len2_byte
;
4189 int gap
, len1
, len_mid
, len2
;
4190 unsigned char *start1_addr
, *start2_addr
, *temp
;
4192 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
;
4193 cur_intv
= BUF_INTERVALS (current_buffer
);
4195 validate_region (&startr1
, &endr1
);
4196 validate_region (&startr2
, &endr2
);
4198 start1
= XFASTINT (startr1
);
4199 end1
= XFASTINT (endr1
);
4200 start2
= XFASTINT (startr2
);
4201 end2
= XFASTINT (endr2
);
4204 /* Swap the regions if they're reversed. */
4207 register int glumph
= start1
;
4215 len1
= end1
- start1
;
4216 len2
= end2
- start2
;
4219 error ("Transposed regions overlap");
4220 else if (start1
== end1
|| start2
== end2
)
4221 error ("Transposed region has length 0");
4223 /* The possibilities are:
4224 1. Adjacent (contiguous) regions, or separate but equal regions
4225 (no, really equal, in this case!), or
4226 2. Separate regions of unequal size.
4228 The worst case is usually No. 2. It means that (aside from
4229 potential need for getting the gap out of the way), there also
4230 needs to be a shifting of the text between the two regions. So
4231 if they are spread far apart, we are that much slower... sigh. */
4233 /* It must be pointed out that the really studly thing to do would
4234 be not to move the gap at all, but to leave it in place and work
4235 around it if necessary. This would be extremely efficient,
4236 especially considering that people are likely to do
4237 transpositions near where they are working interactively, which
4238 is exactly where the gap would be found. However, such code
4239 would be much harder to write and to read. So, if you are
4240 reading this comment and are feeling squirrely, by all means have
4241 a go! I just didn't feel like doing it, so I will simply move
4242 the gap the minimum distance to get it out of the way, and then
4243 deal with an unbroken array. */
4245 /* Make sure the gap won't interfere, by moving it out of the text
4246 we will operate on. */
4247 if (start1
< gap
&& gap
< end2
)
4249 if (gap
- start1
< end2
- gap
)
4255 start1_byte
= CHAR_TO_BYTE (start1
);
4256 start2_byte
= CHAR_TO_BYTE (start2
);
4257 len1_byte
= CHAR_TO_BYTE (end1
) - start1_byte
;
4258 len2_byte
= CHAR_TO_BYTE (end2
) - start2_byte
;
4260 #ifdef BYTE_COMBINING_DEBUG
4263 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4264 len2_byte
, start1
, start1_byte
)
4265 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4266 len1_byte
, end2
, start2_byte
+ len2_byte
)
4267 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4268 len1_byte
, end2
, start2_byte
+ len2_byte
))
4273 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4274 len2_byte
, start1
, start1_byte
)
4275 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4276 len1_byte
, start2
, start2_byte
)
4277 || count_combining_after (BYTE_POS_ADDR (start2_byte
),
4278 len2_byte
, end1
, start1_byte
+ len1_byte
)
4279 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4280 len1_byte
, end2
, start2_byte
+ len2_byte
))
4285 /* Hmmm... how about checking to see if the gap is large
4286 enough to use as the temporary storage? That would avoid an
4287 allocation... interesting. Later, don't fool with it now. */
4289 /* Working without memmove, for portability (sigh), so must be
4290 careful of overlapping subsections of the array... */
4292 if (end1
== start2
) /* adjacent regions */
4294 modify_region (current_buffer
, start1
, end2
);
4295 record_change (start1
, len1
+ len2
);
4297 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4298 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4299 Fset_text_properties (make_number (start1
), make_number (end2
),
4302 /* First region smaller than second. */
4303 if (len1_byte
< len2_byte
)
4307 SAFE_ALLOCA (temp
, unsigned char *, len2_byte
);
4309 /* Don't precompute these addresses. We have to compute them
4310 at the last minute, because the relocating allocator might
4311 have moved the buffer around during the xmalloc. */
4312 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4313 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4315 bcopy (start2_addr
, temp
, len2_byte
);
4316 bcopy (start1_addr
, start1_addr
+ len2_byte
, len1_byte
);
4317 bcopy (temp
, start1_addr
, len2_byte
);
4321 /* First region not smaller than second. */
4325 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4326 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4327 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4328 bcopy (start1_addr
, temp
, len1_byte
);
4329 bcopy (start2_addr
, start1_addr
, len2_byte
);
4330 bcopy (temp
, start1_addr
+ len2_byte
, len1_byte
);
4333 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
4334 len1
, current_buffer
, 0);
4335 graft_intervals_into_buffer (tmp_interval2
, start1
,
4336 len2
, current_buffer
, 0);
4337 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4338 update_compositions (start1
+ len2
, end2
, CHECK_TAIL
);
4340 /* Non-adjacent regions, because end1 != start2, bleagh... */
4343 len_mid
= start2_byte
- (start1_byte
+ len1_byte
);
4345 if (len1_byte
== len2_byte
)
4346 /* Regions are same size, though, how nice. */
4350 modify_region (current_buffer
, start1
, end1
);
4351 modify_region (current_buffer
, start2
, end2
);
4352 record_change (start1
, len1
);
4353 record_change (start2
, len2
);
4354 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4355 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4356 Fset_text_properties (make_number (start1
), make_number (end1
),
4358 Fset_text_properties (make_number (start2
), make_number (end2
),
4361 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4362 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4363 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4364 bcopy (start1_addr
, temp
, len1_byte
);
4365 bcopy (start2_addr
, start1_addr
, len2_byte
);
4366 bcopy (temp
, start2_addr
, len1_byte
);
4369 graft_intervals_into_buffer (tmp_interval1
, start2
,
4370 len1
, current_buffer
, 0);
4371 graft_intervals_into_buffer (tmp_interval2
, start1
,
4372 len2
, current_buffer
, 0);
4375 else if (len1_byte
< len2_byte
) /* Second region larger than first */
4376 /* Non-adjacent & unequal size, area between must also be shifted. */
4380 modify_region (current_buffer
, start1
, end2
);
4381 record_change (start1
, (end2
- start1
));
4382 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4383 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4384 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4385 Fset_text_properties (make_number (start1
), make_number (end2
),
4388 /* holds region 2 */
4389 SAFE_ALLOCA (temp
, unsigned char *, len2_byte
);
4390 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4391 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4392 bcopy (start2_addr
, temp
, len2_byte
);
4393 bcopy (start1_addr
, start1_addr
+ len_mid
+ len2_byte
, len1_byte
);
4394 safe_bcopy (start1_addr
+ len1_byte
, start1_addr
+ len2_byte
, len_mid
);
4395 bcopy (temp
, start1_addr
, len2_byte
);
4398 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4399 len1
, current_buffer
, 0);
4400 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4401 len_mid
, current_buffer
, 0);
4402 graft_intervals_into_buffer (tmp_interval2
, start1
,
4403 len2
, current_buffer
, 0);
4406 /* Second region smaller than first. */
4410 record_change (start1
, (end2
- start1
));
4411 modify_region (current_buffer
, start1
, end2
);
4413 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4414 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4415 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4416 Fset_text_properties (make_number (start1
), make_number (end2
),
4419 /* holds region 1 */
4420 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4421 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4422 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4423 bcopy (start1_addr
, temp
, len1_byte
);
4424 bcopy (start2_addr
, start1_addr
, len2_byte
);
4425 bcopy (start1_addr
+ len1_byte
, start1_addr
+ len2_byte
, len_mid
);
4426 bcopy (temp
, start1_addr
+ len2_byte
+ len_mid
, len1_byte
);
4429 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4430 len1
, current_buffer
, 0);
4431 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4432 len_mid
, current_buffer
, 0);
4433 graft_intervals_into_buffer (tmp_interval2
, start1
,
4434 len2
, current_buffer
, 0);
4437 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4438 update_compositions (end2
- len1
, end2
, CHECK_BORDER
);
4441 /* When doing multiple transpositions, it might be nice
4442 to optimize this. Perhaps the markers in any one buffer
4443 should be organized in some sorted data tree. */
4444 if (NILP (leave_markers
))
4446 transpose_markers (start1
, end1
, start2
, end2
,
4447 start1_byte
, start1_byte
+ len1_byte
,
4448 start2_byte
, start2_byte
+ len2_byte
);
4449 fix_start_end_in_overlays (start1
, end2
);
4461 Qbuffer_access_fontify_functions
4462 = intern ("buffer-access-fontify-functions");
4463 staticpro (&Qbuffer_access_fontify_functions
);
4465 DEFVAR_LISP ("inhibit-field-text-motion", &Vinhibit_field_text_motion
,
4466 doc
: /* Non-nil means text motion commands don't notice fields. */);
4467 Vinhibit_field_text_motion
= Qnil
;
4469 DEFVAR_LISP ("buffer-access-fontify-functions",
4470 &Vbuffer_access_fontify_functions
,
4471 doc
: /* List of functions called by `buffer-substring' to fontify if necessary.
4472 Each function is called with two arguments which specify the range
4473 of the buffer being accessed. */);
4474 Vbuffer_access_fontify_functions
= Qnil
;
4478 extern Lisp_Object Vprin1_to_string_buffer
;
4479 obuf
= Fcurrent_buffer ();
4480 /* Do this here, because init_buffer_once is too early--it won't work. */
4481 Fset_buffer (Vprin1_to_string_buffer
);
4482 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
4483 Fset (Fmake_local_variable (intern ("buffer-access-fontify-functions")),
4488 DEFVAR_LISP ("buffer-access-fontified-property",
4489 &Vbuffer_access_fontified_property
,
4490 doc
: /* Property which (if non-nil) indicates text has been fontified.
4491 `buffer-substring' need not call the `buffer-access-fontify-functions'
4492 functions if all the text being accessed has this property. */);
4493 Vbuffer_access_fontified_property
= Qnil
;
4495 DEFVAR_LISP ("system-name", &Vsystem_name
,
4496 doc
: /* The name of the machine Emacs is running on. */);
4498 DEFVAR_LISP ("user-full-name", &Vuser_full_name
,
4499 doc
: /* The full name of the user logged in. */);
4501 DEFVAR_LISP ("user-login-name", &Vuser_login_name
,
4502 doc
: /* The user's name, taken from environment variables if possible. */);
4504 DEFVAR_LISP ("user-real-login-name", &Vuser_real_login_name
,
4505 doc
: /* The user's name, based upon the real uid only. */);
4507 DEFVAR_LISP ("operating-system-release", &Voperating_system_release
,
4508 doc
: /* The release of the operating system Emacs is running on. */);
4510 defsubr (&Spropertize
);
4511 defsubr (&Schar_equal
);
4512 defsubr (&Sgoto_char
);
4513 defsubr (&Sstring_to_char
);
4514 defsubr (&Schar_to_string
);
4515 defsubr (&Sbuffer_substring
);
4516 defsubr (&Sbuffer_substring_no_properties
);
4517 defsubr (&Sbuffer_string
);
4519 defsubr (&Spoint_marker
);
4520 defsubr (&Smark_marker
);
4522 defsubr (&Sregion_beginning
);
4523 defsubr (&Sregion_end
);
4525 staticpro (&Qfield
);
4526 Qfield
= intern ("field");
4527 staticpro (&Qboundary
);
4528 Qboundary
= intern ("boundary");
4529 defsubr (&Sfield_beginning
);
4530 defsubr (&Sfield_end
);
4531 defsubr (&Sfield_string
);
4532 defsubr (&Sfield_string_no_properties
);
4533 defsubr (&Sdelete_field
);
4534 defsubr (&Sconstrain_to_field
);
4536 defsubr (&Sline_beginning_position
);
4537 defsubr (&Sline_end_position
);
4539 /* defsubr (&Smark); */
4540 /* defsubr (&Sset_mark); */
4541 defsubr (&Ssave_excursion
);
4542 defsubr (&Ssave_current_buffer
);
4544 defsubr (&Sbufsize
);
4545 defsubr (&Spoint_max
);
4546 defsubr (&Spoint_min
);
4547 defsubr (&Spoint_min_marker
);
4548 defsubr (&Spoint_max_marker
);
4549 defsubr (&Sgap_position
);
4550 defsubr (&Sgap_size
);
4551 defsubr (&Sposition_bytes
);
4552 defsubr (&Sbyte_to_position
);
4558 defsubr (&Sfollowing_char
);
4559 defsubr (&Sprevious_char
);
4560 defsubr (&Schar_after
);
4561 defsubr (&Schar_before
);
4563 defsubr (&Sinsert_before_markers
);
4564 defsubr (&Sinsert_and_inherit
);
4565 defsubr (&Sinsert_and_inherit_before_markers
);
4566 defsubr (&Sinsert_char
);
4567 defsubr (&Sinsert_byte
);
4569 defsubr (&Suser_login_name
);
4570 defsubr (&Suser_real_login_name
);
4571 defsubr (&Suser_uid
);
4572 defsubr (&Suser_real_uid
);
4573 defsubr (&Suser_full_name
);
4574 defsubr (&Semacs_pid
);
4575 defsubr (&Scurrent_time
);
4576 defsubr (&Sget_internal_run_time
);
4577 defsubr (&Sformat_time_string
);
4578 defsubr (&Sfloat_time
);
4579 defsubr (&Sdecode_time
);
4580 defsubr (&Sencode_time
);
4581 defsubr (&Scurrent_time_string
);
4582 defsubr (&Scurrent_time_zone
);
4583 defsubr (&Sset_time_zone_rule
);
4584 defsubr (&Ssystem_name
);
4585 defsubr (&Smessage
);
4586 defsubr (&Smessage_box
);
4587 defsubr (&Smessage_or_box
);
4588 defsubr (&Scurrent_message
);
4591 defsubr (&Sinsert_buffer_substring
);
4592 defsubr (&Scompare_buffer_substrings
);
4593 defsubr (&Ssubst_char_in_region
);
4594 defsubr (&Stranslate_region_internal
);
4595 defsubr (&Sdelete_region
);
4596 defsubr (&Sdelete_and_extract_region
);
4598 defsubr (&Snarrow_to_region
);
4599 defsubr (&Ssave_restriction
);
4600 defsubr (&Stranspose_regions
);
4603 /* arch-tag: fc3827d8-6f60-4067-b11e-c3218031b018
4604 (do not change this comment) */