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 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"
62 #define MAX_10_EXP DBL_MAX_10_EXP
64 #define MAX_10_EXP 310
72 extern char **environ
;
75 extern size_t emacs_strftimeu
P_ ((char *, size_t, const char *,
76 const struct tm
*, int));
77 static int tm_diff
P_ ((struct tm
*, struct tm
*));
78 static void find_field
P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
, int *, Lisp_Object
, int *));
79 static void update_buffer_properties
P_ ((int, int));
80 static Lisp_Object region_limit
P_ ((int));
81 int lisp_time_argument
P_ ((Lisp_Object
, time_t *, int *));
82 static size_t emacs_memftimeu
P_ ((char *, size_t, const char *,
83 size_t, const struct tm
*, int));
84 static void general_insert_function
P_ ((void (*) (const unsigned char *, int),
85 void (*) (Lisp_Object
, int, int, int,
87 int, int, Lisp_Object
*));
88 static Lisp_Object subst_char_in_region_unwind
P_ ((Lisp_Object
));
89 static Lisp_Object subst_char_in_region_unwind_1
P_ ((Lisp_Object
));
90 static void transpose_markers
P_ ((int, int, int, int, int, int, int, int));
93 extern char *index
P_ ((const char *, int));
96 Lisp_Object Vbuffer_access_fontify_functions
;
97 Lisp_Object Qbuffer_access_fontify_functions
;
98 Lisp_Object Vbuffer_access_fontified_property
;
100 Lisp_Object Fuser_full_name
P_ ((Lisp_Object
));
102 /* Non-nil means don't stop at field boundary in text motion commands. */
104 Lisp_Object Vinhibit_field_text_motion
;
106 /* Some static data, and a function to initialize it for each run */
108 Lisp_Object Vsystem_name
;
109 Lisp_Object Vuser_real_login_name
; /* login name of current user ID */
110 Lisp_Object Vuser_full_name
; /* full name of current user */
111 Lisp_Object Vuser_login_name
; /* user name from LOGNAME or USER */
112 Lisp_Object Voperating_system_release
; /* Operating System Release */
114 /* Symbol for the text property used to mark fields. */
118 /* A special value for Qfield properties. */
120 Lisp_Object Qboundary
;
127 register unsigned char *p
;
128 struct passwd
*pw
; /* password entry for the current user */
131 /* Set up system_name even when dumping. */
135 /* Don't bother with this on initial start when just dumping out */
138 #endif /* not CANNOT_DUMP */
140 pw
= (struct passwd
*) getpwuid (getuid ());
142 /* We let the real user name default to "root" because that's quite
143 accurate on MSDOG and because it lets Emacs find the init file.
144 (The DVX libraries override the Djgpp libraries here.) */
145 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "root");
147 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "unknown");
150 /* Get the effective user name, by consulting environment variables,
151 or the effective uid if those are unset. */
152 user_name
= (char *) getenv ("LOGNAME");
155 user_name
= (char *) getenv ("USERNAME"); /* it's USERNAME on NT */
156 #else /* WINDOWSNT */
157 user_name
= (char *) getenv ("USER");
158 #endif /* WINDOWSNT */
161 pw
= (struct passwd
*) getpwuid (geteuid ());
162 user_name
= (char *) (pw
? pw
->pw_name
: "unknown");
164 Vuser_login_name
= build_string (user_name
);
166 /* If the user name claimed in the environment vars differs from
167 the real uid, use the claimed name to find the full name. */
168 tem
= Fstring_equal (Vuser_login_name
, Vuser_real_login_name
);
169 Vuser_full_name
= Fuser_full_name (NILP (tem
)? make_number (geteuid())
172 p
= (unsigned char *) getenv ("NAME");
174 Vuser_full_name
= build_string (p
);
175 else if (NILP (Vuser_full_name
))
176 Vuser_full_name
= build_string ("unknown");
178 #ifdef HAVE_SYS_UTSNAME_H
182 Voperating_system_release
= build_string (uts
.release
);
185 Voperating_system_release
= Qnil
;
189 DEFUN ("char-to-string", Fchar_to_string
, Schar_to_string
, 1, 1, 0,
190 doc
: /* Convert arg CHAR to a string containing that character.
191 usage: (char-to-string CHAR) */)
193 Lisp_Object character
;
196 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
198 CHECK_NUMBER (character
);
200 len
= (SINGLE_BYTE_CHAR_P (XFASTINT (character
))
201 ? (*str
= (unsigned char)(XFASTINT (character
)), 1)
202 : char_to_string (XFASTINT (character
), str
));
203 return make_string_from_bytes (str
, 1, len
);
206 DEFUN ("string-to-char", Fstring_to_char
, Sstring_to_char
, 1, 1, 0,
207 doc
: /* Convert arg STRING to a character, the first character of that string.
208 A multibyte character is handled correctly. */)
210 register Lisp_Object string
;
212 register Lisp_Object val
;
213 CHECK_STRING (string
);
216 if (STRING_MULTIBYTE (string
))
217 XSETFASTINT (val
, STRING_CHAR (SDATA (string
), SBYTES (string
)));
219 XSETFASTINT (val
, SREF (string
, 0));
222 XSETFASTINT (val
, 0);
227 buildmark (charpos
, bytepos
)
228 int charpos
, bytepos
;
230 register Lisp_Object mark
;
231 mark
= Fmake_marker ();
232 set_marker_both (mark
, Qnil
, charpos
, bytepos
);
236 DEFUN ("point", Fpoint
, Spoint
, 0, 0, 0,
237 doc
: /* Return value of point, as an integer.
238 Beginning of buffer is position (point-min). */)
242 XSETFASTINT (temp
, PT
);
246 DEFUN ("point-marker", Fpoint_marker
, Spoint_marker
, 0, 0, 0,
247 doc
: /* Return value of point, as a marker object. */)
250 return buildmark (PT
, PT_BYTE
);
254 clip_to_bounds (lower
, num
, upper
)
255 int lower
, num
, upper
;
259 else if (num
> upper
)
265 DEFUN ("goto-char", Fgoto_char
, Sgoto_char
, 1, 1, "NGoto char: ",
266 doc
: /* Set point to POSITION, a number or marker.
267 Beginning of buffer is position (point-min), end is (point-max). */)
269 register Lisp_Object position
;
273 if (MARKERP (position
)
274 && current_buffer
== XMARKER (position
)->buffer
)
276 pos
= marker_position (position
);
278 SET_PT_BOTH (BEGV
, BEGV_BYTE
);
280 SET_PT_BOTH (ZV
, ZV_BYTE
);
282 SET_PT_BOTH (pos
, marker_byte_position (position
));
287 CHECK_NUMBER_COERCE_MARKER (position
);
289 pos
= clip_to_bounds (BEGV
, XINT (position
), ZV
);
295 /* Return the start or end position of the region.
296 BEGINNINGP non-zero means return the start.
297 If there is no region active, signal an error. */
300 region_limit (beginningp
)
303 extern Lisp_Object Vmark_even_if_inactive
; /* Defined in callint.c. */
306 if (!NILP (Vtransient_mark_mode
)
307 && NILP (Vmark_even_if_inactive
)
308 && NILP (current_buffer
->mark_active
))
309 Fsignal (Qmark_inactive
, Qnil
);
311 m
= Fmarker_position (current_buffer
->mark
);
313 error ("The mark is not set now, so there is no region");
315 if ((PT
< XFASTINT (m
)) == (beginningp
!= 0))
316 m
= make_number (PT
);
320 DEFUN ("region-beginning", Fregion_beginning
, Sregion_beginning
, 0, 0, 0,
321 doc
: /* Return position of beginning of region, as an integer. */)
324 return region_limit (1);
327 DEFUN ("region-end", Fregion_end
, Sregion_end
, 0, 0, 0,
328 doc
: /* Return position of end of region, as an integer. */)
331 return region_limit (0);
334 DEFUN ("mark-marker", Fmark_marker
, Smark_marker
, 0, 0, 0,
335 doc
: /* Return this buffer's mark, as a marker object.
336 Watch out! Moving this marker changes the mark position.
337 If you set the marker not to point anywhere, the buffer will have no mark. */)
340 return current_buffer
->mark
;
344 /* Find all the overlays in the current buffer that touch position POS.
345 Return the number found, and store them in a vector in VEC
349 overlays_around (pos
, vec
, len
)
354 Lisp_Object overlay
, start
, end
;
355 struct Lisp_Overlay
*tail
;
356 int startpos
, endpos
;
359 for (tail
= current_buffer
->overlays_before
; tail
; tail
= tail
->next
)
361 XSETMISC (overlay
, tail
);
363 end
= OVERLAY_END (overlay
);
364 endpos
= OVERLAY_POSITION (end
);
367 start
= OVERLAY_START (overlay
);
368 startpos
= OVERLAY_POSITION (start
);
373 /* Keep counting overlays even if we can't return them all. */
378 for (tail
= current_buffer
->overlays_after
; tail
; tail
= tail
->next
)
380 XSETMISC (overlay
, tail
);
382 start
= OVERLAY_START (overlay
);
383 startpos
= OVERLAY_POSITION (start
);
386 end
= OVERLAY_END (overlay
);
387 endpos
= OVERLAY_POSITION (end
);
399 /* Return the value of property PROP, in OBJECT at POSITION.
400 It's the value of PROP that a char inserted at POSITION would get.
401 OBJECT is optional and defaults to the current buffer.
402 If OBJECT is a buffer, then overlay properties are considered as well as
404 If OBJECT is a window, then that window's buffer is used, but
405 window-specific overlays are considered only if they are associated
408 get_pos_property (position
, prop
, object
)
409 Lisp_Object position
, object
;
410 register Lisp_Object prop
;
412 CHECK_NUMBER_COERCE_MARKER (position
);
415 XSETBUFFER (object
, current_buffer
);
416 else if (WINDOWP (object
))
417 object
= XWINDOW (object
)->buffer
;
419 if (!BUFFERP (object
))
420 /* pos-property only makes sense in buffers right now, since strings
421 have no overlays and no notion of insertion for which stickiness
423 return Fget_text_property (position
, prop
, object
);
426 int posn
= XINT (position
);
428 Lisp_Object
*overlay_vec
, tem
;
429 struct buffer
*obuf
= current_buffer
;
431 set_buffer_temp (XBUFFER (object
));
433 /* First try with room for 40 overlays. */
435 overlay_vec
= (Lisp_Object
*) alloca (noverlays
* sizeof (Lisp_Object
));
436 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
438 /* If there are more than 40,
439 make enough space for all, and try again. */
442 overlay_vec
= (Lisp_Object
*) alloca (noverlays
* sizeof (Lisp_Object
));
443 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
445 noverlays
= sort_overlays (overlay_vec
, noverlays
, NULL
);
447 set_buffer_temp (obuf
);
449 /* Now check the overlays in order of decreasing priority. */
450 while (--noverlays
>= 0)
452 Lisp_Object ol
= overlay_vec
[noverlays
];
453 tem
= Foverlay_get (ol
, prop
);
456 /* Check the overlay is indeed active at point. */
457 Lisp_Object start
= OVERLAY_START (ol
), finish
= OVERLAY_END (ol
);
458 if ((OVERLAY_POSITION (start
) == posn
459 && XMARKER (start
)->insertion_type
== 1)
460 || (OVERLAY_POSITION (finish
) == posn
461 && XMARKER (finish
)->insertion_type
== 0))
462 ; /* The overlay will not cover a char inserted at point. */
470 { /* Now check the text-properties. */
471 int stickiness
= text_property_stickiness (prop
, position
, object
);
473 return Fget_text_property (position
, prop
, object
);
474 else if (stickiness
< 0
475 && XINT (position
) > BUF_BEGV (XBUFFER (object
)))
476 return Fget_text_property (make_number (XINT (position
) - 1),
484 /* Find the field surrounding POS in *BEG and *END. If POS is nil,
485 the value of point is used instead. If BEG or END null,
486 means don't store the beginning or end of the field.
488 BEG_LIMIT and END_LIMIT serve to limit the ranged of the returned
489 results; they do not effect boundary behavior.
491 If MERGE_AT_BOUNDARY is nonzero, then if POS is at the very first
492 position of a field, then the beginning of the previous field is
493 returned instead of the beginning of POS's field (since the end of a
494 field is actually also the beginning of the next input field, this
495 behavior is sometimes useful). Additionally in the MERGE_AT_BOUNDARY
496 true case, if two fields are separated by a field with the special
497 value `boundary', and POS lies within it, then the two separated
498 fields are considered to be adjacent, and POS between them, when
499 finding the beginning and ending of the "merged" field.
501 Either BEG or END may be 0, in which case the corresponding value
505 find_field (pos
, merge_at_boundary
, beg_limit
, beg
, end_limit
, end
)
507 Lisp_Object merge_at_boundary
;
508 Lisp_Object beg_limit
, end_limit
;
511 /* Fields right before and after the point. */
512 Lisp_Object before_field
, after_field
;
513 /* 1 if POS counts as the start of a field. */
514 int at_field_start
= 0;
515 /* 1 if POS counts as the end of a field. */
516 int at_field_end
= 0;
519 XSETFASTINT (pos
, PT
);
521 CHECK_NUMBER_COERCE_MARKER (pos
);
524 = get_char_property_and_overlay (pos
, Qfield
, Qnil
, NULL
);
526 = (XFASTINT (pos
) > BEGV
527 ? get_char_property_and_overlay (make_number (XINT (pos
) - 1),
531 /* See if we need to handle the case where MERGE_AT_BOUNDARY is nil
532 and POS is at beginning of a field, which can also be interpreted
533 as the end of the previous field. Note that the case where if
534 MERGE_AT_BOUNDARY is non-nil (see function comment) is actually the
535 more natural one; then we avoid treating the beginning of a field
537 if (NILP (merge_at_boundary
))
539 Lisp_Object field
= get_pos_property (pos
, Qfield
, Qnil
);
540 if (!EQ (field
, after_field
))
542 if (!EQ (field
, before_field
))
544 if (NILP (field
) && at_field_start
&& at_field_end
)
545 /* If an inserted char would have a nil field while the surrounding
546 text is non-nil, we're probably not looking at a
547 zero-length field, but instead at a non-nil field that's
548 not intended for editing (such as comint's prompts). */
549 at_field_end
= at_field_start
= 0;
552 /* Note about special `boundary' fields:
554 Consider the case where the point (`.') is between the fields `x' and `y':
558 In this situation, if merge_at_boundary is true, we consider the
559 `x' and `y' fields as forming one big merged field, and so the end
560 of the field is the end of `y'.
562 However, if `x' and `y' are separated by a special `boundary' field
563 (a field with a `field' char-property of 'boundary), then we ignore
564 this special field when merging adjacent fields. Here's the same
565 situation, but with a `boundary' field between the `x' and `y' fields:
569 Here, if point is at the end of `x', the beginning of `y', or
570 anywhere in-between (within the `boundary' field), we merge all
571 three fields and consider the beginning as being the beginning of
572 the `x' field, and the end as being the end of the `y' field. */
577 /* POS is at the edge of a field, and we should consider it as
578 the beginning of the following field. */
579 *beg
= XFASTINT (pos
);
581 /* Find the previous field boundary. */
584 if (!NILP (merge_at_boundary
) && EQ (before_field
, Qboundary
))
585 /* Skip a `boundary' field. */
586 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
589 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
591 *beg
= NILP (p
) ? BEGV
: XFASTINT (p
);
598 /* POS is at the edge of a field, and we should consider it as
599 the end of the previous field. */
600 *end
= XFASTINT (pos
);
602 /* Find the next field boundary. */
604 if (!NILP (merge_at_boundary
) && EQ (after_field
, Qboundary
))
605 /* Skip a `boundary' field. */
606 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
609 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
611 *end
= NILP (pos
) ? ZV
: XFASTINT (pos
);
617 DEFUN ("delete-field", Fdelete_field
, Sdelete_field
, 0, 1, 0,
618 doc
: /* Delete the field surrounding POS.
619 A field is a region of text with the same `field' property.
620 If POS is nil, the value of point is used for POS. */)
625 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
627 del_range (beg
, end
);
631 DEFUN ("field-string", Ffield_string
, Sfield_string
, 0, 1, 0,
632 doc
: /* Return the contents of the field surrounding POS as a string.
633 A field is a region of text with the same `field' property.
634 If POS is nil, the value of point is used for POS. */)
639 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
640 return make_buffer_string (beg
, end
, 1);
643 DEFUN ("field-string-no-properties", Ffield_string_no_properties
, Sfield_string_no_properties
, 0, 1, 0,
644 doc
: /* Return the contents of the field around POS, without text-properties.
645 A field is a region of text with the same `field' property.
646 If POS is nil, the value of point is used for POS. */)
651 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
652 return make_buffer_string (beg
, end
, 0);
655 DEFUN ("field-beginning", Ffield_beginning
, Sfield_beginning
, 0, 3, 0,
656 doc
: /* Return the beginning of the field surrounding POS.
657 A field is a region of text with the same `field' property.
658 If POS is nil, the value of point is used for POS.
659 If ESCAPE-FROM-EDGE is non-nil and POS is at the beginning of its
660 field, then the beginning of the *previous* field is returned.
661 If LIMIT is non-nil, it is a buffer position; if the beginning of the field
662 is before LIMIT, then LIMIT will be returned instead. */)
663 (pos
, escape_from_edge
, limit
)
664 Lisp_Object pos
, escape_from_edge
, limit
;
667 find_field (pos
, escape_from_edge
, limit
, &beg
, Qnil
, 0);
668 return make_number (beg
);
671 DEFUN ("field-end", Ffield_end
, Sfield_end
, 0, 3, 0,
672 doc
: /* Return the end of the field surrounding POS.
673 A field is a region of text with the same `field' property.
674 If POS is nil, the value of point is used for POS.
675 If ESCAPE-FROM-EDGE is non-nil and POS is at the end of its field,
676 then the end of the *following* field is returned.
677 If LIMIT is non-nil, it is a buffer position; if the end of the field
678 is after LIMIT, then LIMIT will be returned instead. */)
679 (pos
, escape_from_edge
, limit
)
680 Lisp_Object pos
, escape_from_edge
, limit
;
683 find_field (pos
, escape_from_edge
, Qnil
, 0, limit
, &end
);
684 return make_number (end
);
687 DEFUN ("constrain-to-field", Fconstrain_to_field
, Sconstrain_to_field
, 2, 5, 0,
688 doc
: /* Return the position closest to NEW-POS that is in the same field as OLD-POS.
690 A field is a region of text with the same `field' property.
691 If NEW-POS is nil, then the current point is used instead, and set to the
692 constrained position if that is different.
694 If OLD-POS is at the boundary of two fields, then the allowable
695 positions for NEW-POS depends on the value of the optional argument
696 ESCAPE-FROM-EDGE: If ESCAPE-FROM-EDGE is nil, then NEW-POS is
697 constrained to the field that has the same `field' char-property
698 as any new characters inserted at OLD-POS, whereas if ESCAPE-FROM-EDGE
699 is non-nil, NEW-POS is constrained to the union of the two adjacent
700 fields. Additionally, if two fields are separated by another field with
701 the special value `boundary', then any point within this special field is
702 also considered to be `on the boundary'.
704 If the optional argument ONLY-IN-LINE is non-nil and constraining
705 NEW-POS would move it to a different line, NEW-POS is returned
706 unconstrained. This useful for commands that move by line, like
707 \\[next-line] or \\[beginning-of-line], which should generally respect field boundaries
708 only in the case where they can still move to the right line.
710 If the optional argument INHIBIT-CAPTURE-PROPERTY is non-nil, and OLD-POS has
711 a non-nil property of that name, then any field boundaries are ignored.
713 Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */)
714 (new_pos
, old_pos
, escape_from_edge
, only_in_line
, inhibit_capture_property
)
715 Lisp_Object new_pos
, old_pos
;
716 Lisp_Object escape_from_edge
, only_in_line
, inhibit_capture_property
;
718 /* If non-zero, then the original point, before re-positioning. */
722 /* Use the current point, and afterwards, set it. */
725 XSETFASTINT (new_pos
, PT
);
728 if (NILP (Vinhibit_field_text_motion
)
729 && !EQ (new_pos
, old_pos
)
730 && (!NILP (get_pos_property (new_pos
, Qfield
, Qnil
))
731 || !NILP (get_pos_property (old_pos
, Qfield
, Qnil
)))
732 && (NILP (inhibit_capture_property
)
733 || NILP (get_pos_property (old_pos
, inhibit_capture_property
, Qnil
))))
734 /* It is possible that NEW_POS is not within the same field as
735 OLD_POS; try to move NEW_POS so that it is. */
738 Lisp_Object field_bound
;
740 CHECK_NUMBER_COERCE_MARKER (new_pos
);
741 CHECK_NUMBER_COERCE_MARKER (old_pos
);
743 fwd
= (XFASTINT (new_pos
) > XFASTINT (old_pos
));
746 field_bound
= Ffield_end (old_pos
, escape_from_edge
, new_pos
);
748 field_bound
= Ffield_beginning (old_pos
, escape_from_edge
, new_pos
);
750 if (/* See if ESCAPE_FROM_EDGE caused FIELD_BOUND to jump to the
751 other side of NEW_POS, which would mean that NEW_POS is
752 already acceptable, and it's not necessary to constrain it
754 ((XFASTINT (field_bound
) < XFASTINT (new_pos
)) ? fwd
: !fwd
)
755 /* NEW_POS should be constrained, but only if either
756 ONLY_IN_LINE is nil (in which case any constraint is OK),
757 or NEW_POS and FIELD_BOUND are on the same line (in which
758 case the constraint is OK even if ONLY_IN_LINE is non-nil). */
759 && (NILP (only_in_line
)
760 /* This is the ONLY_IN_LINE case, check that NEW_POS and
761 FIELD_BOUND are on the same line by seeing whether
762 there's an intervening newline or not. */
763 || (scan_buffer ('\n',
764 XFASTINT (new_pos
), XFASTINT (field_bound
),
765 fwd
? -1 : 1, &shortage
, 1),
767 /* Constrain NEW_POS to FIELD_BOUND. */
768 new_pos
= field_bound
;
770 if (orig_point
&& XFASTINT (new_pos
) != orig_point
)
771 /* The NEW_POS argument was originally nil, so automatically set PT. */
772 SET_PT (XFASTINT (new_pos
));
779 DEFUN ("line-beginning-position",
780 Fline_beginning_position
, Sline_beginning_position
, 0, 1, 0,
781 doc
: /* Return the character position of the first character on the current line.
782 With argument N not nil or 1, move forward N - 1 lines first.
783 If scan reaches end of buffer, return that position.
785 This function constrains the returned position to the current field
786 unless that would be on a different line than the original,
787 unconstrained result. If N is nil or 1, and a front-sticky field
788 starts at point, the scan stops as soon as it starts. To ignore field
789 boundaries bind `inhibit-field-text-motion' to t.
791 This function does not move point. */)
795 int orig
, orig_byte
, end
;
804 Fforward_line (make_number (XINT (n
) - 1));
807 SET_PT_BOTH (orig
, orig_byte
);
809 /* Return END constrained to the current input field. */
810 return Fconstrain_to_field (make_number (end
), make_number (orig
),
811 XINT (n
) != 1 ? Qt
: Qnil
,
815 DEFUN ("line-end-position", Fline_end_position
, Sline_end_position
, 0, 1, 0,
816 doc
: /* Return the character position of the last character on the current line.
817 With argument N not nil or 1, move forward N - 1 lines first.
818 If scan reaches end of buffer, return that position.
820 This function constrains the returned position to the current field
821 unless that would be on a different line than the original,
822 unconstrained result. If N is nil or 1, and a rear-sticky field ends
823 at point, the scan stops as soon as it starts. To ignore field
824 boundaries bind `inhibit-field-text-motion' to t.
826 This function does not move point. */)
838 end_pos
= find_before_next_newline (orig
, 0, XINT (n
) - (XINT (n
) <= 0));
840 /* Return END_POS constrained to the current input field. */
841 return Fconstrain_to_field (make_number (end_pos
), make_number (orig
),
847 save_excursion_save ()
849 int visible
= (XBUFFER (XWINDOW (selected_window
)->buffer
)
852 return Fcons (Fpoint_marker (),
853 Fcons (Fcopy_marker (current_buffer
->mark
, Qnil
),
854 Fcons (visible
? Qt
: Qnil
,
855 Fcons (current_buffer
->mark_active
,
860 save_excursion_restore (info
)
863 Lisp_Object tem
, tem1
, omark
, nmark
;
864 struct gcpro gcpro1
, gcpro2
, gcpro3
;
867 tem
= Fmarker_buffer (XCAR (info
));
868 /* If buffer being returned to is now deleted, avoid error */
869 /* Otherwise could get error here while unwinding to top level
871 /* In that case, Fmarker_buffer returns nil now. */
875 omark
= nmark
= Qnil
;
876 GCPRO3 (info
, omark
, nmark
);
883 unchain_marker (XMARKER (tem
));
888 omark
= Fmarker_position (current_buffer
->mark
);
889 Fset_marker (current_buffer
->mark
, tem
, Fcurrent_buffer ());
890 nmark
= Fmarker_position (tem
);
891 unchain_marker (XMARKER (tem
));
895 visible_p
= !NILP (XCAR (info
));
897 #if 0 /* We used to make the current buffer visible in the selected window
898 if that was true previously. That avoids some anomalies.
899 But it creates others, and it wasn't documented, and it is simpler
900 and cleaner never to alter the window/buffer connections. */
903 && current_buffer
!= XBUFFER (XWINDOW (selected_window
)->buffer
))
904 Fswitch_to_buffer (Fcurrent_buffer (), Qnil
);
910 tem1
= current_buffer
->mark_active
;
911 current_buffer
->mark_active
= tem
;
913 if (!NILP (Vrun_hooks
))
915 /* If mark is active now, and either was not active
916 or was at a different place, run the activate hook. */
917 if (! NILP (current_buffer
->mark_active
))
919 if (! EQ (omark
, nmark
))
920 call1 (Vrun_hooks
, intern ("activate-mark-hook"));
922 /* If mark has ceased to be active, run deactivate hook. */
923 else if (! NILP (tem1
))
924 call1 (Vrun_hooks
, intern ("deactivate-mark-hook"));
927 /* If buffer was visible in a window, and a different window was
928 selected, and the old selected window is still showing this
929 buffer, restore point in that window. */
932 && !EQ (tem
, selected_window
)
933 && (tem1
= XWINDOW (tem
)->buffer
,
934 (/* Window is live... */
936 /* ...and it shows the current buffer. */
937 && XBUFFER (tem1
) == current_buffer
)))
938 Fset_window_point (tem
, make_number (PT
));
944 DEFUN ("save-excursion", Fsave_excursion
, Ssave_excursion
, 0, UNEVALLED
, 0,
945 doc
: /* Save point, mark, and current buffer; execute BODY; restore those things.
946 Executes BODY just like `progn'.
947 The values of point, mark and the current buffer are restored
948 even in case of abnormal exit (throw or error).
949 The state of activation of the mark is also restored.
951 This construct does not save `deactivate-mark', and therefore
952 functions that change the buffer will still cause deactivation
953 of the mark at the end of the command. To prevent that, bind
954 `deactivate-mark' with `let'.
956 usage: (save-excursion &rest BODY) */)
960 register Lisp_Object val
;
961 int count
= SPECPDL_INDEX ();
963 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
966 return unbind_to (count
, val
);
969 DEFUN ("save-current-buffer", Fsave_current_buffer
, Ssave_current_buffer
, 0, UNEVALLED
, 0,
970 doc
: /* Save the current buffer; execute BODY; restore the current buffer.
971 Executes BODY just like `progn'.
972 usage: (save-current-buffer &rest BODY) */)
977 int count
= SPECPDL_INDEX ();
979 record_unwind_protect (set_buffer_if_live
, Fcurrent_buffer ());
982 return unbind_to (count
, val
);
985 DEFUN ("buffer-size", Fbufsize
, Sbufsize
, 0, 1, 0,
986 doc
: /* Return the number of characters in the current buffer.
987 If BUFFER, return the number of characters in that buffer instead. */)
992 return make_number (Z
- BEG
);
995 CHECK_BUFFER (buffer
);
996 return make_number (BUF_Z (XBUFFER (buffer
))
997 - BUF_BEG (XBUFFER (buffer
)));
1001 DEFUN ("point-min", Fpoint_min
, Spoint_min
, 0, 0, 0,
1002 doc
: /* Return the minimum permissible value of point in the current buffer.
1003 This is 1, unless narrowing (a buffer restriction) is in effect. */)
1007 XSETFASTINT (temp
, BEGV
);
1011 DEFUN ("point-min-marker", Fpoint_min_marker
, Spoint_min_marker
, 0, 0, 0,
1012 doc
: /* Return a marker to the minimum permissible value of point in this buffer.
1013 This is the beginning, unless narrowing (a buffer restriction) is in effect. */)
1016 return buildmark (BEGV
, BEGV_BYTE
);
1019 DEFUN ("point-max", Fpoint_max
, Spoint_max
, 0, 0, 0,
1020 doc
: /* Return the maximum permissible value of point in the current buffer.
1021 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1022 is in effect, in which case it is less. */)
1026 XSETFASTINT (temp
, ZV
);
1030 DEFUN ("point-max-marker", Fpoint_max_marker
, Spoint_max_marker
, 0, 0, 0,
1031 doc
: /* Return a marker to the maximum permissible value of point in this buffer.
1032 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1033 is in effect, in which case it is less. */)
1036 return buildmark (ZV
, ZV_BYTE
);
1039 DEFUN ("gap-position", Fgap_position
, Sgap_position
, 0, 0, 0,
1040 doc
: /* Return the position of the gap, in the current buffer.
1041 See also `gap-size'. */)
1045 XSETFASTINT (temp
, GPT
);
1049 DEFUN ("gap-size", Fgap_size
, Sgap_size
, 0, 0, 0,
1050 doc
: /* Return the size of the current buffer's gap.
1051 See also `gap-position'. */)
1055 XSETFASTINT (temp
, GAP_SIZE
);
1059 DEFUN ("position-bytes", Fposition_bytes
, Sposition_bytes
, 1, 1, 0,
1060 doc
: /* Return the byte position for character position POSITION.
1061 If POSITION is out of range, the value is nil. */)
1063 Lisp_Object position
;
1065 CHECK_NUMBER_COERCE_MARKER (position
);
1066 if (XINT (position
) < BEG
|| XINT (position
) > Z
)
1068 return make_number (CHAR_TO_BYTE (XINT (position
)));
1071 DEFUN ("byte-to-position", Fbyte_to_position
, Sbyte_to_position
, 1, 1, 0,
1072 doc
: /* Return the character position for byte position BYTEPOS.
1073 If BYTEPOS is out of range, the value is nil. */)
1075 Lisp_Object bytepos
;
1077 CHECK_NUMBER (bytepos
);
1078 if (XINT (bytepos
) < BEG_BYTE
|| XINT (bytepos
) > Z_BYTE
)
1080 return make_number (BYTE_TO_CHAR (XINT (bytepos
)));
1083 DEFUN ("following-char", Ffollowing_char
, Sfollowing_char
, 0, 0, 0,
1084 doc
: /* Return the character following point, as a number.
1085 At the end of the buffer or accessible region, return 0. */)
1090 XSETFASTINT (temp
, 0);
1092 XSETFASTINT (temp
, FETCH_CHAR (PT_BYTE
));
1096 DEFUN ("preceding-char", Fprevious_char
, Sprevious_char
, 0, 0, 0,
1097 doc
: /* Return the character preceding point, as a number.
1098 At the beginning of the buffer or accessible region, return 0. */)
1103 XSETFASTINT (temp
, 0);
1104 else if (!NILP (current_buffer
->enable_multibyte_characters
))
1108 XSETFASTINT (temp
, FETCH_CHAR (pos
));
1111 XSETFASTINT (temp
, FETCH_BYTE (PT_BYTE
- 1));
1115 DEFUN ("bobp", Fbobp
, Sbobp
, 0, 0, 0,
1116 doc
: /* Return t if point is at the beginning of the buffer.
1117 If the buffer is narrowed, this means the beginning of the narrowed part. */)
1125 DEFUN ("eobp", Feobp
, Seobp
, 0, 0, 0,
1126 doc
: /* Return t if point is at the end of the buffer.
1127 If the buffer is narrowed, this means the end of the narrowed part. */)
1135 DEFUN ("bolp", Fbolp
, Sbolp
, 0, 0, 0,
1136 doc
: /* Return t if point is at the beginning of a line. */)
1139 if (PT
== BEGV
|| FETCH_BYTE (PT_BYTE
- 1) == '\n')
1144 DEFUN ("eolp", Feolp
, Seolp
, 0, 0, 0,
1145 doc
: /* Return t if point is at the end of a line.
1146 `End of a line' includes point being at the end of the buffer. */)
1149 if (PT
== ZV
|| FETCH_BYTE (PT_BYTE
) == '\n')
1154 DEFUN ("char-after", Fchar_after
, Schar_after
, 0, 1, 0,
1155 doc
: /* Return character in current buffer at position POS.
1156 POS is an integer or a marker and defaults to point.
1157 If POS is out of range, the value is nil. */)
1161 register int pos_byte
;
1166 XSETFASTINT (pos
, PT
);
1171 pos_byte
= marker_byte_position (pos
);
1172 if (pos_byte
< BEGV_BYTE
|| pos_byte
>= ZV_BYTE
)
1177 CHECK_NUMBER_COERCE_MARKER (pos
);
1178 if (XINT (pos
) < BEGV
|| XINT (pos
) >= ZV
)
1181 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1184 return make_number (FETCH_CHAR (pos_byte
));
1187 DEFUN ("char-before", Fchar_before
, Schar_before
, 0, 1, 0,
1188 doc
: /* Return character in current buffer preceding position POS.
1189 POS is an integer or a marker and defaults to point.
1190 If POS is out of range, the value is nil. */)
1194 register Lisp_Object val
;
1195 register int pos_byte
;
1200 XSETFASTINT (pos
, PT
);
1205 pos_byte
= marker_byte_position (pos
);
1207 if (pos_byte
<= BEGV_BYTE
|| pos_byte
> ZV_BYTE
)
1212 CHECK_NUMBER_COERCE_MARKER (pos
);
1214 if (XINT (pos
) <= BEGV
|| XINT (pos
) > ZV
)
1217 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1220 if (!NILP (current_buffer
->enable_multibyte_characters
))
1223 XSETFASTINT (val
, FETCH_CHAR (pos_byte
));
1228 XSETFASTINT (val
, FETCH_BYTE (pos_byte
));
1233 DEFUN ("user-login-name", Fuser_login_name
, Suser_login_name
, 0, 1, 0,
1234 doc
: /* Return the name under which the user logged in, as a string.
1235 This is based on the effective uid, not the real uid.
1236 Also, if the environment variables LOGNAME or USER are set,
1237 that determines the value of this function.
1239 If optional argument UID is an integer, return the login name of the user
1240 with that uid, or nil if there is no such user. */)
1246 /* Set up the user name info if we didn't do it before.
1247 (That can happen if Emacs is dumpable
1248 but you decide to run `temacs -l loadup' and not dump. */
1249 if (INTEGERP (Vuser_login_name
))
1253 return Vuser_login_name
;
1256 pw
= (struct passwd
*) getpwuid (XINT (uid
));
1257 return (pw
? build_string (pw
->pw_name
) : Qnil
);
1260 DEFUN ("user-real-login-name", Fuser_real_login_name
, Suser_real_login_name
,
1262 doc
: /* Return the name of the user's real uid, as a string.
1263 This ignores the environment variables LOGNAME and USER, so it differs from
1264 `user-login-name' when running under `su'. */)
1267 /* Set up the user name info if we didn't do it before.
1268 (That can happen if Emacs is dumpable
1269 but you decide to run `temacs -l loadup' and not dump. */
1270 if (INTEGERP (Vuser_login_name
))
1272 return Vuser_real_login_name
;
1275 DEFUN ("user-uid", Fuser_uid
, Suser_uid
, 0, 0, 0,
1276 doc
: /* Return the effective uid of Emacs.
1277 Value is an integer or float, depending on the value. */)
1280 return make_fixnum_or_float (geteuid ());
1283 DEFUN ("user-real-uid", Fuser_real_uid
, Suser_real_uid
, 0, 0, 0,
1284 doc
: /* Return the real uid of Emacs.
1285 Value is an integer or float, depending on the value. */)
1288 return make_fixnum_or_float (getuid ());
1291 DEFUN ("user-full-name", Fuser_full_name
, Suser_full_name
, 0, 1, 0,
1292 doc
: /* Return the full name of the user logged in, as a string.
1293 If the full name corresponding to Emacs's userid is not known,
1296 If optional argument UID is an integer or float, return the full name
1297 of the user with that uid, or nil if there is no such user.
1298 If UID is a string, return the full name of the user with that login
1299 name, or nil if there is no such user. */)
1304 register unsigned char *p
, *q
;
1308 return Vuser_full_name
;
1309 else if (NUMBERP (uid
))
1310 pw
= (struct passwd
*) getpwuid ((uid_t
) XFLOATINT (uid
));
1311 else if (STRINGP (uid
))
1312 pw
= (struct passwd
*) getpwnam (SDATA (uid
));
1314 error ("Invalid UID specification");
1319 p
= (unsigned char *) USER_FULL_NAME
;
1320 /* Chop off everything after the first comma. */
1321 q
= (unsigned char *) index (p
, ',');
1322 full
= make_string (p
, q
? q
- p
: strlen (p
));
1324 #ifdef AMPERSAND_FULL_NAME
1326 q
= (unsigned char *) index (p
, '&');
1327 /* Substitute the login name for the &, upcasing the first character. */
1330 register unsigned char *r
;
1333 login
= Fuser_login_name (make_number (pw
->pw_uid
));
1334 r
= (unsigned char *) alloca (strlen (p
) + SCHARS (login
) + 1);
1335 bcopy (p
, r
, q
- p
);
1337 strcat (r
, SDATA (login
));
1338 r
[q
- p
] = UPCASE (r
[q
- p
]);
1340 full
= build_string (r
);
1342 #endif /* AMPERSAND_FULL_NAME */
1347 DEFUN ("system-name", Fsystem_name
, Ssystem_name
, 0, 0, 0,
1348 doc
: /* Return the name of the machine you are running on, as a string. */)
1351 return Vsystem_name
;
1354 /* For the benefit of callers who don't want to include lisp.h */
1359 if (STRINGP (Vsystem_name
))
1360 return (char *) SDATA (Vsystem_name
);
1366 get_operating_system_release()
1368 if (STRINGP (Voperating_system_release
))
1369 return (char *) SDATA (Voperating_system_release
);
1374 DEFUN ("emacs-pid", Femacs_pid
, Semacs_pid
, 0, 0, 0,
1375 doc
: /* Return the process ID of Emacs, as an integer. */)
1378 return make_number (getpid ());
1381 DEFUN ("current-time", Fcurrent_time
, Scurrent_time
, 0, 0, 0,
1382 doc
: /* Return the current time, as the number of seconds since 1970-01-01 00:00:00.
1383 The time is returned as a list of three integers. The first has the
1384 most significant 16 bits of the seconds, while the second has the
1385 least significant 16 bits. The third integer gives the microsecond
1388 The microsecond count is zero on systems that do not provide
1389 resolution finer than a second. */)
1393 Lisp_Object result
[3];
1396 XSETINT (result
[0], (EMACS_SECS (t
) >> 16) & 0xffff);
1397 XSETINT (result
[1], (EMACS_SECS (t
) >> 0) & 0xffff);
1398 XSETINT (result
[2], EMACS_USECS (t
));
1400 return Flist (3, result
);
1403 DEFUN ("get-internal-run-time", Fget_internal_run_time
, Sget_internal_run_time
,
1405 doc
: /* Return the current run time used by Emacs.
1406 The time is returned as a list of three integers. The first has the
1407 most significant 16 bits of the seconds, while the second has the
1408 least significant 16 bits. The third integer gives the microsecond
1411 On systems that can't determine the run time, get-internal-run-time
1412 does the same thing as current-time. The microsecond count is zero on
1413 systems that do not provide resolution finer than a second. */)
1416 #ifdef HAVE_GETRUSAGE
1417 struct rusage usage
;
1418 Lisp_Object result
[3];
1421 if (getrusage (RUSAGE_SELF
, &usage
) < 0)
1422 /* This shouldn't happen. What action is appropriate? */
1423 Fsignal (Qerror
, Qnil
);
1425 /* Sum up user time and system time. */
1426 secs
= usage
.ru_utime
.tv_sec
+ usage
.ru_stime
.tv_sec
;
1427 usecs
= usage
.ru_utime
.tv_usec
+ usage
.ru_stime
.tv_usec
;
1428 if (usecs
>= 1000000)
1434 XSETINT (result
[0], (secs
>> 16) & 0xffff);
1435 XSETINT (result
[1], (secs
>> 0) & 0xffff);
1436 XSETINT (result
[2], usecs
);
1438 return Flist (3, result
);
1440 return Fcurrent_time ();
1446 lisp_time_argument (specified_time
, result
, usec
)
1447 Lisp_Object specified_time
;
1451 if (NILP (specified_time
))
1458 *usec
= EMACS_USECS (t
);
1459 *result
= EMACS_SECS (t
);
1463 return time (result
) != -1;
1467 Lisp_Object high
, low
;
1468 high
= Fcar (specified_time
);
1469 CHECK_NUMBER (high
);
1470 low
= Fcdr (specified_time
);
1475 Lisp_Object usec_l
= Fcdr (low
);
1477 usec_l
= Fcar (usec_l
);
1482 CHECK_NUMBER (usec_l
);
1483 *usec
= XINT (usec_l
);
1491 *result
= (XINT (high
) << 16) + (XINT (low
) & 0xffff);
1492 return *result
>> 16 == XINT (high
);
1496 DEFUN ("float-time", Ffloat_time
, Sfloat_time
, 0, 1, 0,
1497 doc
: /* Return the current time, as a float number of seconds since the epoch.
1498 If SPECIFIED-TIME is given, it is the time to convert to float
1499 instead of the current time. The argument should have the form
1500 (HIGH LOW . IGNORED). Thus, you can use times obtained from
1501 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
1502 have the form (HIGH . LOW), but this is considered obsolete.
1504 WARNING: Since the result is floating point, it may not be exact.
1505 Do not use this function if precise time stamps are required. */)
1507 Lisp_Object specified_time
;
1512 if (! lisp_time_argument (specified_time
, &sec
, &usec
))
1513 error ("Invalid time specification");
1515 return make_float ((sec
* 1e6
+ usec
) / 1e6
);
1518 /* Write information into buffer S of size MAXSIZE, according to the
1519 FORMAT of length FORMAT_LEN, using time information taken from *TP.
1520 Default to Universal Time if UT is nonzero, local time otherwise.
1521 Return the number of bytes written, not including the terminating
1522 '\0'. If S is NULL, nothing will be written anywhere; so to
1523 determine how many bytes would be written, use NULL for S and
1524 ((size_t) -1) for MAXSIZE.
1526 This function behaves like emacs_strftimeu, except it allows null
1529 emacs_memftimeu (s
, maxsize
, format
, format_len
, tp
, ut
)
1534 const struct tm
*tp
;
1539 /* Loop through all the null-terminated strings in the format
1540 argument. Normally there's just one null-terminated string, but
1541 there can be arbitrarily many, concatenated together, if the
1542 format contains '\0' bytes. emacs_strftimeu stops at the first
1543 '\0' byte so we must invoke it separately for each such string. */
1552 result
= emacs_strftimeu (s
, maxsize
, format
, tp
, ut
);
1556 if (result
== 0 && s
[0] != '\0')
1561 maxsize
-= result
+ 1;
1563 len
= strlen (format
);
1564 if (len
== format_len
)
1568 format_len
-= len
+ 1;
1572 DEFUN ("format-time-string", Fformat_time_string
, Sformat_time_string
, 1, 3, 0,
1573 doc
: /* Use FORMAT-STRING to format the time TIME, or now if omitted.
1574 TIME is specified as (HIGH LOW . IGNORED), as returned by
1575 `current-time' or `file-attributes'. The obsolete form (HIGH . LOW)
1576 is also still accepted.
1577 The third, optional, argument UNIVERSAL, if non-nil, means describe TIME
1578 as Universal Time; nil means describe TIME in the local time zone.
1579 The value is a copy of FORMAT-STRING, but with certain constructs replaced
1580 by text that describes the specified date and time in TIME:
1582 %Y is the year, %y within the century, %C the century.
1583 %G is the year corresponding to the ISO week, %g within the century.
1584 %m is the numeric month.
1585 %b and %h are the locale's abbreviated month name, %B the full name.
1586 %d is the day of the month, zero-padded, %e is blank-padded.
1587 %u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.
1588 %a is the locale's abbreviated name of the day of week, %A the full name.
1589 %U is the week number starting on Sunday, %W starting on Monday,
1590 %V according to ISO 8601.
1591 %j is the day of the year.
1593 %H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H
1594 only blank-padded, %l is like %I blank-padded.
1595 %p is the locale's equivalent of either AM or PM.
1598 %Z is the time zone name, %z is the numeric form.
1599 %s is the number of seconds since 1970-01-01 00:00:00 +0000.
1601 %c is the locale's date and time format.
1602 %x is the locale's "preferred" date format.
1603 %D is like "%m/%d/%y".
1605 %R is like "%H:%M", %T is like "%H:%M:%S", %r is like "%I:%M:%S %p".
1606 %X is the locale's "preferred" time format.
1608 Finally, %n is a newline, %t is a tab, %% is a literal %.
1610 Certain flags and modifiers are available with some format controls.
1611 The flags are `_', `-', `^' and `#'. For certain characters X,
1612 %_X is like %X, but padded with blanks; %-X is like %X,
1613 but without padding. %^X is like %X, but with all textual
1614 characters up-cased; %#X is like %X, but with letter-case of
1615 all textual characters reversed.
1616 %NX (where N stands for an integer) is like %X,
1617 but takes up at least N (a number) positions.
1618 The modifiers are `E' and `O'. For certain characters X,
1619 %EX is a locale's alternative version of %X;
1620 %OX is like %X, but uses the locale's number symbols.
1622 For example, to produce full ISO 8601 format, use "%Y-%m-%dT%T%z". */)
1623 (format_string
, time
, universal
)
1624 Lisp_Object format_string
, time
, universal
;
1629 int ut
= ! NILP (universal
);
1631 CHECK_STRING (format_string
);
1633 if (! lisp_time_argument (time
, &value
, NULL
))
1634 error ("Invalid time specification");
1636 format_string
= code_convert_string_norecord (format_string
,
1637 Vlocale_coding_system
, 1);
1639 /* This is probably enough. */
1640 size
= SBYTES (format_string
) * 6 + 50;
1642 tm
= ut
? gmtime (&value
) : localtime (&value
);
1644 error ("Specified time is not representable");
1646 synchronize_system_time_locale ();
1650 char *buf
= (char *) alloca (size
+ 1);
1654 result
= emacs_memftimeu (buf
, size
, SDATA (format_string
),
1655 SBYTES (format_string
),
1657 if ((result
> 0 && result
< size
) || (result
== 0 && buf
[0] == '\0'))
1658 return code_convert_string_norecord (make_string (buf
, result
),
1659 Vlocale_coding_system
, 0);
1661 /* If buffer was too small, make it bigger and try again. */
1662 result
= emacs_memftimeu (NULL
, (size_t) -1,
1663 SDATA (format_string
),
1664 SBYTES (format_string
),
1670 DEFUN ("decode-time", Fdecode_time
, Sdecode_time
, 0, 1, 0,
1671 doc
: /* Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST ZONE).
1672 The optional SPECIFIED-TIME should be a list of (HIGH LOW . IGNORED),
1673 as from `current-time' and `file-attributes', or `nil' to use the
1674 current time. The obsolete form (HIGH . LOW) is also still accepted.
1675 The list has the following nine members: SEC is an integer between 0
1676 and 60; SEC is 60 for a leap second, which only some operating systems
1677 support. MINUTE is an integer between 0 and 59. HOUR is an integer
1678 between 0 and 23. DAY is an integer between 1 and 31. MONTH is an
1679 integer between 1 and 12. YEAR is an integer indicating the
1680 four-digit year. DOW is the day of week, an integer between 0 and 6,
1681 where 0 is Sunday. DST is t if daylight savings time is effect,
1682 otherwise nil. ZONE is an integer indicating the number of seconds
1683 east of Greenwich. (Note that Common Lisp has different meanings for
1686 Lisp_Object specified_time
;
1690 struct tm
*decoded_time
;
1691 Lisp_Object list_args
[9];
1693 if (! lisp_time_argument (specified_time
, &time_spec
, NULL
))
1694 error ("Invalid time specification");
1696 decoded_time
= localtime (&time_spec
);
1698 error ("Specified time is not representable");
1699 XSETFASTINT (list_args
[0], decoded_time
->tm_sec
);
1700 XSETFASTINT (list_args
[1], decoded_time
->tm_min
);
1701 XSETFASTINT (list_args
[2], decoded_time
->tm_hour
);
1702 XSETFASTINT (list_args
[3], decoded_time
->tm_mday
);
1703 XSETFASTINT (list_args
[4], decoded_time
->tm_mon
+ 1);
1704 XSETINT (list_args
[5], decoded_time
->tm_year
+ 1900);
1705 XSETFASTINT (list_args
[6], decoded_time
->tm_wday
);
1706 list_args
[7] = (decoded_time
->tm_isdst
)? Qt
: Qnil
;
1708 /* Make a copy, in case gmtime modifies the struct. */
1709 save_tm
= *decoded_time
;
1710 decoded_time
= gmtime (&time_spec
);
1711 if (decoded_time
== 0)
1712 list_args
[8] = Qnil
;
1714 XSETINT (list_args
[8], tm_diff (&save_tm
, decoded_time
));
1715 return Flist (9, list_args
);
1718 DEFUN ("encode-time", Fencode_time
, Sencode_time
, 6, MANY
, 0,
1719 doc
: /* Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.
1720 This is the reverse operation of `decode-time', which see.
1721 ZONE defaults to the current time zone rule. This can
1722 be a string or t (as from `set-time-zone-rule'), or it can be a list
1723 \(as from `current-time-zone') or an integer (as from `decode-time')
1724 applied without consideration for daylight savings time.
1726 You can pass more than 7 arguments; then the first six arguments
1727 are used as SECOND through YEAR, and the *last* argument is used as ZONE.
1728 The intervening arguments are ignored.
1729 This feature lets (apply 'encode-time (decode-time ...)) work.
1731 Out-of-range values for SECOND, MINUTE, HOUR, DAY, or MONTH are allowed;
1732 for example, a DAY of 0 means the day preceding the given month.
1733 Year numbers less than 100 are treated just like other year numbers.
1734 If you want them to stand for years in this century, you must do that yourself.
1736 Years before 1970 are not guaranteed to work. On some systems,
1737 year values as low as 1901 do work.
1739 usage: (encode-time SECOND MINUTE HOUR DAY MONTH YEAR &optional ZONE) */)
1742 register Lisp_Object
*args
;
1746 Lisp_Object zone
= (nargs
> 6 ? args
[nargs
- 1] : Qnil
);
1748 CHECK_NUMBER (args
[0]); /* second */
1749 CHECK_NUMBER (args
[1]); /* minute */
1750 CHECK_NUMBER (args
[2]); /* hour */
1751 CHECK_NUMBER (args
[3]); /* day */
1752 CHECK_NUMBER (args
[4]); /* month */
1753 CHECK_NUMBER (args
[5]); /* year */
1755 tm
.tm_sec
= XINT (args
[0]);
1756 tm
.tm_min
= XINT (args
[1]);
1757 tm
.tm_hour
= XINT (args
[2]);
1758 tm
.tm_mday
= XINT (args
[3]);
1759 tm
.tm_mon
= XINT (args
[4]) - 1;
1760 tm
.tm_year
= XINT (args
[5]) - 1900;
1766 time
= mktime (&tm
);
1771 char **oldenv
= environ
, **newenv
;
1775 else if (STRINGP (zone
))
1776 tzstring
= (char *) SDATA (zone
);
1777 else if (INTEGERP (zone
))
1779 int abszone
= abs (XINT (zone
));
1780 sprintf (tzbuf
, "XXX%s%d:%02d:%02d", "-" + (XINT (zone
) < 0),
1781 abszone
/ (60*60), (abszone
/60) % 60, abszone
% 60);
1785 error ("Invalid time zone specification");
1787 /* Set TZ before calling mktime; merely adjusting mktime's returned
1788 value doesn't suffice, since that would mishandle leap seconds. */
1789 set_time_zone_rule (tzstring
);
1791 time
= mktime (&tm
);
1793 /* Restore TZ to previous value. */
1797 #ifdef LOCALTIME_CACHE
1802 if (time
== (time_t) -1)
1803 error ("Specified time is not representable");
1805 return make_time (time
);
1808 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
, 0, 1, 0,
1809 doc
: /* Return the current time, as a human-readable string.
1810 Programs can use this function to decode a time,
1811 since the number of columns in each field is fixed.
1812 The format is `Sun Sep 16 01:03:52 1973'.
1813 However, see also the functions `decode-time' and `format-time-string'
1814 which provide a much more powerful and general facility.
1816 If SPECIFIED-TIME is given, it is a time to format instead of the
1817 current time. The argument should have the form (HIGH LOW . IGNORED).
1818 Thus, you can use times obtained from `current-time' and from
1819 `file-attributes'. SPECIFIED-TIME can also have the form (HIGH . LOW),
1820 but this is considered obsolete. */)
1822 Lisp_Object specified_time
;
1828 if (! lisp_time_argument (specified_time
, &value
, NULL
))
1830 tem
= (char *) ctime (&value
);
1832 strncpy (buf
, tem
, 24);
1835 return build_string (buf
);
1838 #define TM_YEAR_BASE 1900
1840 /* Yield A - B, measured in seconds.
1841 This function is copied from the GNU C Library. */
1846 /* Compute intervening leap days correctly even if year is negative.
1847 Take care to avoid int overflow in leap day calculations,
1848 but it's OK to assume that A and B are close to each other. */
1849 int a4
= (a
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (a
->tm_year
& 3);
1850 int b4
= (b
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (b
->tm_year
& 3);
1851 int a100
= a4
/ 25 - (a4
% 25 < 0);
1852 int b100
= b4
/ 25 - (b4
% 25 < 0);
1853 int a400
= a100
>> 2;
1854 int b400
= b100
>> 2;
1855 int intervening_leap_days
= (a4
- b4
) - (a100
- b100
) + (a400
- b400
);
1856 int years
= a
->tm_year
- b
->tm_year
;
1857 int days
= (365 * years
+ intervening_leap_days
1858 + (a
->tm_yday
- b
->tm_yday
));
1859 return (60 * (60 * (24 * days
+ (a
->tm_hour
- b
->tm_hour
))
1860 + (a
->tm_min
- b
->tm_min
))
1861 + (a
->tm_sec
- b
->tm_sec
));
1864 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 1, 0,
1865 doc
: /* Return the offset and name for the local time zone.
1866 This returns a list of the form (OFFSET NAME).
1867 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).
1868 A negative value means west of Greenwich.
1869 NAME is a string giving the name of the time zone.
1870 If SPECIFIED-TIME is given, the time zone offset is determined from it
1871 instead of using the current time. The argument should have the form
1872 (HIGH LOW . IGNORED). Thus, you can use times obtained from
1873 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
1874 have the form (HIGH . LOW), but this is considered obsolete.
1876 Some operating systems cannot provide all this information to Emacs;
1877 in this case, `current-time-zone' returns a list containing nil for
1878 the data it can't find. */)
1880 Lisp_Object specified_time
;
1886 if (lisp_time_argument (specified_time
, &value
, NULL
)
1887 && (t
= gmtime (&value
)) != 0
1888 && (gmt
= *t
, t
= localtime (&value
)) != 0)
1890 int offset
= tm_diff (t
, &gmt
);
1895 s
= (char *)t
->tm_zone
;
1896 #else /* not HAVE_TM_ZONE */
1898 if (t
->tm_isdst
== 0 || t
->tm_isdst
== 1)
1899 s
= tzname
[t
->tm_isdst
];
1901 #endif /* not HAVE_TM_ZONE */
1903 #if defined HAVE_TM_ZONE || defined HAVE_TZNAME
1906 /* On Japanese w32, we can get a Japanese string as time
1907 zone name. Don't accept that. */
1909 for (p
= s
; *p
&& (isalnum ((unsigned char)*p
) || *p
== ' '); ++p
)
1918 /* No local time zone name is available; use "+-NNNN" instead. */
1919 int am
= (offset
< 0 ? -offset
: offset
) / 60;
1920 sprintf (buf
, "%c%02d%02d", (offset
< 0 ? '-' : '+'), am
/60, am
%60);
1923 return Fcons (make_number (offset
), Fcons (build_string (s
), Qnil
));
1926 return Fmake_list (make_number (2), Qnil
);
1929 /* This holds the value of `environ' produced by the previous
1930 call to Fset_time_zone_rule, or 0 if Fset_time_zone_rule
1931 has never been called. */
1932 static char **environbuf
;
1934 DEFUN ("set-time-zone-rule", Fset_time_zone_rule
, Sset_time_zone_rule
, 1, 1, 0,
1935 doc
: /* Set the local time zone using TZ, a string specifying a time zone rule.
1936 If TZ is nil, use implementation-defined default time zone information.
1937 If TZ is t, use Universal Time. */)
1945 else if (EQ (tz
, Qt
))
1950 tzstring
= (char *) SDATA (tz
);
1953 set_time_zone_rule (tzstring
);
1956 environbuf
= environ
;
1961 #ifdef LOCALTIME_CACHE
1963 /* These two values are known to load tz files in buggy implementations,
1964 i.e. Solaris 1 executables running under either Solaris 1 or Solaris 2.
1965 Their values shouldn't matter in non-buggy implementations.
1966 We don't use string literals for these strings,
1967 since if a string in the environment is in readonly
1968 storage, it runs afoul of bugs in SVR4 and Solaris 2.3.
1969 See Sun bugs 1113095 and 1114114, ``Timezone routines
1970 improperly modify environment''. */
1972 static char set_time_zone_rule_tz1
[] = "TZ=GMT+0";
1973 static char set_time_zone_rule_tz2
[] = "TZ=GMT+1";
1977 /* Set the local time zone rule to TZSTRING.
1978 This allocates memory into `environ', which it is the caller's
1979 responsibility to free. */
1982 set_time_zone_rule (tzstring
)
1986 char **from
, **to
, **newenv
;
1988 /* Make the ENVIRON vector longer with room for TZSTRING. */
1989 for (from
= environ
; *from
; from
++)
1991 envptrs
= from
- environ
+ 2;
1992 newenv
= to
= (char **) xmalloc (envptrs
* sizeof (char *)
1993 + (tzstring
? strlen (tzstring
) + 4 : 0));
1995 /* Add TZSTRING to the end of environ, as a value for TZ. */
1998 char *t
= (char *) (to
+ envptrs
);
2000 strcat (t
, tzstring
);
2004 /* Copy the old environ vector elements into NEWENV,
2005 but don't copy the TZ variable.
2006 So we have only one definition of TZ, which came from TZSTRING. */
2007 for (from
= environ
; *from
; from
++)
2008 if (strncmp (*from
, "TZ=", 3) != 0)
2014 /* If we do have a TZSTRING, NEWENV points to the vector slot where
2015 the TZ variable is stored. If we do not have a TZSTRING,
2016 TO points to the vector slot which has the terminating null. */
2018 #ifdef LOCALTIME_CACHE
2020 /* In SunOS 4.1.3_U1 and 4.1.4, if TZ has a value like
2021 "US/Pacific" that loads a tz file, then changes to a value like
2022 "XXX0" that does not load a tz file, and then changes back to
2023 its original value, the last change is (incorrectly) ignored.
2024 Also, if TZ changes twice in succession to values that do
2025 not load a tz file, tzset can dump core (see Sun bug#1225179).
2026 The following code works around these bugs. */
2030 /* Temporarily set TZ to a value that loads a tz file
2031 and that differs from tzstring. */
2033 *newenv
= (strcmp (tzstring
, set_time_zone_rule_tz1
+ 3) == 0
2034 ? set_time_zone_rule_tz2
: set_time_zone_rule_tz1
);
2040 /* The implied tzstring is unknown, so temporarily set TZ to
2041 two different values that each load a tz file. */
2042 *to
= set_time_zone_rule_tz1
;
2045 *to
= set_time_zone_rule_tz2
;
2050 /* Now TZ has the desired value, and tzset can be invoked safely. */
2057 /* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC
2058 (if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a
2059 type of object is Lisp_String). INHERIT is passed to
2060 INSERT_FROM_STRING_FUNC as the last argument. */
2063 general_insert_function (insert_func
, insert_from_string_func
,
2064 inherit
, nargs
, args
)
2065 void (*insert_func
) P_ ((const unsigned char *, int));
2066 void (*insert_from_string_func
) P_ ((Lisp_Object
, int, int, int, int, int));
2068 register Lisp_Object
*args
;
2070 register int argnum
;
2071 register Lisp_Object val
;
2073 for (argnum
= 0; argnum
< nargs
; argnum
++)
2079 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2082 if (!NILP (current_buffer
->enable_multibyte_characters
))
2083 len
= CHAR_STRING (XFASTINT (val
), str
);
2086 str
[0] = (SINGLE_BYTE_CHAR_P (XINT (val
))
2088 : multibyte_char_to_unibyte (XINT (val
), Qnil
));
2091 (*insert_func
) (str
, len
);
2093 else if (STRINGP (val
))
2095 (*insert_from_string_func
) (val
, 0, 0,
2102 val
= wrong_type_argument (Qchar_or_string_p
, val
);
2116 /* Callers passing one argument to Finsert need not gcpro the
2117 argument "array", since the only element of the array will
2118 not be used after calling insert or insert_from_string, so
2119 we don't care if it gets trashed. */
2121 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
2122 doc
: /* Insert the arguments, either strings or characters, at point.
2123 Point and before-insertion markers move forward to end up
2124 after the inserted text.
2125 Any other markers at the point of insertion remain before the text.
2127 If the current buffer is multibyte, unibyte strings are converted
2128 to multibyte for insertion (see `string-make-multibyte').
2129 If the current buffer is unibyte, multibyte strings are converted
2130 to unibyte for insertion (see `string-make-unibyte').
2132 When operating on binary data, it may be necessary to preserve the
2133 original bytes of a unibyte string when inserting it into a multibyte
2134 buffer; to accomplish this, apply `string-as-multibyte' to the string
2135 and insert the result.
2137 usage: (insert &rest ARGS) */)
2140 register Lisp_Object
*args
;
2142 general_insert_function (insert
, insert_from_string
, 0, nargs
, args
);
2146 DEFUN ("insert-and-inherit", Finsert_and_inherit
, Sinsert_and_inherit
,
2148 doc
: /* Insert the arguments at point, inheriting properties from adjoining text.
2149 Point and before-insertion markers move forward to end up
2150 after the inserted text.
2151 Any other markers at the point of insertion remain before the text.
2153 If the current buffer is multibyte, unibyte strings are converted
2154 to multibyte for insertion (see `unibyte-char-to-multibyte').
2155 If the current buffer is unibyte, multibyte strings are converted
2156 to unibyte for insertion.
2158 usage: (insert-and-inherit &rest ARGS) */)
2161 register Lisp_Object
*args
;
2163 general_insert_function (insert_and_inherit
, insert_from_string
, 1,
2168 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
2169 doc
: /* Insert strings or characters at point, relocating markers after the text.
2170 Point and markers move forward to end up after the inserted text.
2172 If the current buffer is multibyte, unibyte strings are converted
2173 to multibyte for insertion (see `unibyte-char-to-multibyte').
2174 If the current buffer is unibyte, multibyte strings are converted
2175 to unibyte for insertion.
2177 usage: (insert-before-markers &rest ARGS) */)
2180 register Lisp_Object
*args
;
2182 general_insert_function (insert_before_markers
,
2183 insert_from_string_before_markers
, 0,
2188 DEFUN ("insert-before-markers-and-inherit", Finsert_and_inherit_before_markers
,
2189 Sinsert_and_inherit_before_markers
, 0, MANY
, 0,
2190 doc
: /* Insert text at point, relocating markers and inheriting properties.
2191 Point and markers move forward to end up after the inserted text.
2193 If the current buffer is multibyte, unibyte strings are converted
2194 to multibyte for insertion (see `unibyte-char-to-multibyte').
2195 If the current buffer is unibyte, multibyte strings are converted
2196 to unibyte for insertion.
2198 usage: (insert-before-markers-and-inherit &rest ARGS) */)
2201 register Lisp_Object
*args
;
2203 general_insert_function (insert_before_markers_and_inherit
,
2204 insert_from_string_before_markers
, 1,
2209 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 2, 3, 0,
2210 doc
: /* Insert COUNT (second arg) copies of CHARACTER (first arg).
2211 Both arguments are required.
2212 Point, and before-insertion markers, are relocated as in the function `insert'.
2213 The optional third arg INHERIT, if non-nil, says to inherit text properties
2214 from adjoining text, if those properties are sticky. */)
2215 (character
, count
, inherit
)
2216 Lisp_Object character
, count
, inherit
;
2218 register unsigned char *string
;
2219 register int strlen
;
2222 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2224 CHECK_NUMBER (character
);
2225 CHECK_NUMBER (count
);
2227 if (!NILP (current_buffer
->enable_multibyte_characters
))
2228 len
= CHAR_STRING (XFASTINT (character
), str
);
2230 str
[0] = XFASTINT (character
), len
= 1;
2231 n
= XINT (count
) * len
;
2234 strlen
= min (n
, 256 * len
);
2235 string
= (unsigned char *) alloca (strlen
);
2236 for (i
= 0; i
< strlen
; i
++)
2237 string
[i
] = str
[i
% len
];
2241 if (!NILP (inherit
))
2242 insert_and_inherit (string
, strlen
);
2244 insert (string
, strlen
);
2249 if (!NILP (inherit
))
2250 insert_and_inherit (string
, n
);
2258 /* Making strings from buffer contents. */
2260 /* Return a Lisp_String containing the text of the current buffer from
2261 START to END. If text properties are in use and the current buffer
2262 has properties in the range specified, the resulting string will also
2263 have them, if PROPS is nonzero.
2265 We don't want to use plain old make_string here, because it calls
2266 make_uninit_string, which can cause the buffer arena to be
2267 compacted. make_string has no way of knowing that the data has
2268 been moved, and thus copies the wrong data into the string. This
2269 doesn't effect most of the other users of make_string, so it should
2270 be left as is. But we should use this function when conjuring
2271 buffer substrings. */
2274 make_buffer_string (start
, end
, props
)
2278 int start_byte
= CHAR_TO_BYTE (start
);
2279 int end_byte
= CHAR_TO_BYTE (end
);
2281 return make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
);
2284 /* Return a Lisp_String containing the text of the current buffer from
2285 START / START_BYTE to END / END_BYTE.
2287 If text properties are in use and the current buffer
2288 has properties in the range specified, the resulting string will also
2289 have them, if PROPS is nonzero.
2291 We don't want to use plain old make_string here, because it calls
2292 make_uninit_string, which can cause the buffer arena to be
2293 compacted. make_string has no way of knowing that the data has
2294 been moved, and thus copies the wrong data into the string. This
2295 doesn't effect most of the other users of make_string, so it should
2296 be left as is. But we should use this function when conjuring
2297 buffer substrings. */
2300 make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
)
2301 int start
, start_byte
, end
, end_byte
;
2304 Lisp_Object result
, tem
, tem1
;
2306 if (start
< GPT
&& GPT
< end
)
2309 if (! NILP (current_buffer
->enable_multibyte_characters
))
2310 result
= make_uninit_multibyte_string (end
- start
, end_byte
- start_byte
);
2312 result
= make_uninit_string (end
- start
);
2313 bcopy (BYTE_POS_ADDR (start_byte
), SDATA (result
),
2314 end_byte
- start_byte
);
2316 /* If desired, update and copy the text properties. */
2319 update_buffer_properties (start
, end
);
2321 tem
= Fnext_property_change (make_number (start
), Qnil
, make_number (end
));
2322 tem1
= Ftext_properties_at (make_number (start
), Qnil
);
2324 if (XINT (tem
) != end
|| !NILP (tem1
))
2325 copy_intervals_to_string (result
, current_buffer
, start
,
2332 /* Call Vbuffer_access_fontify_functions for the range START ... END
2333 in the current buffer, if necessary. */
2336 update_buffer_properties (start
, end
)
2339 /* If this buffer has some access functions,
2340 call them, specifying the range of the buffer being accessed. */
2341 if (!NILP (Vbuffer_access_fontify_functions
))
2343 Lisp_Object args
[3];
2346 args
[0] = Qbuffer_access_fontify_functions
;
2347 XSETINT (args
[1], start
);
2348 XSETINT (args
[2], end
);
2350 /* But don't call them if we can tell that the work
2351 has already been done. */
2352 if (!NILP (Vbuffer_access_fontified_property
))
2354 tem
= Ftext_property_any (args
[1], args
[2],
2355 Vbuffer_access_fontified_property
,
2358 Frun_hook_with_args (3, args
);
2361 Frun_hook_with_args (3, args
);
2365 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
2366 doc
: /* Return the contents of part of the current buffer as a string.
2367 The two arguments START and END are character positions;
2368 they can be in either order.
2369 The string returned is multibyte if the buffer is multibyte.
2371 This function copies the text properties of that part of the buffer
2372 into the result string; if you don't want the text properties,
2373 use `buffer-substring-no-properties' instead. */)
2375 Lisp_Object start
, end
;
2379 validate_region (&start
, &end
);
2383 return make_buffer_string (b
, e
, 1);
2386 DEFUN ("buffer-substring-no-properties", Fbuffer_substring_no_properties
,
2387 Sbuffer_substring_no_properties
, 2, 2, 0,
2388 doc
: /* Return the characters of part of the buffer, without the text properties.
2389 The two arguments START and END are character positions;
2390 they can be in either order. */)
2392 Lisp_Object start
, end
;
2396 validate_region (&start
, &end
);
2400 return make_buffer_string (b
, e
, 0);
2403 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
2404 doc
: /* Return the contents of the current buffer as a string.
2405 If narrowing is in effect, this function returns only the visible part
2409 return make_buffer_string (BEGV
, ZV
, 1);
2412 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
2414 doc
: /* Insert before point a substring of the contents of BUFFER.
2415 BUFFER may be a buffer or a buffer name.
2416 Arguments START and END are character positions specifying the substring.
2417 They default to the values of (point-min) and (point-max) in BUFFER. */)
2418 (buffer
, start
, end
)
2419 Lisp_Object buffer
, start
, end
;
2421 register int b
, e
, temp
;
2422 register struct buffer
*bp
, *obuf
;
2425 buf
= Fget_buffer (buffer
);
2429 if (NILP (bp
->name
))
2430 error ("Selecting deleted buffer");
2436 CHECK_NUMBER_COERCE_MARKER (start
);
2443 CHECK_NUMBER_COERCE_MARKER (end
);
2448 temp
= b
, b
= e
, e
= temp
;
2450 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
2451 args_out_of_range (start
, end
);
2453 obuf
= current_buffer
;
2454 set_buffer_internal_1 (bp
);
2455 update_buffer_properties (b
, e
);
2456 set_buffer_internal_1 (obuf
);
2458 insert_from_buffer (bp
, b
, e
- b
, 0);
2462 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
2464 doc
: /* Compare two substrings of two buffers; return result as number.
2465 the value is -N if first string is less after N-1 chars,
2466 +N if first string is greater after N-1 chars, or 0 if strings match.
2467 Each substring is represented as three arguments: BUFFER, START and END.
2468 That makes six args in all, three for each substring.
2470 The value of `case-fold-search' in the current buffer
2471 determines whether case is significant or ignored. */)
2472 (buffer1
, start1
, end1
, buffer2
, start2
, end2
)
2473 Lisp_Object buffer1
, start1
, end1
, buffer2
, start2
, end2
;
2475 register int begp1
, endp1
, begp2
, endp2
, temp
;
2476 register struct buffer
*bp1
, *bp2
;
2477 register Lisp_Object trt
2478 = (!NILP (current_buffer
->case_fold_search
)
2479 ? current_buffer
->case_canon_table
: Qnil
);
2481 int i1
, i2
, i1_byte
, i2_byte
;
2483 /* Find the first buffer and its substring. */
2486 bp1
= current_buffer
;
2490 buf1
= Fget_buffer (buffer1
);
2493 bp1
= XBUFFER (buf1
);
2494 if (NILP (bp1
->name
))
2495 error ("Selecting deleted buffer");
2499 begp1
= BUF_BEGV (bp1
);
2502 CHECK_NUMBER_COERCE_MARKER (start1
);
2503 begp1
= XINT (start1
);
2506 endp1
= BUF_ZV (bp1
);
2509 CHECK_NUMBER_COERCE_MARKER (end1
);
2510 endp1
= XINT (end1
);
2514 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
2516 if (!(BUF_BEGV (bp1
) <= begp1
2518 && endp1
<= BUF_ZV (bp1
)))
2519 args_out_of_range (start1
, end1
);
2521 /* Likewise for second substring. */
2524 bp2
= current_buffer
;
2528 buf2
= Fget_buffer (buffer2
);
2531 bp2
= XBUFFER (buf2
);
2532 if (NILP (bp2
->name
))
2533 error ("Selecting deleted buffer");
2537 begp2
= BUF_BEGV (bp2
);
2540 CHECK_NUMBER_COERCE_MARKER (start2
);
2541 begp2
= XINT (start2
);
2544 endp2
= BUF_ZV (bp2
);
2547 CHECK_NUMBER_COERCE_MARKER (end2
);
2548 endp2
= XINT (end2
);
2552 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
2554 if (!(BUF_BEGV (bp2
) <= begp2
2556 && endp2
<= BUF_ZV (bp2
)))
2557 args_out_of_range (start2
, end2
);
2561 i1_byte
= buf_charpos_to_bytepos (bp1
, i1
);
2562 i2_byte
= buf_charpos_to_bytepos (bp2
, i2
);
2564 while (i1
< endp1
&& i2
< endp2
)
2566 /* When we find a mismatch, we must compare the
2567 characters, not just the bytes. */
2572 if (! NILP (bp1
->enable_multibyte_characters
))
2574 c1
= BUF_FETCH_MULTIBYTE_CHAR (bp1
, i1_byte
);
2575 BUF_INC_POS (bp1
, i1_byte
);
2580 c1
= BUF_FETCH_BYTE (bp1
, i1
);
2581 c1
= unibyte_char_to_multibyte (c1
);
2585 if (! NILP (bp2
->enable_multibyte_characters
))
2587 c2
= BUF_FETCH_MULTIBYTE_CHAR (bp2
, i2_byte
);
2588 BUF_INC_POS (bp2
, i2_byte
);
2593 c2
= BUF_FETCH_BYTE (bp2
, i2
);
2594 c2
= unibyte_char_to_multibyte (c2
);
2600 c1
= CHAR_TABLE_TRANSLATE (trt
, c1
);
2601 c2
= CHAR_TABLE_TRANSLATE (trt
, c2
);
2604 return make_number (- 1 - chars
);
2606 return make_number (chars
+ 1);
2611 /* The strings match as far as they go.
2612 If one is shorter, that one is less. */
2613 if (chars
< endp1
- begp1
)
2614 return make_number (chars
+ 1);
2615 else if (chars
< endp2
- begp2
)
2616 return make_number (- chars
- 1);
2618 /* Same length too => they are equal. */
2619 return make_number (0);
2623 subst_char_in_region_unwind (arg
)
2626 return current_buffer
->undo_list
= arg
;
2630 subst_char_in_region_unwind_1 (arg
)
2633 return current_buffer
->filename
= arg
;
2636 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
2637 Ssubst_char_in_region
, 4, 5, 0,
2638 doc
: /* From START to END, replace FROMCHAR with TOCHAR each time it occurs.
2639 If optional arg NOUNDO is non-nil, don't record this change for undo
2640 and don't mark the buffer as really changed.
2641 Both characters must have the same length of multi-byte form. */)
2642 (start
, end
, fromchar
, tochar
, noundo
)
2643 Lisp_Object start
, end
, fromchar
, tochar
, noundo
;
2645 register int pos
, pos_byte
, stop
, i
, len
, end_byte
;
2647 unsigned char fromstr
[MAX_MULTIBYTE_LENGTH
], tostr
[MAX_MULTIBYTE_LENGTH
];
2649 int count
= SPECPDL_INDEX ();
2650 #define COMBINING_NO 0
2651 #define COMBINING_BEFORE 1
2652 #define COMBINING_AFTER 2
2653 #define COMBINING_BOTH (COMBINING_BEFORE | COMBINING_AFTER)
2654 int maybe_byte_combining
= COMBINING_NO
;
2655 int last_changed
= 0;
2656 int multibyte_p
= !NILP (current_buffer
->enable_multibyte_characters
);
2658 validate_region (&start
, &end
);
2659 CHECK_NUMBER (fromchar
);
2660 CHECK_NUMBER (tochar
);
2664 len
= CHAR_STRING (XFASTINT (fromchar
), fromstr
);
2665 if (CHAR_STRING (XFASTINT (tochar
), tostr
) != len
)
2666 error ("Characters in `subst-char-in-region' have different byte-lengths");
2667 if (!ASCII_BYTE_P (*tostr
))
2669 /* If *TOSTR is in the range 0x80..0x9F and TOCHAR is not a
2670 complete multibyte character, it may be combined with the
2671 after bytes. If it is in the range 0xA0..0xFF, it may be
2672 combined with the before and after bytes. */
2673 if (!CHAR_HEAD_P (*tostr
))
2674 maybe_byte_combining
= COMBINING_BOTH
;
2675 else if (BYTES_BY_CHAR_HEAD (*tostr
) > len
)
2676 maybe_byte_combining
= COMBINING_AFTER
;
2682 fromstr
[0] = XFASTINT (fromchar
);
2683 tostr
[0] = XFASTINT (tochar
);
2687 pos_byte
= CHAR_TO_BYTE (pos
);
2688 stop
= CHAR_TO_BYTE (XINT (end
));
2691 /* If we don't want undo, turn off putting stuff on the list.
2692 That's faster than getting rid of things,
2693 and it prevents even the entry for a first change.
2694 Also inhibit locking the file. */
2697 record_unwind_protect (subst_char_in_region_unwind
,
2698 current_buffer
->undo_list
);
2699 current_buffer
->undo_list
= Qt
;
2700 /* Don't do file-locking. */
2701 record_unwind_protect (subst_char_in_region_unwind_1
,
2702 current_buffer
->filename
);
2703 current_buffer
->filename
= Qnil
;
2706 if (pos_byte
< GPT_BYTE
)
2707 stop
= min (stop
, GPT_BYTE
);
2710 int pos_byte_next
= pos_byte
;
2712 if (pos_byte
>= stop
)
2714 if (pos_byte
>= end_byte
) break;
2717 p
= BYTE_POS_ADDR (pos_byte
);
2719 INC_POS (pos_byte_next
);
2722 if (pos_byte_next
- pos_byte
== len
2723 && p
[0] == fromstr
[0]
2725 || (p
[1] == fromstr
[1]
2726 && (len
== 2 || (p
[2] == fromstr
[2]
2727 && (len
== 3 || p
[3] == fromstr
[3]))))))
2732 modify_region (current_buffer
, changed
, XINT (end
));
2734 if (! NILP (noundo
))
2736 if (MODIFF
- 1 == SAVE_MODIFF
)
2738 if (MODIFF
- 1 == current_buffer
->auto_save_modified
)
2739 current_buffer
->auto_save_modified
++;
2743 /* Take care of the case where the new character
2744 combines with neighboring bytes. */
2745 if (maybe_byte_combining
2746 && (maybe_byte_combining
== COMBINING_AFTER
2747 ? (pos_byte_next
< Z_BYTE
2748 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2749 : ((pos_byte_next
< Z_BYTE
2750 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2751 || (pos_byte
> BEG_BYTE
2752 && ! ASCII_BYTE_P (FETCH_BYTE (pos_byte
- 1))))))
2754 Lisp_Object tem
, string
;
2756 struct gcpro gcpro1
;
2758 tem
= current_buffer
->undo_list
;
2761 /* Make a multibyte string containing this single character. */
2762 string
= make_multibyte_string (tostr
, 1, len
);
2763 /* replace_range is less efficient, because it moves the gap,
2764 but it handles combining correctly. */
2765 replace_range (pos
, pos
+ 1, string
,
2767 pos_byte_next
= CHAR_TO_BYTE (pos
);
2768 if (pos_byte_next
> pos_byte
)
2769 /* Before combining happened. We should not increment
2770 POS. So, to cancel the later increment of POS,
2774 INC_POS (pos_byte_next
);
2776 if (! NILP (noundo
))
2777 current_buffer
->undo_list
= tem
;
2784 record_change (pos
, 1);
2785 for (i
= 0; i
< len
; i
++) *p
++ = tostr
[i
];
2787 last_changed
= pos
+ 1;
2789 pos_byte
= pos_byte_next
;
2795 signal_after_change (changed
,
2796 last_changed
- changed
, last_changed
- changed
);
2797 update_compositions (changed
, last_changed
, CHECK_ALL
);
2800 unbind_to (count
, Qnil
);
2804 DEFUN ("translate-region-internal", Ftranslate_region_internal
,
2805 Stranslate_region_internal
, 3, 3, 0,
2806 doc
: /* Internal use only.
2807 From START to END, translate characters according to TABLE.
2808 TABLE is a string; the Nth character in it is the mapping
2809 for the character with code N.
2810 It returns the number of characters changed. */)
2814 register Lisp_Object table
;
2816 register unsigned char *tt
; /* Trans table. */
2817 register int nc
; /* New character. */
2818 int cnt
; /* Number of changes made. */
2819 int size
; /* Size of translate table. */
2820 int pos
, pos_byte
, end_pos
;
2821 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
2822 int string_multibyte
;
2824 validate_region (&start
, &end
);
2825 if (CHAR_TABLE_P (table
))
2832 CHECK_STRING (table
);
2834 if (! multibyte
&& (SCHARS (table
) < SBYTES (table
)))
2835 table
= string_make_unibyte (table
);
2836 string_multibyte
= SCHARS (table
) < SBYTES (table
);
2837 size
= SCHARS (table
);
2842 pos_byte
= CHAR_TO_BYTE (pos
);
2843 end_pos
= XINT (end
);
2844 modify_region (current_buffer
, pos
, XINT (end
));
2847 for (; pos
< end_pos
; )
2849 register unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
2850 unsigned char *str
, buf
[MAX_MULTIBYTE_LENGTH
];
2855 oc
= STRING_CHAR_AND_LENGTH (p
, MAX_MULTIBYTE_LENGTH
, len
);
2862 /* Reload as signal_after_change in last iteration may GC. */
2864 if (string_multibyte
)
2866 str
= tt
+ string_char_to_byte (table
, oc
);
2867 nc
= STRING_CHAR_AND_LENGTH (str
, MAX_MULTIBYTE_LENGTH
,
2873 if (! ASCII_BYTE_P (nc
) && multibyte
)
2875 str_len
= CHAR_STRING (nc
, buf
);
2891 val
= CHAR_TABLE_REF (table
, oc
);
2893 && (c
= XINT (val
), CHAR_VALID_P (c
, 0)))
2896 str_len
= CHAR_STRING (nc
, buf
);
2907 /* This is less efficient, because it moves the gap,
2908 but it should multibyte characters correctly. */
2909 string
= make_multibyte_string (str
, 1, str_len
);
2910 replace_range (pos
, pos
+ 1, string
, 1, 0, 1);
2915 record_change (pos
, 1);
2916 while (str_len
-- > 0)
2918 signal_after_change (pos
, 1, 1);
2919 update_compositions (pos
, pos
+ 1, CHECK_BORDER
);
2928 return make_number (cnt
);
2931 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
2932 doc
: /* Delete the text between point and mark.
2934 When called from a program, expects two arguments,
2935 positions (integers or markers) specifying the stretch to be deleted. */)
2937 Lisp_Object start
, end
;
2939 validate_region (&start
, &end
);
2940 del_range (XINT (start
), XINT (end
));
2944 DEFUN ("delete-and-extract-region", Fdelete_and_extract_region
,
2945 Sdelete_and_extract_region
, 2, 2, 0,
2946 doc
: /* Delete the text between START and END and return it. */)
2948 Lisp_Object start
, end
;
2950 validate_region (&start
, &end
);
2951 if (XINT (start
) == XINT (end
))
2952 return build_string ("");
2953 return del_range_1 (XINT (start
), XINT (end
), 1, 1);
2956 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
2957 doc
: /* Remove restrictions (narrowing) from current buffer.
2958 This allows the buffer's full text to be seen and edited. */)
2961 if (BEG
!= BEGV
|| Z
!= ZV
)
2962 current_buffer
->clip_changed
= 1;
2964 BEGV_BYTE
= BEG_BYTE
;
2965 SET_BUF_ZV_BOTH (current_buffer
, Z
, Z_BYTE
);
2966 /* Changing the buffer bounds invalidates any recorded current column. */
2967 invalidate_current_column ();
2971 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
2972 doc
: /* Restrict editing in this buffer to the current region.
2973 The rest of the text becomes temporarily invisible and untouchable
2974 but is not deleted; if you save the buffer in a file, the invisible
2975 text is included in the file. \\[widen] makes all visible again.
2976 See also `save-restriction'.
2978 When calling from a program, pass two arguments; positions (integers
2979 or markers) bounding the text that should remain visible. */)
2981 register Lisp_Object start
, end
;
2983 CHECK_NUMBER_COERCE_MARKER (start
);
2984 CHECK_NUMBER_COERCE_MARKER (end
);
2986 if (XINT (start
) > XINT (end
))
2989 tem
= start
; start
= end
; end
= tem
;
2992 if (!(BEG
<= XINT (start
) && XINT (start
) <= XINT (end
) && XINT (end
) <= Z
))
2993 args_out_of_range (start
, end
);
2995 if (BEGV
!= XFASTINT (start
) || ZV
!= XFASTINT (end
))
2996 current_buffer
->clip_changed
= 1;
2998 SET_BUF_BEGV (current_buffer
, XFASTINT (start
));
2999 SET_BUF_ZV (current_buffer
, XFASTINT (end
));
3000 if (PT
< XFASTINT (start
))
3001 SET_PT (XFASTINT (start
));
3002 if (PT
> XFASTINT (end
))
3003 SET_PT (XFASTINT (end
));
3004 /* Changing the buffer bounds invalidates any recorded current column. */
3005 invalidate_current_column ();
3010 save_restriction_save ()
3012 if (BEGV
== BEG
&& ZV
== Z
)
3013 /* The common case that the buffer isn't narrowed.
3014 We return just the buffer object, which save_restriction_restore
3015 recognizes as meaning `no restriction'. */
3016 return Fcurrent_buffer ();
3018 /* We have to save a restriction, so return a pair of markers, one
3019 for the beginning and one for the end. */
3021 Lisp_Object beg
, end
;
3023 beg
= buildmark (BEGV
, BEGV_BYTE
);
3024 end
= buildmark (ZV
, ZV_BYTE
);
3026 /* END must move forward if text is inserted at its exact location. */
3027 XMARKER(end
)->insertion_type
= 1;
3029 return Fcons (beg
, end
);
3034 save_restriction_restore (data
)
3038 /* A pair of marks bounding a saved restriction. */
3040 struct Lisp_Marker
*beg
= XMARKER (XCAR (data
));
3041 struct Lisp_Marker
*end
= XMARKER (XCDR (data
));
3042 struct buffer
*buf
= beg
->buffer
; /* END should have the same buffer. */
3044 if (buf
/* Verify marker still points to a buffer. */
3045 && (beg
->charpos
!= BUF_BEGV (buf
) || end
->charpos
!= BUF_ZV (buf
)))
3046 /* The restriction has changed from the saved one, so restore
3047 the saved restriction. */
3049 int pt
= BUF_PT (buf
);
3051 SET_BUF_BEGV_BOTH (buf
, beg
->charpos
, beg
->bytepos
);
3052 SET_BUF_ZV_BOTH (buf
, end
->charpos
, end
->bytepos
);
3054 if (pt
< beg
->charpos
|| pt
> end
->charpos
)
3055 /* The point is outside the new visible range, move it inside. */
3056 SET_BUF_PT_BOTH (buf
,
3057 clip_to_bounds (beg
->charpos
, pt
, end
->charpos
),
3058 clip_to_bounds (beg
->bytepos
, BUF_PT_BYTE (buf
),
3061 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3065 /* A buffer, which means that there was no old restriction. */
3067 struct buffer
*buf
= XBUFFER (data
);
3069 if (buf
/* Verify marker still points to a buffer. */
3070 && (BUF_BEGV (buf
) != BUF_BEG (buf
) || BUF_ZV (buf
) != BUF_Z (buf
)))
3071 /* The buffer has been narrowed, get rid of the narrowing. */
3073 SET_BUF_BEGV_BOTH (buf
, BUF_BEG (buf
), BUF_BEG_BYTE (buf
));
3074 SET_BUF_ZV_BOTH (buf
, BUF_Z (buf
), BUF_Z_BYTE (buf
));
3076 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3083 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
3084 doc
: /* Execute BODY, saving and restoring current buffer's restrictions.
3085 The buffer's restrictions make parts of the beginning and end invisible.
3086 (They are set up with `narrow-to-region' and eliminated with `widen'.)
3087 This special form, `save-restriction', saves the current buffer's restrictions
3088 when it is entered, and restores them when it is exited.
3089 So any `narrow-to-region' within BODY lasts only until the end of the form.
3090 The old restrictions settings are restored
3091 even in case of abnormal exit (throw or error).
3093 The value returned is the value of the last form in BODY.
3095 Note: if you are using both `save-excursion' and `save-restriction',
3096 use `save-excursion' outermost:
3097 (save-excursion (save-restriction ...))
3099 usage: (save-restriction &rest BODY) */)
3103 register Lisp_Object val
;
3104 int count
= SPECPDL_INDEX ();
3106 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
3107 val
= Fprogn (body
);
3108 return unbind_to (count
, val
);
3111 /* Buffer for the most recent text displayed by Fmessage_box. */
3112 static char *message_text
;
3114 /* Allocated length of that buffer. */
3115 static int message_length
;
3117 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
3118 doc
: /* Print a one-line message at the bottom of the screen.
3119 The message also goes into the `*Messages*' buffer.
3120 \(In keyboard macros, that's all it does.)
3122 The first argument is a format control string, and the rest are data
3123 to be formatted under control of the string. See `format' for details.
3125 If the first argument is nil or the empty string, the function clears
3126 any existing message; this lets the minibuffer contents show. See
3127 also `current-message'.
3129 usage: (message FORMAT-STRING &rest ARGS) */)
3135 || (STRINGP (args
[0])
3136 && SBYTES (args
[0]) == 0))
3143 register Lisp_Object val
;
3144 val
= Fformat (nargs
, args
);
3145 message3 (val
, SBYTES (val
), STRING_MULTIBYTE (val
));
3150 DEFUN ("message-box", Fmessage_box
, Smessage_box
, 1, MANY
, 0,
3151 doc
: /* Display a message, in a dialog box if possible.
3152 If a dialog box is not available, use the echo area.
3153 The first argument is a format control string, and the rest are data
3154 to be formatted under control of the string. See `format' for details.
3156 If the first argument is nil or the empty string, clear any existing
3157 message; let the minibuffer contents show.
3159 usage: (message-box FORMAT-STRING &rest ARGS) */)
3171 register Lisp_Object val
;
3172 val
= Fformat (nargs
, args
);
3174 /* The MS-DOS frames support popup menus even though they are
3175 not FRAME_WINDOW_P. */
3176 if (FRAME_WINDOW_P (XFRAME (selected_frame
))
3177 || FRAME_MSDOS_P (XFRAME (selected_frame
)))
3179 Lisp_Object pane
, menu
, obj
;
3180 struct gcpro gcpro1
;
3181 pane
= Fcons (Fcons (build_string ("OK"), Qt
), Qnil
);
3183 menu
= Fcons (val
, pane
);
3184 obj
= Fx_popup_dialog (Qt
, menu
, Qt
);
3188 #endif /* HAVE_MENUS */
3189 /* Copy the data so that it won't move when we GC. */
3192 message_text
= (char *)xmalloc (80);
3193 message_length
= 80;
3195 if (SBYTES (val
) > message_length
)
3197 message_length
= SBYTES (val
);
3198 message_text
= (char *)xrealloc (message_text
, message_length
);
3200 bcopy (SDATA (val
), message_text
, SBYTES (val
));
3201 message2 (message_text
, SBYTES (val
),
3202 STRING_MULTIBYTE (val
));
3207 extern Lisp_Object last_nonmenu_event
;
3210 DEFUN ("message-or-box", Fmessage_or_box
, Smessage_or_box
, 1, MANY
, 0,
3211 doc
: /* Display a message in a dialog box or in the echo area.
3212 If this command was invoked with the mouse, use a dialog box if
3213 `use-dialog-box' is non-nil.
3214 Otherwise, use the echo area.
3215 The first argument is a format control string, and the rest are data
3216 to be formatted under control of the string. See `format' for details.
3218 If the first argument is nil or the empty string, clear any existing
3219 message; let the minibuffer contents show.
3221 usage: (message-or-box FORMAT-STRING &rest ARGS) */)
3227 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3229 return Fmessage_box (nargs
, args
);
3231 return Fmessage (nargs
, args
);
3234 DEFUN ("current-message", Fcurrent_message
, Scurrent_message
, 0, 0, 0,
3235 doc
: /* Return the string currently displayed in the echo area, or nil if none. */)
3238 return current_message ();
3242 DEFUN ("propertize", Fpropertize
, Spropertize
, 1, MANY
, 0,
3243 doc
: /* Return a copy of STRING with text properties added.
3244 First argument is the string to copy.
3245 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
3246 properties to add to the result.
3247 usage: (propertize STRING &rest PROPERTIES) */)
3252 Lisp_Object properties
, string
;
3253 struct gcpro gcpro1
, gcpro2
;
3256 /* Number of args must be odd. */
3257 if ((nargs
& 1) == 0 || nargs
< 1)
3258 error ("Wrong number of arguments");
3260 properties
= string
= Qnil
;
3261 GCPRO2 (properties
, string
);
3263 /* First argument must be a string. */
3264 CHECK_STRING (args
[0]);
3265 string
= Fcopy_sequence (args
[0]);
3267 for (i
= 1; i
< nargs
; i
+= 2)
3268 properties
= Fcons (args
[i
], Fcons (args
[i
+ 1], properties
));
3270 Fadd_text_properties (make_number (0),
3271 make_number (SCHARS (string
)),
3272 properties
, string
);
3273 RETURN_UNGCPRO (string
);
3277 /* Number of bytes that STRING will occupy when put into the result.
3278 MULTIBYTE is nonzero if the result should be multibyte. */
3280 #define CONVERTED_BYTE_SIZE(MULTIBYTE, STRING) \
3281 (((MULTIBYTE) && ! STRING_MULTIBYTE (STRING)) \
3282 ? count_size_as_multibyte (SDATA (STRING), SBYTES (STRING)) \
3285 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
3286 doc
: /* Format a string out of a format-string and arguments.
3287 The first argument is a format control string.
3288 The other arguments are substituted into it to make the result, a string.
3289 It may contain %-sequences meaning to substitute the next argument.
3290 %s means print a string argument. Actually, prints any object, with `princ'.
3291 %d means print as number in decimal (%o octal, %x hex).
3292 %X is like %x, but uses upper case.
3293 %e means print a number in exponential notation.
3294 %f means print a number in decimal-point notation.
3295 %g means print a number in exponential notation
3296 or decimal-point notation, whichever uses fewer characters.
3297 %c means print a number as a single character.
3298 %S means print any object as an s-expression (using `prin1').
3299 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.
3300 Use %% to put a single % into the output.
3302 The basic structure of a %-sequence is
3303 % <flags> <width> <precision> character
3304 where flags is [- #0]+, width is [0-9]+, and precision is .[0-9]+
3306 usage: (format STRING &rest OBJECTS) */)
3309 register Lisp_Object
*args
;
3311 register int n
; /* The number of the next arg to substitute */
3312 register int total
; /* An estimate of the final length */
3314 register unsigned char *format
, *end
, *format_start
;
3316 /* Nonzero if the output should be a multibyte string,
3317 which is true if any of the inputs is one. */
3319 /* When we make a multibyte string, we must pay attention to the
3320 byte combining problem, i.e., a byte may be combined with a
3321 multibyte charcter of the previous string. This flag tells if we
3322 must consider such a situation or not. */
3323 int maybe_combine_byte
;
3324 unsigned char *this_format
;
3325 /* Precision for each spec, or -1, a flag value meaning no precision
3326 was given in that spec. Element 0, corresonding to the format
3327 string itself, will not be used. Element NARGS, corresponding to
3328 no argument, *will* be assigned to in the case that a `%' and `.'
3329 occur after the final format specifier. */
3330 int *precision
= (int *) (alloca((nargs
+ 1) * sizeof (int)));
3333 int arg_intervals
= 0;
3336 /* discarded[I] is 1 if byte I of the format
3337 string was not copied into the output.
3338 It is 2 if byte I was not the first byte of its character. */
3339 char *discarded
= 0;
3341 /* Each element records, for one argument,
3342 the start and end bytepos in the output string,
3343 and whether the argument is a string with intervals.
3344 info[0] is unused. Unused elements have -1 for start. */
3347 int start
, end
, intervals
;
3350 /* It should not be necessary to GCPRO ARGS, because
3351 the caller in the interpreter should take care of that. */
3353 /* Try to determine whether the result should be multibyte.
3354 This is not always right; sometimes the result needs to be multibyte
3355 because of an object that we will pass through prin1,
3356 and in that case, we won't know it here. */
3357 for (n
= 0; n
< nargs
; n
++)
3359 if (STRINGP (args
[n
]) && STRING_MULTIBYTE (args
[n
]))
3361 /* Piggyback on this loop to initialize precision[N]. */
3364 precision
[nargs
] = -1;
3366 CHECK_STRING (args
[0]);
3367 /* We may have to change "%S" to "%s". */
3368 args
[0] = Fcopy_sequence (args
[0]);
3370 /* GC should never happen here, so abort if it does. */
3373 /* If we start out planning a unibyte result,
3374 then discover it has to be multibyte, we jump back to retry.
3375 That can only happen from the first large while loop below. */
3378 format
= SDATA (args
[0]);
3379 format_start
= format
;
3380 end
= format
+ SBYTES (args
[0]);
3383 /* Make room in result for all the non-%-codes in the control string. */
3384 total
= 5 + CONVERTED_BYTE_SIZE (multibyte
, args
[0]) + 1;
3386 /* Allocate the info and discarded tables. */
3388 int nbytes
= (nargs
+1) * sizeof *info
;
3391 info
= (struct info
*) alloca (nbytes
);
3392 bzero (info
, nbytes
);
3393 for (i
= 0; i
<= nargs
; i
++)
3396 SAFE_ALLOCA (discarded
, char *, SBYTES (args
[0]));
3397 bzero (discarded
, SBYTES (args
[0]));
3400 /* Add to TOTAL enough space to hold the converted arguments. */
3403 while (format
!= end
)
3404 if (*format
++ == '%')
3407 int actual_width
= 0;
3408 unsigned char *this_format_start
= format
- 1;
3409 int field_width
= 0;
3411 /* General format specifications look like
3413 '%' [flags] [field-width] [precision] format
3418 field-width ::= [0-9]+
3419 precision ::= '.' [0-9]*
3421 If a field-width is specified, it specifies to which width
3422 the output should be padded with blanks, iff the output
3423 string is shorter than field-width.
3425 If precision is specified, it specifies the number of
3426 digits to print after the '.' for floats, or the max.
3427 number of chars to print from a string. */
3429 while (format
!= end
3430 && (*format
== '-' || *format
== '0' || *format
== '#'
3431 || * format
== ' '))
3434 if (*format
>= '0' && *format
<= '9')
3436 for (field_width
= 0; *format
>= '0' && *format
<= '9'; ++format
)
3437 field_width
= 10 * field_width
+ *format
- '0';
3440 /* N is not incremented for another few lines below, so refer to
3441 element N+1 (which might be precision[NARGS]). */
3445 for (precision
[n
+1] = 0; *format
>= '0' && *format
<= '9'; ++format
)
3446 precision
[n
+1] = 10 * precision
[n
+1] + *format
- '0';
3449 if (format
- this_format_start
+ 1 > longest_format
)
3450 longest_format
= format
- this_format_start
+ 1;
3453 error ("Format string ends in middle of format specifier");
3456 else if (++n
>= nargs
)
3457 error ("Not enough arguments for format string");
3458 else if (*format
== 'S')
3460 /* For `S', prin1 the argument and then treat like a string. */
3461 register Lisp_Object tem
;
3462 tem
= Fprin1_to_string (args
[n
], Qnil
);
3463 if (STRING_MULTIBYTE (tem
) && ! multibyte
)
3469 /* If we restart the loop, we should not come here again
3470 because args[n] is now a string and calling
3471 Fprin1_to_string on it produces superflous double
3472 quotes. So, change "%S" to "%s" now. */
3476 else if (SYMBOLP (args
[n
]))
3478 args
[n
] = SYMBOL_NAME (args
[n
]);
3479 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
3486 else if (STRINGP (args
[n
]))
3489 if (*format
!= 's' && *format
!= 'S')
3490 error ("Format specifier doesn't match argument type");
3491 /* In the case (PRECISION[N] > 0), THISSIZE may not need
3492 to be as large as is calculated here. Easy check for
3493 the case PRECISION = 0. */
3494 thissize
= precision
[n
] ? CONVERTED_BYTE_SIZE (multibyte
, args
[n
]) : 0;
3495 actual_width
= lisp_string_width (args
[n
], -1, NULL
, NULL
);
3497 /* Would get MPV otherwise, since Lisp_Int's `point' to low memory. */
3498 else if (INTEGERP (args
[n
]) && *format
!= 's')
3500 /* The following loop assumes the Lisp type indicates
3501 the proper way to pass the argument.
3502 So make sure we have a flonum if the argument should
3504 if (*format
== 'e' || *format
== 'f' || *format
== 'g')
3505 args
[n
] = Ffloat (args
[n
]);
3507 if (*format
!= 'd' && *format
!= 'o' && *format
!= 'x'
3508 && *format
!= 'i' && *format
!= 'X' && *format
!= 'c')
3509 error ("Invalid format operation %%%c", *format
);
3514 if (! SINGLE_BYTE_CHAR_P (XINT (args
[n
]))
3515 /* Note: No one can remember why we have to treat
3516 the character 0 as a multibyte character here.
3517 But, until it causes a real problem, let's
3519 || XINT (args
[n
]) == 0)
3526 args
[n
] = Fchar_to_string (args
[n
]);
3527 thissize
= SBYTES (args
[n
]);
3529 else if (! ASCII_BYTE_P (XINT (args
[n
])) && multibyte
)
3532 = Fchar_to_string (Funibyte_char_to_multibyte (args
[n
]));
3533 thissize
= SBYTES (args
[n
]);
3537 else if (FLOATP (args
[n
]) && *format
!= 's')
3539 if (! (*format
== 'e' || *format
== 'f' || *format
== 'g'))
3541 if (*format
!= 'd' && *format
!= 'o' && *format
!= 'x'
3542 && *format
!= 'i' && *format
!= 'X' && *format
!= 'c')
3543 error ("Invalid format operation %%%c", *format
);
3544 args
[n
] = Ftruncate (args
[n
], Qnil
);
3547 /* Note that we're using sprintf to print floats,
3548 so we have to take into account what that function
3550 /* Filter out flag value of -1. */
3551 thissize
= (MAX_10_EXP
+ 100
3552 + (precision
[n
] > 0 ? precision
[n
] : 0));
3556 /* Anything but a string, convert to a string using princ. */
3557 register Lisp_Object tem
;
3558 tem
= Fprin1_to_string (args
[n
], Qt
);
3559 if (STRING_MULTIBYTE (tem
) && ! multibyte
)
3568 thissize
+= max (0, field_width
- actual_width
);
3569 total
+= thissize
+ 4;
3574 /* Now we can no longer jump to retry.
3575 TOTAL and LONGEST_FORMAT are known for certain. */
3577 this_format
= (unsigned char *) alloca (longest_format
+ 1);
3579 /* Allocate the space for the result.
3580 Note that TOTAL is an overestimate. */
3581 SAFE_ALLOCA (buf
, char *, total
);
3587 /* Scan the format and store result in BUF. */
3588 format
= SDATA (args
[0]);
3589 format_start
= format
;
3590 end
= format
+ SBYTES (args
[0]);
3591 maybe_combine_byte
= 0;
3592 while (format
!= end
)
3598 unsigned char *this_format_start
= format
;
3600 discarded
[format
- format_start
] = 1;
3603 while (index("-0# ", *format
))
3609 discarded
[format
- format_start
] = 1;
3613 minlen
= atoi (format
);
3615 while ((*format
>= '0' && *format
<= '9') || *format
== '.')
3617 discarded
[format
- format_start
] = 1;
3621 if (*format
++ == '%')
3630 discarded
[format
- format_start
- 1] = 1;
3631 info
[n
].start
= nchars
;
3633 if (STRINGP (args
[n
]))
3635 /* handle case (precision[n] >= 0) */
3638 int nbytes
, start
, end
;
3641 /* lisp_string_width ignores a precision of 0, but GNU
3642 libc functions print 0 characters when the precision
3643 is 0. Imitate libc behavior here. Changing
3644 lisp_string_width is the right thing, and will be
3645 done, but meanwhile we work with it. */
3647 if (precision
[n
] == 0)
3648 width
= nchars_string
= nbytes
= 0;
3649 else if (precision
[n
] > 0)
3650 width
= lisp_string_width (args
[n
], precision
[n
], &nchars_string
, &nbytes
);
3652 { /* no precision spec given for this argument */
3653 width
= lisp_string_width (args
[n
], -1, NULL
, NULL
);
3654 nbytes
= SBYTES (args
[n
]);
3655 nchars_string
= SCHARS (args
[n
]);
3658 /* If spec requires it, pad on right with spaces. */
3659 padding
= minlen
- width
;
3661 while (padding
-- > 0)
3667 info
[n
].start
= start
= nchars
;
3668 nchars
+= nchars_string
;
3673 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3674 && STRING_MULTIBYTE (args
[n
])
3675 && !CHAR_HEAD_P (SREF (args
[n
], 0)))
3676 maybe_combine_byte
= 1;
3678 p
+= copy_text (SDATA (args
[n
]), p
,
3680 STRING_MULTIBYTE (args
[n
]), multibyte
);
3682 info
[n
].end
= nchars
;
3685 while (padding
-- > 0)
3691 /* If this argument has text properties, record where
3692 in the result string it appears. */
3693 if (STRING_INTERVALS (args
[n
]))
3694 info
[n
].intervals
= arg_intervals
= 1;
3696 else if (INTEGERP (args
[n
]) || FLOATP (args
[n
]))
3700 bcopy (this_format_start
, this_format
,
3701 format
- this_format_start
);
3702 this_format
[format
- this_format_start
] = 0;
3704 if (INTEGERP (args
[n
]))
3705 sprintf (p
, this_format
, XINT (args
[n
]));
3707 sprintf (p
, this_format
, XFLOAT_DATA (args
[n
]));
3711 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3712 && !CHAR_HEAD_P (*((unsigned char *) p
)))
3713 maybe_combine_byte
= 1;
3714 this_nchars
= strlen (p
);
3716 p
+= str_to_multibyte (p
, buf
+ total
- 1 - p
, this_nchars
);
3719 nchars
+= this_nchars
;
3720 info
[n
].end
= nchars
;
3724 else if (STRING_MULTIBYTE (args
[0]))
3726 /* Copy a whole multibyte character. */
3729 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3730 && !CHAR_HEAD_P (*format
))
3731 maybe_combine_byte
= 1;
3733 while (! CHAR_HEAD_P (*format
))
3735 discarded
[format
- format_start
] = 2;
3742 /* Convert a single-byte character to multibyte. */
3743 int len
= copy_text (format
, p
, 1, 0, 1);
3750 *p
++ = *format
++, nchars
++;
3753 if (p
> buf
+ total
)
3756 if (maybe_combine_byte
)
3757 nchars
= multibyte_chars_in_text (buf
, p
- buf
);
3758 val
= make_specified_string (buf
, nchars
, p
- buf
, multibyte
);
3760 /* If we allocated BUF with malloc, free it too. */
3763 /* If the format string has text properties, or any of the string
3764 arguments has text properties, set up text properties of the
3767 if (STRING_INTERVALS (args
[0]) || arg_intervals
)
3769 Lisp_Object len
, new_len
, props
;
3770 struct gcpro gcpro1
;
3772 /* Add text properties from the format string. */
3773 len
= make_number (SCHARS (args
[0]));
3774 props
= text_property_list (args
[0], make_number (0), len
, Qnil
);
3779 int bytepos
= 0, position
= 0, translated
= 0, argn
= 1;
3782 /* Adjust the bounds of each text property
3783 to the proper start and end in the output string. */
3785 /* Put the positions in PROPS in increasing order, so that
3786 we can do (effectively) one scan through the position
3787 space of the format string. */
3788 props
= Fnreverse (props
);
3790 /* BYTEPOS is the byte position in the format string,
3791 POSITION is the untranslated char position in it,
3792 TRANSLATED is the translated char position in BUF,
3793 and ARGN is the number of the next arg we will come to. */
3794 for (list
= props
; CONSP (list
); list
= XCDR (list
))
3801 /* First adjust the property start position. */
3802 pos
= XINT (XCAR (item
));
3804 /* Advance BYTEPOS, POSITION, TRANSLATED and ARGN
3805 up to this position. */
3806 for (; position
< pos
; bytepos
++)
3808 if (! discarded
[bytepos
])
3809 position
++, translated
++;
3810 else if (discarded
[bytepos
] == 1)
3813 if (translated
== info
[argn
].start
)
3815 translated
+= info
[argn
].end
- info
[argn
].start
;
3821 XSETCAR (item
, make_number (translated
));
3823 /* Likewise adjust the property end position. */
3824 pos
= XINT (XCAR (XCDR (item
)));
3826 for (; bytepos
< pos
; bytepos
++)
3828 if (! discarded
[bytepos
])
3829 position
++, translated
++;
3830 else if (discarded
[bytepos
] == 1)
3833 if (translated
== info
[argn
].start
)
3835 translated
+= info
[argn
].end
- info
[argn
].start
;
3841 XSETCAR (XCDR (item
), make_number (translated
));
3844 add_text_properties_from_list (val
, props
, make_number (0));
3847 /* Add text properties from arguments. */
3849 for (n
= 1; n
< nargs
; ++n
)
3850 if (info
[n
].intervals
)
3852 len
= make_number (SCHARS (args
[n
]));
3853 new_len
= make_number (info
[n
].end
- info
[n
].start
);
3854 props
= text_property_list (args
[n
], make_number (0), len
, Qnil
);
3855 extend_property_ranges (props
, len
, new_len
);
3856 /* If successive arguments have properites, be sure that
3857 the value of `composition' property be the copy. */
3858 if (n
> 1 && info
[n
- 1].end
)
3859 make_composition_value_copy (props
);
3860 add_text_properties_from_list (val
, props
,
3861 make_number (info
[n
].start
));
3871 format2 (string1
, arg0
, arg1
)
3873 Lisp_Object arg0
, arg1
;
3875 Lisp_Object args
[3];
3876 args
[0] = build_string (string1
);
3879 return Fformat (3, args
);
3882 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
3883 doc
: /* Return t if two characters match, optionally ignoring case.
3884 Both arguments must be characters (i.e. integers).
3885 Case is ignored if `case-fold-search' is non-nil in the current buffer. */)
3887 register Lisp_Object c1
, c2
;
3893 if (XINT (c1
) == XINT (c2
))
3895 if (NILP (current_buffer
->case_fold_search
))
3898 /* Do these in separate statements,
3899 then compare the variables.
3900 because of the way DOWNCASE uses temp variables. */
3901 i1
= DOWNCASE (XFASTINT (c1
));
3902 i2
= DOWNCASE (XFASTINT (c2
));
3903 return (i1
== i2
? Qt
: Qnil
);
3906 /* Transpose the markers in two regions of the current buffer, and
3907 adjust the ones between them if necessary (i.e.: if the regions
3910 START1, END1 are the character positions of the first region.
3911 START1_BYTE, END1_BYTE are the byte positions.
3912 START2, END2 are the character positions of the second region.
3913 START2_BYTE, END2_BYTE are the byte positions.
3915 Traverses the entire marker list of the buffer to do so, adding an
3916 appropriate amount to some, subtracting from some, and leaving the
3917 rest untouched. Most of this is copied from adjust_markers in insdel.c.
3919 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
3922 transpose_markers (start1
, end1
, start2
, end2
,
3923 start1_byte
, end1_byte
, start2_byte
, end2_byte
)
3924 register int start1
, end1
, start2
, end2
;
3925 register int start1_byte
, end1_byte
, start2_byte
, end2_byte
;
3927 register int amt1
, amt1_byte
, amt2
, amt2_byte
, diff
, diff_byte
, mpos
;
3928 register struct Lisp_Marker
*marker
;
3930 /* Update point as if it were a marker. */
3934 TEMP_SET_PT_BOTH (PT
+ (end2
- end1
),
3935 PT_BYTE
+ (end2_byte
- end1_byte
));
3936 else if (PT
< start2
)
3937 TEMP_SET_PT_BOTH (PT
+ (end2
- start2
) - (end1
- start1
),
3938 (PT_BYTE
+ (end2_byte
- start2_byte
)
3939 - (end1_byte
- start1_byte
)));
3941 TEMP_SET_PT_BOTH (PT
- (start2
- start1
),
3942 PT_BYTE
- (start2_byte
- start1_byte
));
3944 /* We used to adjust the endpoints here to account for the gap, but that
3945 isn't good enough. Even if we assume the caller has tried to move the
3946 gap out of our way, it might still be at start1 exactly, for example;
3947 and that places it `inside' the interval, for our purposes. The amount
3948 of adjustment is nontrivial if there's a `denormalized' marker whose
3949 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
3950 the dirty work to Fmarker_position, below. */
3952 /* The difference between the region's lengths */
3953 diff
= (end2
- start2
) - (end1
- start1
);
3954 diff_byte
= (end2_byte
- start2_byte
) - (end1_byte
- start1_byte
);
3956 /* For shifting each marker in a region by the length of the other
3957 region plus the distance between the regions. */
3958 amt1
= (end2
- start2
) + (start2
- end1
);
3959 amt2
= (end1
- start1
) + (start2
- end1
);
3960 amt1_byte
= (end2_byte
- start2_byte
) + (start2_byte
- end1_byte
);
3961 amt2_byte
= (end1_byte
- start1_byte
) + (start2_byte
- end1_byte
);
3963 for (marker
= BUF_MARKERS (current_buffer
); marker
; marker
= marker
->next
)
3965 mpos
= marker
->bytepos
;
3966 if (mpos
>= start1_byte
&& mpos
< end2_byte
)
3968 if (mpos
< end1_byte
)
3970 else if (mpos
< start2_byte
)
3974 marker
->bytepos
= mpos
;
3976 mpos
= marker
->charpos
;
3977 if (mpos
>= start1
&& mpos
< end2
)
3981 else if (mpos
< start2
)
3986 marker
->charpos
= mpos
;
3990 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
3991 doc
: /* Transpose region STARTR1 to ENDR1 with STARTR2 to ENDR2.
3992 The regions may not be overlapping, because the size of the buffer is
3993 never changed in a transposition.
3995 Optional fifth arg LEAVE-MARKERS, if non-nil, means don't update
3996 any markers that happen to be located in the regions.
3998 Transposing beyond buffer boundaries is an error. */)
3999 (startr1
, endr1
, startr2
, endr2
, leave_markers
)
4000 Lisp_Object startr1
, endr1
, startr2
, endr2
, leave_markers
;
4002 register int start1
, end1
, start2
, end2
;
4003 int start1_byte
, start2_byte
, len1_byte
, len2_byte
;
4004 int gap
, len1
, len_mid
, len2
;
4005 unsigned char *start1_addr
, *start2_addr
, *temp
;
4007 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
;
4008 cur_intv
= BUF_INTERVALS (current_buffer
);
4010 validate_region (&startr1
, &endr1
);
4011 validate_region (&startr2
, &endr2
);
4013 start1
= XFASTINT (startr1
);
4014 end1
= XFASTINT (endr1
);
4015 start2
= XFASTINT (startr2
);
4016 end2
= XFASTINT (endr2
);
4019 /* Swap the regions if they're reversed. */
4022 register int glumph
= start1
;
4030 len1
= end1
- start1
;
4031 len2
= end2
- start2
;
4034 error ("Transposed regions overlap");
4035 else if (start1
== end1
|| start2
== end2
)
4036 error ("Transposed region has length 0");
4038 /* The possibilities are:
4039 1. Adjacent (contiguous) regions, or separate but equal regions
4040 (no, really equal, in this case!), or
4041 2. Separate regions of unequal size.
4043 The worst case is usually No. 2. It means that (aside from
4044 potential need for getting the gap out of the way), there also
4045 needs to be a shifting of the text between the two regions. So
4046 if they are spread far apart, we are that much slower... sigh. */
4048 /* It must be pointed out that the really studly thing to do would
4049 be not to move the gap at all, but to leave it in place and work
4050 around it if necessary. This would be extremely efficient,
4051 especially considering that people are likely to do
4052 transpositions near where they are working interactively, which
4053 is exactly where the gap would be found. However, such code
4054 would be much harder to write and to read. So, if you are
4055 reading this comment and are feeling squirrely, by all means have
4056 a go! I just didn't feel like doing it, so I will simply move
4057 the gap the minimum distance to get it out of the way, and then
4058 deal with an unbroken array. */
4060 /* Make sure the gap won't interfere, by moving it out of the text
4061 we will operate on. */
4062 if (start1
< gap
&& gap
< end2
)
4064 if (gap
- start1
< end2
- gap
)
4070 start1_byte
= CHAR_TO_BYTE (start1
);
4071 start2_byte
= CHAR_TO_BYTE (start2
);
4072 len1_byte
= CHAR_TO_BYTE (end1
) - start1_byte
;
4073 len2_byte
= CHAR_TO_BYTE (end2
) - start2_byte
;
4075 #ifdef BYTE_COMBINING_DEBUG
4078 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4079 len2_byte
, start1
, start1_byte
)
4080 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4081 len1_byte
, end2
, start2_byte
+ len2_byte
)
4082 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4083 len1_byte
, end2
, start2_byte
+ len2_byte
))
4088 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4089 len2_byte
, start1
, start1_byte
)
4090 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4091 len1_byte
, start2
, start2_byte
)
4092 || count_combining_after (BYTE_POS_ADDR (start2_byte
),
4093 len2_byte
, end1
, start1_byte
+ len1_byte
)
4094 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4095 len1_byte
, end2
, start2_byte
+ len2_byte
))
4100 /* Hmmm... how about checking to see if the gap is large
4101 enough to use as the temporary storage? That would avoid an
4102 allocation... interesting. Later, don't fool with it now. */
4104 /* Working without memmove, for portability (sigh), so must be
4105 careful of overlapping subsections of the array... */
4107 if (end1
== start2
) /* adjacent regions */
4109 modify_region (current_buffer
, start1
, end2
);
4110 record_change (start1
, len1
+ len2
);
4112 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4113 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4114 Fset_text_properties (make_number (start1
), make_number (end2
),
4117 /* First region smaller than second. */
4118 if (len1_byte
< len2_byte
)
4122 SAFE_ALLOCA (temp
, unsigned char *, len2_byte
);
4124 /* Don't precompute these addresses. We have to compute them
4125 at the last minute, because the relocating allocator might
4126 have moved the buffer around during the xmalloc. */
4127 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4128 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4130 bcopy (start2_addr
, temp
, len2_byte
);
4131 bcopy (start1_addr
, start1_addr
+ len2_byte
, len1_byte
);
4132 bcopy (temp
, start1_addr
, len2_byte
);
4136 /* First region not smaller than second. */
4140 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4141 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4142 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4143 bcopy (start1_addr
, temp
, len1_byte
);
4144 bcopy (start2_addr
, start1_addr
, len2_byte
);
4145 bcopy (temp
, start1_addr
+ len2_byte
, len1_byte
);
4148 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
4149 len1
, current_buffer
, 0);
4150 graft_intervals_into_buffer (tmp_interval2
, start1
,
4151 len2
, current_buffer
, 0);
4152 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4153 update_compositions (start1
+ len2
, end2
, CHECK_TAIL
);
4155 /* Non-adjacent regions, because end1 != start2, bleagh... */
4158 len_mid
= start2_byte
- (start1_byte
+ len1_byte
);
4160 if (len1_byte
== len2_byte
)
4161 /* Regions are same size, though, how nice. */
4165 modify_region (current_buffer
, start1
, end1
);
4166 modify_region (current_buffer
, start2
, end2
);
4167 record_change (start1
, len1
);
4168 record_change (start2
, len2
);
4169 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4170 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4171 Fset_text_properties (make_number (start1
), make_number (end1
),
4173 Fset_text_properties (make_number (start2
), make_number (end2
),
4176 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4177 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4178 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4179 bcopy (start1_addr
, temp
, len1_byte
);
4180 bcopy (start2_addr
, start1_addr
, len2_byte
);
4181 bcopy (temp
, start2_addr
, len1_byte
);
4184 graft_intervals_into_buffer (tmp_interval1
, start2
,
4185 len1
, current_buffer
, 0);
4186 graft_intervals_into_buffer (tmp_interval2
, start1
,
4187 len2
, current_buffer
, 0);
4190 else if (len1_byte
< len2_byte
) /* Second region larger than first */
4191 /* Non-adjacent & unequal size, area between must also be shifted. */
4195 modify_region (current_buffer
, start1
, end2
);
4196 record_change (start1
, (end2
- start1
));
4197 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4198 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4199 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4200 Fset_text_properties (make_number (start1
), make_number (end2
),
4203 /* holds region 2 */
4204 SAFE_ALLOCA (temp
, unsigned char *, len2_byte
);
4205 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4206 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4207 bcopy (start2_addr
, temp
, len2_byte
);
4208 bcopy (start1_addr
, start1_addr
+ len_mid
+ len2_byte
, len1_byte
);
4209 safe_bcopy (start1_addr
+ len1_byte
, start1_addr
+ len2_byte
, len_mid
);
4210 bcopy (temp
, start1_addr
, len2_byte
);
4213 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4214 len1
, current_buffer
, 0);
4215 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4216 len_mid
, current_buffer
, 0);
4217 graft_intervals_into_buffer (tmp_interval2
, start1
,
4218 len2
, current_buffer
, 0);
4221 /* Second region smaller than first. */
4225 record_change (start1
, (end2
- start1
));
4226 modify_region (current_buffer
, start1
, end2
);
4228 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4229 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4230 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4231 Fset_text_properties (make_number (start1
), make_number (end2
),
4234 /* holds region 1 */
4235 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4236 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4237 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4238 bcopy (start1_addr
, temp
, len1_byte
);
4239 bcopy (start2_addr
, start1_addr
, len2_byte
);
4240 bcopy (start1_addr
+ len1_byte
, start1_addr
+ len2_byte
, len_mid
);
4241 bcopy (temp
, start1_addr
+ len2_byte
+ len_mid
, len1_byte
);
4244 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4245 len1
, current_buffer
, 0);
4246 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4247 len_mid
, current_buffer
, 0);
4248 graft_intervals_into_buffer (tmp_interval2
, start1
,
4249 len2
, current_buffer
, 0);
4252 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4253 update_compositions (end2
- len1
, end2
, CHECK_BORDER
);
4256 /* When doing multiple transpositions, it might be nice
4257 to optimize this. Perhaps the markers in any one buffer
4258 should be organized in some sorted data tree. */
4259 if (NILP (leave_markers
))
4261 transpose_markers (start1
, end1
, start2
, end2
,
4262 start1_byte
, start1_byte
+ len1_byte
,
4263 start2_byte
, start2_byte
+ len2_byte
);
4264 fix_start_end_in_overlays (start1
, end2
);
4276 Qbuffer_access_fontify_functions
4277 = intern ("buffer-access-fontify-functions");
4278 staticpro (&Qbuffer_access_fontify_functions
);
4280 DEFVAR_LISP ("inhibit-field-text-motion", &Vinhibit_field_text_motion
,
4281 doc
: /* Non-nil means text motion commands don't notice fields. */);
4282 Vinhibit_field_text_motion
= Qnil
;
4284 DEFVAR_LISP ("buffer-access-fontify-functions",
4285 &Vbuffer_access_fontify_functions
,
4286 doc
: /* List of functions called by `buffer-substring' to fontify if necessary.
4287 Each function is called with two arguments which specify the range
4288 of the buffer being accessed. */);
4289 Vbuffer_access_fontify_functions
= Qnil
;
4293 extern Lisp_Object Vprin1_to_string_buffer
;
4294 obuf
= Fcurrent_buffer ();
4295 /* Do this here, because init_buffer_once is too early--it won't work. */
4296 Fset_buffer (Vprin1_to_string_buffer
);
4297 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
4298 Fset (Fmake_local_variable (intern ("buffer-access-fontify-functions")),
4303 DEFVAR_LISP ("buffer-access-fontified-property",
4304 &Vbuffer_access_fontified_property
,
4305 doc
: /* Property which (if non-nil) indicates text has been fontified.
4306 `buffer-substring' need not call the `buffer-access-fontify-functions'
4307 functions if all the text being accessed has this property. */);
4308 Vbuffer_access_fontified_property
= Qnil
;
4310 DEFVAR_LISP ("system-name", &Vsystem_name
,
4311 doc
: /* The name of the machine Emacs is running on. */);
4313 DEFVAR_LISP ("user-full-name", &Vuser_full_name
,
4314 doc
: /* The full name of the user logged in. */);
4316 DEFVAR_LISP ("user-login-name", &Vuser_login_name
,
4317 doc
: /* The user's name, taken from environment variables if possible. */);
4319 DEFVAR_LISP ("user-real-login-name", &Vuser_real_login_name
,
4320 doc
: /* The user's name, based upon the real uid only. */);
4322 DEFVAR_LISP ("operating-system-release", &Voperating_system_release
,
4323 doc
: /* The release of the operating system Emacs is running on. */);
4325 defsubr (&Spropertize
);
4326 defsubr (&Schar_equal
);
4327 defsubr (&Sgoto_char
);
4328 defsubr (&Sstring_to_char
);
4329 defsubr (&Schar_to_string
);
4330 defsubr (&Sbuffer_substring
);
4331 defsubr (&Sbuffer_substring_no_properties
);
4332 defsubr (&Sbuffer_string
);
4334 defsubr (&Spoint_marker
);
4335 defsubr (&Smark_marker
);
4337 defsubr (&Sregion_beginning
);
4338 defsubr (&Sregion_end
);
4340 staticpro (&Qfield
);
4341 Qfield
= intern ("field");
4342 staticpro (&Qboundary
);
4343 Qboundary
= intern ("boundary");
4344 defsubr (&Sfield_beginning
);
4345 defsubr (&Sfield_end
);
4346 defsubr (&Sfield_string
);
4347 defsubr (&Sfield_string_no_properties
);
4348 defsubr (&Sdelete_field
);
4349 defsubr (&Sconstrain_to_field
);
4351 defsubr (&Sline_beginning_position
);
4352 defsubr (&Sline_end_position
);
4354 /* defsubr (&Smark); */
4355 /* defsubr (&Sset_mark); */
4356 defsubr (&Ssave_excursion
);
4357 defsubr (&Ssave_current_buffer
);
4359 defsubr (&Sbufsize
);
4360 defsubr (&Spoint_max
);
4361 defsubr (&Spoint_min
);
4362 defsubr (&Spoint_min_marker
);
4363 defsubr (&Spoint_max_marker
);
4364 defsubr (&Sgap_position
);
4365 defsubr (&Sgap_size
);
4366 defsubr (&Sposition_bytes
);
4367 defsubr (&Sbyte_to_position
);
4373 defsubr (&Sfollowing_char
);
4374 defsubr (&Sprevious_char
);
4375 defsubr (&Schar_after
);
4376 defsubr (&Schar_before
);
4378 defsubr (&Sinsert_before_markers
);
4379 defsubr (&Sinsert_and_inherit
);
4380 defsubr (&Sinsert_and_inherit_before_markers
);
4381 defsubr (&Sinsert_char
);
4383 defsubr (&Suser_login_name
);
4384 defsubr (&Suser_real_login_name
);
4385 defsubr (&Suser_uid
);
4386 defsubr (&Suser_real_uid
);
4387 defsubr (&Suser_full_name
);
4388 defsubr (&Semacs_pid
);
4389 defsubr (&Scurrent_time
);
4390 defsubr (&Sget_internal_run_time
);
4391 defsubr (&Sformat_time_string
);
4392 defsubr (&Sfloat_time
);
4393 defsubr (&Sdecode_time
);
4394 defsubr (&Sencode_time
);
4395 defsubr (&Scurrent_time_string
);
4396 defsubr (&Scurrent_time_zone
);
4397 defsubr (&Sset_time_zone_rule
);
4398 defsubr (&Ssystem_name
);
4399 defsubr (&Smessage
);
4400 defsubr (&Smessage_box
);
4401 defsubr (&Smessage_or_box
);
4402 defsubr (&Scurrent_message
);
4405 defsubr (&Sinsert_buffer_substring
);
4406 defsubr (&Scompare_buffer_substrings
);
4407 defsubr (&Ssubst_char_in_region
);
4408 defsubr (&Stranslate_region_internal
);
4409 defsubr (&Sdelete_region
);
4410 defsubr (&Sdelete_and_extract_region
);
4412 defsubr (&Snarrow_to_region
);
4413 defsubr (&Ssave_restriction
);
4414 defsubr (&Stranspose_regions
);
4417 /* arch-tag: fc3827d8-6f60-4067-b11e-c3218031b018
4418 (do not change this comment) */