1 /* Lisp functions pertaining to editing.
2 Copyright (C) 1985,86,87,89,93,94,95,96,97,98,1999,2000,01,02,03,2004
3 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
24 #include <sys/types.h>
36 /* Without this, sprintf on Mac OS Classic will produce wrong
45 #include "intervals.h"
47 #include "character.h"
56 #define MAX_10_EXP DBL_MAX_10_EXP
58 #define MAX_10_EXP 310
66 extern char **environ
;
69 extern Lisp_Object make_time
P_ ((time_t));
70 extern size_t emacs_strftimeu
P_ ((char *, size_t, const char *,
71 const struct tm
*, int));
72 static int tm_diff
P_ ((struct tm
*, struct tm
*));
73 static void find_field
P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
, int *, Lisp_Object
, int *));
74 static void update_buffer_properties
P_ ((int, int));
75 static Lisp_Object region_limit
P_ ((int));
76 int lisp_time_argument
P_ ((Lisp_Object
, time_t *, int *));
77 static size_t emacs_memftimeu
P_ ((char *, size_t, const char *,
78 size_t, const struct tm
*, int));
79 static void general_insert_function
P_ ((void (*) (const unsigned char *, int),
80 void (*) (Lisp_Object
, int, int, int,
82 int, int, Lisp_Object
*));
83 static Lisp_Object subst_char_in_region_unwind
P_ ((Lisp_Object
));
84 static Lisp_Object subst_char_in_region_unwind_1
P_ ((Lisp_Object
));
85 static void transpose_markers
P_ ((int, int, int, int, int, int, int, int));
88 extern char *index
P_ ((const char *, int));
91 Lisp_Object Vbuffer_access_fontify_functions
;
92 Lisp_Object Qbuffer_access_fontify_functions
;
93 Lisp_Object Vbuffer_access_fontified_property
;
95 Lisp_Object Fuser_full_name
P_ ((Lisp_Object
));
97 /* Non-nil means don't stop at field boundary in text motion commands. */
99 Lisp_Object Vinhibit_field_text_motion
;
101 /* Some static data, and a function to initialize it for each run */
103 Lisp_Object Vsystem_name
;
104 Lisp_Object Vuser_real_login_name
; /* login name of current user ID */
105 Lisp_Object Vuser_full_name
; /* full name of current user */
106 Lisp_Object Vuser_login_name
; /* user name from LOGNAME or USER */
108 /* Symbol for the text property used to mark fields. */
112 /* A special value for Qfield properties. */
114 Lisp_Object Qboundary
;
121 register unsigned char *p
;
122 struct passwd
*pw
; /* password entry for the current user */
125 /* Set up system_name even when dumping. */
129 /* Don't bother with this on initial start when just dumping out */
132 #endif /* not CANNOT_DUMP */
134 pw
= (struct passwd
*) getpwuid (getuid ());
136 /* We let the real user name default to "root" because that's quite
137 accurate on MSDOG and because it lets Emacs find the init file.
138 (The DVX libraries override the Djgpp libraries here.) */
139 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "root");
141 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "unknown");
144 /* Get the effective user name, by consulting environment variables,
145 or the effective uid if those are unset. */
146 user_name
= (char *) getenv ("LOGNAME");
149 user_name
= (char *) getenv ("USERNAME"); /* it's USERNAME on NT */
150 #else /* WINDOWSNT */
151 user_name
= (char *) getenv ("USER");
152 #endif /* WINDOWSNT */
155 pw
= (struct passwd
*) getpwuid (geteuid ());
156 user_name
= (char *) (pw
? pw
->pw_name
: "unknown");
158 Vuser_login_name
= build_string (user_name
);
160 /* If the user name claimed in the environment vars differs from
161 the real uid, use the claimed name to find the full name. */
162 tem
= Fstring_equal (Vuser_login_name
, Vuser_real_login_name
);
163 Vuser_full_name
= Fuser_full_name (NILP (tem
)? make_number (geteuid())
166 p
= (unsigned char *) getenv ("NAME");
168 Vuser_full_name
= build_string (p
);
169 else if (NILP (Vuser_full_name
))
170 Vuser_full_name
= build_string ("unknown");
173 DEFUN ("char-to-string", Fchar_to_string
, Schar_to_string
, 1, 1, 0,
174 doc
: /* Convert arg CHAR to a string containing that character.
175 usage: (char-to-string CHAR) */)
177 Lisp_Object character
;
180 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
182 CHECK_NUMBER (character
);
184 len
= CHAR_STRING (XFASTINT (character
), str
);
185 return make_string_from_bytes (str
, 1, len
);
188 DEFUN ("string-to-char", Fstring_to_char
, Sstring_to_char
, 1, 1, 0,
189 doc
: /* Convert arg STRING to a character, the first character of that string.
190 A multibyte character is handled correctly. */)
192 register Lisp_Object string
;
194 register Lisp_Object val
;
195 CHECK_STRING (string
);
198 if (STRING_MULTIBYTE (string
))
199 XSETFASTINT (val
, STRING_CHAR (SDATA (string
), SBYTES (string
)));
201 XSETFASTINT (val
, SREF (string
, 0));
204 XSETFASTINT (val
, 0);
209 buildmark (charpos
, bytepos
)
210 int charpos
, bytepos
;
212 register Lisp_Object mark
;
213 mark
= Fmake_marker ();
214 set_marker_both (mark
, Qnil
, charpos
, bytepos
);
218 DEFUN ("point", Fpoint
, Spoint
, 0, 0, 0,
219 doc
: /* Return value of point, as an integer.
220 Beginning of buffer is position (point-min). */)
224 XSETFASTINT (temp
, PT
);
228 DEFUN ("point-marker", Fpoint_marker
, Spoint_marker
, 0, 0, 0,
229 doc
: /* Return value of point, as a marker object. */)
232 return buildmark (PT
, PT_BYTE
);
236 clip_to_bounds (lower
, num
, upper
)
237 int lower
, num
, upper
;
241 else if (num
> upper
)
247 DEFUN ("goto-char", Fgoto_char
, Sgoto_char
, 1, 1, "NGoto char: ",
248 doc
: /* Set point to POSITION, a number or marker.
249 Beginning of buffer is position (point-min), end is (point-max). */)
251 register Lisp_Object position
;
255 if (MARKERP (position
)
256 && current_buffer
== XMARKER (position
)->buffer
)
258 pos
= marker_position (position
);
260 SET_PT_BOTH (BEGV
, BEGV_BYTE
);
262 SET_PT_BOTH (ZV
, ZV_BYTE
);
264 SET_PT_BOTH (pos
, marker_byte_position (position
));
269 CHECK_NUMBER_COERCE_MARKER (position
);
271 pos
= clip_to_bounds (BEGV
, XINT (position
), ZV
);
277 /* Return the start or end position of the region.
278 BEGINNINGP non-zero means return the start.
279 If there is no region active, signal an error. */
282 region_limit (beginningp
)
285 extern Lisp_Object Vmark_even_if_inactive
; /* Defined in callint.c. */
288 if (!NILP (Vtransient_mark_mode
)
289 && NILP (Vmark_even_if_inactive
)
290 && NILP (current_buffer
->mark_active
))
291 Fsignal (Qmark_inactive
, Qnil
);
293 m
= Fmarker_position (current_buffer
->mark
);
295 error ("The mark is not set now, so there is no region");
297 if ((PT
< XFASTINT (m
)) == (beginningp
!= 0))
298 m
= make_number (PT
);
302 DEFUN ("region-beginning", Fregion_beginning
, Sregion_beginning
, 0, 0, 0,
303 doc
: /* Return position of beginning of region, as an integer. */)
306 return region_limit (1);
309 DEFUN ("region-end", Fregion_end
, Sregion_end
, 0, 0, 0,
310 doc
: /* Return position of end of region, as an integer. */)
313 return region_limit (0);
316 DEFUN ("mark-marker", Fmark_marker
, Smark_marker
, 0, 0, 0,
317 doc
: /* Return this buffer's mark, as a marker object.
318 Watch out! Moving this marker changes the mark position.
319 If you set the marker not to point anywhere, the buffer will have no mark. */)
322 return current_buffer
->mark
;
326 /* Find all the overlays in the current buffer that touch position POS.
327 Return the number found, and store them in a vector in VEC
331 overlays_around (pos
, vec
, len
)
336 Lisp_Object overlay
, start
, end
;
337 struct Lisp_Overlay
*tail
;
338 int startpos
, endpos
;
341 for (tail
= current_buffer
->overlays_before
; tail
; tail
= tail
->next
)
343 XSETMISC (overlay
, tail
);
345 end
= OVERLAY_END (overlay
);
346 endpos
= OVERLAY_POSITION (end
);
349 start
= OVERLAY_START (overlay
);
350 startpos
= OVERLAY_POSITION (start
);
355 /* Keep counting overlays even if we can't return them all. */
360 for (tail
= current_buffer
->overlays_after
; tail
; tail
= tail
->next
)
362 XSETMISC (overlay
, tail
);
364 start
= OVERLAY_START (overlay
);
365 startpos
= OVERLAY_POSITION (start
);
368 end
= OVERLAY_END (overlay
);
369 endpos
= OVERLAY_POSITION (end
);
381 /* Return the value of property PROP, in OBJECT at POSITION.
382 It's the value of PROP that a char inserted at POSITION would get.
383 OBJECT is optional and defaults to the current buffer.
384 If OBJECT is a buffer, then overlay properties are considered as well as
386 If OBJECT is a window, then that window's buffer is used, but
387 window-specific overlays are considered only if they are associated
390 get_pos_property (position
, prop
, object
)
391 Lisp_Object position
, object
;
392 register Lisp_Object prop
;
394 CHECK_NUMBER_COERCE_MARKER (position
);
397 XSETBUFFER (object
, current_buffer
);
398 else if (WINDOWP (object
))
399 object
= XWINDOW (object
)->buffer
;
401 if (!BUFFERP (object
))
402 /* pos-property only makes sense in buffers right now, since strings
403 have no overlays and no notion of insertion for which stickiness
405 return Fget_text_property (position
, prop
, object
);
408 int posn
= XINT (position
);
410 Lisp_Object
*overlay_vec
, tem
;
411 struct buffer
*obuf
= current_buffer
;
413 set_buffer_temp (XBUFFER (object
));
415 /* First try with room for 40 overlays. */
417 overlay_vec
= (Lisp_Object
*) alloca (noverlays
* sizeof (Lisp_Object
));
418 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
420 /* If there are more than 40,
421 make enough space for all, and try again. */
424 overlay_vec
= (Lisp_Object
*) alloca (noverlays
* sizeof (Lisp_Object
));
425 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
427 noverlays
= sort_overlays (overlay_vec
, noverlays
, NULL
);
429 set_buffer_temp (obuf
);
431 /* Now check the overlays in order of decreasing priority. */
432 while (--noverlays
>= 0)
434 Lisp_Object ol
= overlay_vec
[noverlays
];
435 tem
= Foverlay_get (ol
, prop
);
438 /* Check the overlay is indeed active at point. */
439 Lisp_Object start
= OVERLAY_START (ol
), finish
= OVERLAY_END (ol
);
440 if ((OVERLAY_POSITION (start
) == posn
441 && XMARKER (start
)->insertion_type
== 1)
442 || (OVERLAY_POSITION (finish
) == posn
443 && XMARKER (finish
)->insertion_type
== 0))
444 ; /* The overlay will not cover a char inserted at point. */
452 { /* Now check the text-properties. */
453 int stickiness
= text_property_stickiness (prop
, position
, object
);
455 return Fget_text_property (position
, prop
, object
);
456 else if (stickiness
< 0
457 && XINT (position
) > BUF_BEGV (XBUFFER (object
)))
458 return Fget_text_property (make_number (XINT (position
) - 1),
466 /* Find the field surrounding POS in *BEG and *END. If POS is nil,
467 the value of point is used instead. If BEG or END null,
468 means don't store the beginning or end of the field.
470 BEG_LIMIT and END_LIMIT serve to limit the ranged of the returned
471 results; they do not effect boundary behavior.
473 If MERGE_AT_BOUNDARY is nonzero, then if POS is at the very first
474 position of a field, then the beginning of the previous field is
475 returned instead of the beginning of POS's field (since the end of a
476 field is actually also the beginning of the next input field, this
477 behavior is sometimes useful). Additionally in the MERGE_AT_BOUNDARY
478 true case, if two fields are separated by a field with the special
479 value `boundary', and POS lies within it, then the two separated
480 fields are considered to be adjacent, and POS between them, when
481 finding the beginning and ending of the "merged" field.
483 Either BEG or END may be 0, in which case the corresponding value
487 find_field (pos
, merge_at_boundary
, beg_limit
, beg
, end_limit
, end
)
489 Lisp_Object merge_at_boundary
;
490 Lisp_Object beg_limit
, end_limit
;
493 /* Fields right before and after the point. */
494 Lisp_Object before_field
, after_field
;
495 /* 1 if POS counts as the start of a field. */
496 int at_field_start
= 0;
497 /* 1 if POS counts as the end of a field. */
498 int at_field_end
= 0;
501 XSETFASTINT (pos
, PT
);
503 CHECK_NUMBER_COERCE_MARKER (pos
);
506 = get_char_property_and_overlay (pos
, Qfield
, Qnil
, NULL
);
508 = (XFASTINT (pos
) > BEGV
509 ? get_char_property_and_overlay (make_number (XINT (pos
) - 1),
513 /* See if we need to handle the case where MERGE_AT_BOUNDARY is nil
514 and POS is at beginning of a field, which can also be interpreted
515 as the end of the previous field. Note that the case where if
516 MERGE_AT_BOUNDARY is non-nil (see function comment) is actually the
517 more natural one; then we avoid treating the beginning of a field
519 if (NILP (merge_at_boundary
))
521 Lisp_Object field
= get_pos_property (pos
, Qfield
, Qnil
);
522 if (!EQ (field
, after_field
))
524 if (!EQ (field
, before_field
))
526 if (NILP (field
) && at_field_start
&& at_field_end
)
527 /* If an inserted char would have a nil field while the surrounding
528 text is non-nil, we're probably not looking at a
529 zero-length field, but instead at a non-nil field that's
530 not intended for editing (such as comint's prompts). */
531 at_field_end
= at_field_start
= 0;
534 /* Note about special `boundary' fields:
536 Consider the case where the point (`.') is between the fields `x' and `y':
540 In this situation, if merge_at_boundary is true, we consider the
541 `x' and `y' fields as forming one big merged field, and so the end
542 of the field is the end of `y'.
544 However, if `x' and `y' are separated by a special `boundary' field
545 (a field with a `field' char-property of 'boundary), then we ignore
546 this special field when merging adjacent fields. Here's the same
547 situation, but with a `boundary' field between the `x' and `y' fields:
551 Here, if point is at the end of `x', the beginning of `y', or
552 anywhere in-between (within the `boundary' field), we merge all
553 three fields and consider the beginning as being the beginning of
554 the `x' field, and the end as being the end of the `y' field. */
559 /* POS is at the edge of a field, and we should consider it as
560 the beginning of the following field. */
561 *beg
= XFASTINT (pos
);
563 /* Find the previous field boundary. */
566 if (!NILP (merge_at_boundary
) && EQ (before_field
, Qboundary
))
567 /* Skip a `boundary' field. */
568 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
571 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
573 *beg
= NILP (p
) ? BEGV
: XFASTINT (p
);
580 /* POS is at the edge of a field, and we should consider it as
581 the end of the previous field. */
582 *end
= XFASTINT (pos
);
584 /* Find the next field boundary. */
586 if (!NILP (merge_at_boundary
) && EQ (after_field
, Qboundary
))
587 /* Skip a `boundary' field. */
588 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
591 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
593 *end
= NILP (pos
) ? ZV
: XFASTINT (pos
);
599 DEFUN ("delete-field", Fdelete_field
, Sdelete_field
, 0, 1, 0,
600 doc
: /* Delete the field surrounding POS.
601 A field is a region of text with the same `field' property.
602 If POS is nil, the value of point is used for POS. */)
607 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
609 del_range (beg
, end
);
613 DEFUN ("field-string", Ffield_string
, Sfield_string
, 0, 1, 0,
614 doc
: /* Return the contents of the field surrounding POS as a string.
615 A field is a region of text with the same `field' property.
616 If POS is nil, the value of point is used for POS. */)
621 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
622 return make_buffer_string (beg
, end
, 1);
625 DEFUN ("field-string-no-properties", Ffield_string_no_properties
, Sfield_string_no_properties
, 0, 1, 0,
626 doc
: /* Return the contents of the field around POS, without text-properties.
627 A field is a region of text with the same `field' property.
628 If POS is nil, the value of point is used for POS. */)
633 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
634 return make_buffer_string (beg
, end
, 0);
637 DEFUN ("field-beginning", Ffield_beginning
, Sfield_beginning
, 0, 3, 0,
638 doc
: /* Return the beginning of the field surrounding POS.
639 A field is a region of text with the same `field' property.
640 If POS is nil, the value of point is used for POS.
641 If ESCAPE-FROM-EDGE is non-nil and POS is at the beginning of its
642 field, then the beginning of the *previous* field is returned.
643 If LIMIT is non-nil, it is a buffer position; if the beginning of the field
644 is before LIMIT, then LIMIT will be returned instead. */)
645 (pos
, escape_from_edge
, limit
)
646 Lisp_Object pos
, escape_from_edge
, limit
;
649 find_field (pos
, escape_from_edge
, limit
, &beg
, Qnil
, 0);
650 return make_number (beg
);
653 DEFUN ("field-end", Ffield_end
, Sfield_end
, 0, 3, 0,
654 doc
: /* Return the end of the field surrounding POS.
655 A field is a region of text with the same `field' property.
656 If POS is nil, the value of point is used for POS.
657 If ESCAPE-FROM-EDGE is non-nil and POS is at the end of its field,
658 then the end of the *following* field is returned.
659 If LIMIT is non-nil, it is a buffer position; if the end of the field
660 is after LIMIT, then LIMIT will be returned instead. */)
661 (pos
, escape_from_edge
, limit
)
662 Lisp_Object pos
, escape_from_edge
, limit
;
665 find_field (pos
, escape_from_edge
, Qnil
, 0, limit
, &end
);
666 return make_number (end
);
669 DEFUN ("constrain-to-field", Fconstrain_to_field
, Sconstrain_to_field
, 2, 5, 0,
670 doc
: /* Return the position closest to NEW-POS that is in the same field as OLD-POS.
672 A field is a region of text with the same `field' property.
673 If NEW-POS is nil, then the current point is used instead, and set to the
674 constrained position if that is different.
676 If OLD-POS is at the boundary of two fields, then the allowable
677 positions for NEW-POS depends on the value of the optional argument
678 ESCAPE-FROM-EDGE: If ESCAPE-FROM-EDGE is nil, then NEW-POS is
679 constrained to the field that has the same `field' char-property
680 as any new characters inserted at OLD-POS, whereas if ESCAPE-FROM-EDGE
681 is non-nil, NEW-POS is constrained to the union of the two adjacent
682 fields. Additionally, if two fields are separated by another field with
683 the special value `boundary', then any point within this special field is
684 also considered to be `on the boundary'.
686 If the optional argument ONLY-IN-LINE is non-nil and constraining
687 NEW-POS would move it to a different line, NEW-POS is returned
688 unconstrained. This useful for commands that move by line, like
689 \\[next-line] or \\[beginning-of-line], which should generally respect field boundaries
690 only in the case where they can still move to the right line.
692 If the optional argument INHIBIT-CAPTURE-PROPERTY is non-nil, and OLD-POS has
693 a non-nil property of that name, then any field boundaries are ignored.
695 Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */)
696 (new_pos
, old_pos
, escape_from_edge
, only_in_line
, inhibit_capture_property
)
697 Lisp_Object new_pos
, old_pos
;
698 Lisp_Object escape_from_edge
, only_in_line
, inhibit_capture_property
;
700 /* If non-zero, then the original point, before re-positioning. */
704 /* Use the current point, and afterwards, set it. */
707 XSETFASTINT (new_pos
, PT
);
710 if (NILP (Vinhibit_field_text_motion
)
711 && !EQ (new_pos
, old_pos
)
712 && (!NILP (Fget_char_property (new_pos
, Qfield
, Qnil
))
713 || !NILP (Fget_char_property (old_pos
, Qfield
, Qnil
)))
714 && (NILP (inhibit_capture_property
)
715 || NILP (Fget_char_property(old_pos
, inhibit_capture_property
, Qnil
))))
716 /* NEW_POS is not within the same field as OLD_POS; try to
717 move NEW_POS so that it is. */
720 Lisp_Object field_bound
;
722 CHECK_NUMBER_COERCE_MARKER (new_pos
);
723 CHECK_NUMBER_COERCE_MARKER (old_pos
);
725 fwd
= (XFASTINT (new_pos
) > XFASTINT (old_pos
));
728 field_bound
= Ffield_end (old_pos
, escape_from_edge
, new_pos
);
730 field_bound
= Ffield_beginning (old_pos
, escape_from_edge
, new_pos
);
732 if (/* See if ESCAPE_FROM_EDGE caused FIELD_BOUND to jump to the
733 other side of NEW_POS, which would mean that NEW_POS is
734 already acceptable, and it's not necessary to constrain it
736 ((XFASTINT (field_bound
) < XFASTINT (new_pos
)) ? fwd
: !fwd
)
737 /* NEW_POS should be constrained, but only if either
738 ONLY_IN_LINE is nil (in which case any constraint is OK),
739 or NEW_POS and FIELD_BOUND are on the same line (in which
740 case the constraint is OK even if ONLY_IN_LINE is non-nil). */
741 && (NILP (only_in_line
)
742 /* This is the ONLY_IN_LINE case, check that NEW_POS and
743 FIELD_BOUND are on the same line by seeing whether
744 there's an intervening newline or not. */
745 || (scan_buffer ('\n',
746 XFASTINT (new_pos
), XFASTINT (field_bound
),
747 fwd
? -1 : 1, &shortage
, 1),
749 /* Constrain NEW_POS to FIELD_BOUND. */
750 new_pos
= field_bound
;
752 if (orig_point
&& XFASTINT (new_pos
) != orig_point
)
753 /* The NEW_POS argument was originally nil, so automatically set PT. */
754 SET_PT (XFASTINT (new_pos
));
761 DEFUN ("line-beginning-position",
762 Fline_beginning_position
, Sline_beginning_position
, 0, 1, 0,
763 doc
: /* Return the character position of the first character on the current line.
764 With argument N not nil or 1, move forward N - 1 lines first.
765 If scan reaches end of buffer, return that position.
767 The scan does not cross a field boundary unless doing so would move
768 beyond there to a different line; if N is nil or 1, and scan starts at a
769 field boundary, the scan stops as soon as it starts. To ignore field
770 boundaries bind `inhibit-field-text-motion' to t.
772 This function does not move point. */)
776 int orig
, orig_byte
, end
;
785 Fforward_line (make_number (XINT (n
) - 1));
788 SET_PT_BOTH (orig
, orig_byte
);
790 /* Return END constrained to the current input field. */
791 return Fconstrain_to_field (make_number (end
), make_number (orig
),
792 XINT (n
) != 1 ? Qt
: Qnil
,
796 DEFUN ("line-end-position", Fline_end_position
, Sline_end_position
, 0, 1, 0,
797 doc
: /* Return the character position of the last character on the current line.
798 With argument N not nil or 1, move forward N - 1 lines first.
799 If scan reaches end of buffer, return that position.
801 The scan does not cross a field boundary unless doing so would move
802 beyond there to a different line; if N is nil or 1, and scan starts at a
803 field boundary, the scan stops as soon as it starts. To ignore field
804 boundaries bind `inhibit-field-text-motion' to t.
806 This function does not move point. */)
818 end_pos
= find_before_next_newline (orig
, 0, XINT (n
) - (XINT (n
) <= 0));
820 /* Return END_POS constrained to the current input field. */
821 return Fconstrain_to_field (make_number (end_pos
), make_number (orig
),
827 save_excursion_save ()
829 int visible
= (XBUFFER (XWINDOW (selected_window
)->buffer
)
832 return Fcons (Fpoint_marker (),
833 Fcons (Fcopy_marker (current_buffer
->mark
, Qnil
),
834 Fcons (visible
? Qt
: Qnil
,
835 Fcons (current_buffer
->mark_active
,
840 save_excursion_restore (info
)
843 Lisp_Object tem
, tem1
, omark
, nmark
;
844 struct gcpro gcpro1
, gcpro2
, gcpro3
;
847 tem
= Fmarker_buffer (XCAR (info
));
848 /* If buffer being returned to is now deleted, avoid error */
849 /* Otherwise could get error here while unwinding to top level
851 /* In that case, Fmarker_buffer returns nil now. */
855 omark
= nmark
= Qnil
;
856 GCPRO3 (info
, omark
, nmark
);
863 unchain_marker (XMARKER (tem
));
868 omark
= Fmarker_position (current_buffer
->mark
);
869 Fset_marker (current_buffer
->mark
, tem
, Fcurrent_buffer ());
870 nmark
= Fmarker_position (tem
);
871 unchain_marker (XMARKER (tem
));
875 visible_p
= !NILP (XCAR (info
));
877 #if 0 /* We used to make the current buffer visible in the selected window
878 if that was true previously. That avoids some anomalies.
879 But it creates others, and it wasn't documented, and it is simpler
880 and cleaner never to alter the window/buffer connections. */
883 && current_buffer
!= XBUFFER (XWINDOW (selected_window
)->buffer
))
884 Fswitch_to_buffer (Fcurrent_buffer (), Qnil
);
890 tem1
= current_buffer
->mark_active
;
891 current_buffer
->mark_active
= tem
;
893 if (!NILP (Vrun_hooks
))
895 /* If mark is active now, and either was not active
896 or was at a different place, run the activate hook. */
897 if (! NILP (current_buffer
->mark_active
))
899 if (! EQ (omark
, nmark
))
900 call1 (Vrun_hooks
, intern ("activate-mark-hook"));
902 /* If mark has ceased to be active, run deactivate hook. */
903 else if (! NILP (tem1
))
904 call1 (Vrun_hooks
, intern ("deactivate-mark-hook"));
907 /* If buffer was visible in a window, and a different window was
908 selected, and the old selected window is still showing this
909 buffer, restore point in that window. */
912 && !EQ (tem
, selected_window
)
913 && (tem1
= XWINDOW (tem
)->buffer
,
914 (/* Window is live... */
916 /* ...and it shows the current buffer. */
917 && XBUFFER (tem1
) == current_buffer
)))
918 Fset_window_point (tem
, make_number (PT
));
924 DEFUN ("save-excursion", Fsave_excursion
, Ssave_excursion
, 0, UNEVALLED
, 0,
925 doc
: /* Save point, mark, and current buffer; execute BODY; restore those things.
926 Executes BODY just like `progn'.
927 The values of point, mark and the current buffer are restored
928 even in case of abnormal exit (throw or error).
929 The state of activation of the mark is also restored.
931 This construct does not save `deactivate-mark', and therefore
932 functions that change the buffer will still cause deactivation
933 of the mark at the end of the command. To prevent that, bind
934 `deactivate-mark' with `let'.
936 usage: (save-excursion &rest BODY) */)
940 register Lisp_Object val
;
941 int count
= SPECPDL_INDEX ();
943 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
946 return unbind_to (count
, val
);
949 DEFUN ("save-current-buffer", Fsave_current_buffer
, Ssave_current_buffer
, 0, UNEVALLED
, 0,
950 doc
: /* Save the current buffer; execute BODY; restore the current buffer.
951 Executes BODY just like `progn'.
952 usage: (save-current-buffer &rest BODY) */)
957 int count
= SPECPDL_INDEX ();
959 record_unwind_protect (set_buffer_if_live
, Fcurrent_buffer ());
962 return unbind_to (count
, val
);
965 DEFUN ("buffer-size", Fbufsize
, Sbufsize
, 0, 1, 0,
966 doc
: /* Return the number of characters in the current buffer.
967 If BUFFER, return the number of characters in that buffer instead. */)
972 return make_number (Z
- BEG
);
975 CHECK_BUFFER (buffer
);
976 return make_number (BUF_Z (XBUFFER (buffer
))
977 - BUF_BEG (XBUFFER (buffer
)));
981 DEFUN ("point-min", Fpoint_min
, Spoint_min
, 0, 0, 0,
982 doc
: /* Return the minimum permissible value of point in the current buffer.
983 This is 1, unless narrowing (a buffer restriction) is in effect. */)
987 XSETFASTINT (temp
, BEGV
);
991 DEFUN ("point-min-marker", Fpoint_min_marker
, Spoint_min_marker
, 0, 0, 0,
992 doc
: /* Return a marker to the minimum permissible value of point in this buffer.
993 This is the beginning, unless narrowing (a buffer restriction) is in effect. */)
996 return buildmark (BEGV
, BEGV_BYTE
);
999 DEFUN ("point-max", Fpoint_max
, Spoint_max
, 0, 0, 0,
1000 doc
: /* Return the maximum permissible value of point in the current buffer.
1001 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1002 is in effect, in which case it is less. */)
1006 XSETFASTINT (temp
, ZV
);
1010 DEFUN ("point-max-marker", Fpoint_max_marker
, Spoint_max_marker
, 0, 0, 0,
1011 doc
: /* Return a marker to the maximum permissible value of point in this buffer.
1012 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1013 is in effect, in which case it is less. */)
1016 return buildmark (ZV
, ZV_BYTE
);
1019 DEFUN ("gap-position", Fgap_position
, Sgap_position
, 0, 0, 0,
1020 doc
: /* Return the position of the gap, in the current buffer.
1021 See also `gap-size'. */)
1025 XSETFASTINT (temp
, GPT
);
1029 DEFUN ("gap-size", Fgap_size
, Sgap_size
, 0, 0, 0,
1030 doc
: /* Return the size of the current buffer's gap.
1031 See also `gap-position'. */)
1035 XSETFASTINT (temp
, GAP_SIZE
);
1039 DEFUN ("position-bytes", Fposition_bytes
, Sposition_bytes
, 1, 1, 0,
1040 doc
: /* Return the byte position for character position POSITION.
1041 If POSITION is out of range, the value is nil. */)
1043 Lisp_Object position
;
1045 CHECK_NUMBER_COERCE_MARKER (position
);
1046 if (XINT (position
) < BEG
|| XINT (position
) > Z
)
1048 return make_number (CHAR_TO_BYTE (XINT (position
)));
1051 DEFUN ("byte-to-position", Fbyte_to_position
, Sbyte_to_position
, 1, 1, 0,
1052 doc
: /* Return the character position for byte position BYTEPOS.
1053 If BYTEPOS is out of range, the value is nil. */)
1055 Lisp_Object bytepos
;
1057 CHECK_NUMBER (bytepos
);
1058 if (XINT (bytepos
) < BEG_BYTE
|| XINT (bytepos
) > Z_BYTE
)
1060 return make_number (BYTE_TO_CHAR (XINT (bytepos
)));
1063 DEFUN ("following-char", Ffollowing_char
, Sfollowing_char
, 0, 0, 0,
1064 doc
: /* Return the character following point, as a number.
1065 At the end of the buffer or accessible region, return 0. */)
1070 XSETFASTINT (temp
, 0);
1072 XSETFASTINT (temp
, FETCH_CHAR (PT_BYTE
));
1076 DEFUN ("preceding-char", Fprevious_char
, Sprevious_char
, 0, 0, 0,
1077 doc
: /* Return the character preceding point, as a number.
1078 At the beginning of the buffer or accessible region, return 0. */)
1083 XSETFASTINT (temp
, 0);
1084 else if (!NILP (current_buffer
->enable_multibyte_characters
))
1088 XSETFASTINT (temp
, FETCH_CHAR (pos
));
1091 XSETFASTINT (temp
, FETCH_BYTE (PT_BYTE
- 1));
1095 DEFUN ("bobp", Fbobp
, Sbobp
, 0, 0, 0,
1096 doc
: /* Return t if point is at the beginning of the buffer.
1097 If the buffer is narrowed, this means the beginning of the narrowed part. */)
1105 DEFUN ("eobp", Feobp
, Seobp
, 0, 0, 0,
1106 doc
: /* Return t if point is at the end of the buffer.
1107 If the buffer is narrowed, this means the end of the narrowed part. */)
1115 DEFUN ("bolp", Fbolp
, Sbolp
, 0, 0, 0,
1116 doc
: /* Return t if point is at the beginning of a line. */)
1119 if (PT
== BEGV
|| FETCH_BYTE (PT_BYTE
- 1) == '\n')
1124 DEFUN ("eolp", Feolp
, Seolp
, 0, 0, 0,
1125 doc
: /* Return t if point is at the end of a line.
1126 `End of a line' includes point being at the end of the buffer. */)
1129 if (PT
== ZV
|| FETCH_BYTE (PT_BYTE
) == '\n')
1134 DEFUN ("char-after", Fchar_after
, Schar_after
, 0, 1, 0,
1135 doc
: /* Return character in current buffer at position POS.
1136 POS is an integer or a marker and defaults to point.
1137 If POS is out of range, the value is nil. */)
1141 register int pos_byte
;
1146 XSETFASTINT (pos
, PT
);
1151 pos_byte
= marker_byte_position (pos
);
1152 if (pos_byte
< BEGV_BYTE
|| pos_byte
>= ZV_BYTE
)
1157 CHECK_NUMBER_COERCE_MARKER (pos
);
1158 if (XINT (pos
) < BEGV
|| XINT (pos
) >= ZV
)
1161 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1164 return make_number (FETCH_CHAR (pos_byte
));
1167 DEFUN ("char-before", Fchar_before
, Schar_before
, 0, 1, 0,
1168 doc
: /* Return character in current buffer preceding position POS.
1169 POS is an integer or a marker and defaults to point.
1170 If POS is out of range, the value is nil. */)
1174 register Lisp_Object val
;
1175 register int pos_byte
;
1180 XSETFASTINT (pos
, PT
);
1185 pos_byte
= marker_byte_position (pos
);
1187 if (pos_byte
<= BEGV_BYTE
|| pos_byte
> ZV_BYTE
)
1192 CHECK_NUMBER_COERCE_MARKER (pos
);
1194 if (XINT (pos
) <= BEGV
|| XINT (pos
) > ZV
)
1197 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1200 if (!NILP (current_buffer
->enable_multibyte_characters
))
1203 XSETFASTINT (val
, FETCH_CHAR (pos_byte
));
1208 XSETFASTINT (val
, FETCH_BYTE (pos_byte
));
1213 DEFUN ("user-login-name", Fuser_login_name
, Suser_login_name
, 0, 1, 0,
1214 doc
: /* Return the name under which the user logged in, as a string.
1215 This is based on the effective uid, not the real uid.
1216 Also, if the environment variables LOGNAME or USER are set,
1217 that determines the value of this function.
1219 If optional argument UID is an integer, return the login name of the user
1220 with that uid, or nil if there is no such user. */)
1226 /* Set up the user name info if we didn't do it before.
1227 (That can happen if Emacs is dumpable
1228 but you decide to run `temacs -l loadup' and not dump. */
1229 if (INTEGERP (Vuser_login_name
))
1233 return Vuser_login_name
;
1236 pw
= (struct passwd
*) getpwuid (XINT (uid
));
1237 return (pw
? build_string (pw
->pw_name
) : Qnil
);
1240 DEFUN ("user-real-login-name", Fuser_real_login_name
, Suser_real_login_name
,
1242 doc
: /* Return the name of the user's real uid, as a string.
1243 This ignores the environment variables LOGNAME and USER, so it differs from
1244 `user-login-name' when running under `su'. */)
1247 /* Set up the user name info if we didn't do it before.
1248 (That can happen if Emacs is dumpable
1249 but you decide to run `temacs -l loadup' and not dump. */
1250 if (INTEGERP (Vuser_login_name
))
1252 return Vuser_real_login_name
;
1255 DEFUN ("user-uid", Fuser_uid
, Suser_uid
, 0, 0, 0,
1256 doc
: /* Return the effective uid of Emacs.
1257 Value is an integer or float, depending on the value. */)
1260 return make_fixnum_or_float (geteuid ());
1263 DEFUN ("user-real-uid", Fuser_real_uid
, Suser_real_uid
, 0, 0, 0,
1264 doc
: /* Return the real uid of Emacs.
1265 Value is an integer or float, depending on the value. */)
1268 return make_fixnum_or_float (getuid ());
1271 DEFUN ("user-full-name", Fuser_full_name
, Suser_full_name
, 0, 1, 0,
1272 doc
: /* Return the full name of the user logged in, as a string.
1273 If the full name corresponding to Emacs's userid is not known,
1276 If optional argument UID is an integer or float, return the full name
1277 of the user with that uid, or nil if there is no such user.
1278 If UID is a string, return the full name of the user with that login
1279 name, or nil if there is no such user. */)
1284 register unsigned char *p
, *q
;
1288 return Vuser_full_name
;
1289 else if (NUMBERP (uid
))
1290 pw
= (struct passwd
*) getpwuid ((uid_t
) XFLOATINT (uid
));
1291 else if (STRINGP (uid
))
1292 pw
= (struct passwd
*) getpwnam (SDATA (uid
));
1294 error ("Invalid UID specification");
1299 p
= (unsigned char *) USER_FULL_NAME
;
1300 /* Chop off everything after the first comma. */
1301 q
= (unsigned char *) index (p
, ',');
1302 full
= make_string (p
, q
? q
- p
: strlen (p
));
1304 #ifdef AMPERSAND_FULL_NAME
1306 q
= (unsigned char *) index (p
, '&');
1307 /* Substitute the login name for the &, upcasing the first character. */
1310 register unsigned char *r
;
1313 login
= Fuser_login_name (make_number (pw
->pw_uid
));
1314 r
= (unsigned char *) alloca (strlen (p
) + SCHARS (login
) + 1);
1315 bcopy (p
, r
, q
- p
);
1317 strcat (r
, SDATA (login
));
1318 r
[q
- p
] = UPCASE (r
[q
- p
]);
1320 full
= build_string (r
);
1322 #endif /* AMPERSAND_FULL_NAME */
1327 DEFUN ("system-name", Fsystem_name
, Ssystem_name
, 0, 0, 0,
1328 doc
: /* Return the name of the machine you are running on, as a string. */)
1331 return Vsystem_name
;
1334 /* For the benefit of callers who don't want to include lisp.h */
1339 if (STRINGP (Vsystem_name
))
1340 return (char *) SDATA (Vsystem_name
);
1345 DEFUN ("emacs-pid", Femacs_pid
, Semacs_pid
, 0, 0, 0,
1346 doc
: /* Return the process ID of Emacs, as an integer. */)
1349 return make_number (getpid ());
1352 DEFUN ("current-time", Fcurrent_time
, Scurrent_time
, 0, 0, 0,
1353 doc
: /* Return the current time, as the number of seconds since 1970-01-01 00:00:00.
1354 The time is returned as a list of three integers. The first has the
1355 most significant 16 bits of the seconds, while the second has the
1356 least significant 16 bits. The third integer gives the microsecond
1359 The microsecond count is zero on systems that do not provide
1360 resolution finer than a second. */)
1364 Lisp_Object result
[3];
1367 XSETINT (result
[0], (EMACS_SECS (t
) >> 16) & 0xffff);
1368 XSETINT (result
[1], (EMACS_SECS (t
) >> 0) & 0xffff);
1369 XSETINT (result
[2], EMACS_USECS (t
));
1371 return Flist (3, result
);
1376 lisp_time_argument (specified_time
, result
, usec
)
1377 Lisp_Object specified_time
;
1381 if (NILP (specified_time
))
1388 *usec
= EMACS_USECS (t
);
1389 *result
= EMACS_SECS (t
);
1393 return time (result
) != -1;
1397 Lisp_Object high
, low
;
1398 high
= Fcar (specified_time
);
1399 CHECK_NUMBER (high
);
1400 low
= Fcdr (specified_time
);
1405 Lisp_Object usec_l
= Fcdr (low
);
1407 usec_l
= Fcar (usec_l
);
1412 CHECK_NUMBER (usec_l
);
1413 *usec
= XINT (usec_l
);
1421 *result
= (XINT (high
) << 16) + (XINT (low
) & 0xffff);
1422 return *result
>> 16 == XINT (high
);
1426 DEFUN ("float-time", Ffloat_time
, Sfloat_time
, 0, 1, 0,
1427 doc
: /* Return the current time, as a float number of seconds since the epoch.
1428 If SPECIFIED-TIME is given, it is the time to convert to float
1429 instead of the current time. The argument should have the form
1430 (HIGH LOW . IGNORED). Thus, you can use times obtained from
1431 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
1432 have the form (HIGH . LOW), but this is considered obsolete.
1434 WARNING: Since the result is floating point, it may not be exact.
1435 Do not use this function if precise time stamps are required. */)
1437 Lisp_Object specified_time
;
1442 if (! lisp_time_argument (specified_time
, &sec
, &usec
))
1443 error ("Invalid time specification");
1445 return make_float ((sec
* 1e6
+ usec
) / 1e6
);
1448 /* Write information into buffer S of size MAXSIZE, according to the
1449 FORMAT of length FORMAT_LEN, using time information taken from *TP.
1450 Default to Universal Time if UT is nonzero, local time otherwise.
1451 Return the number of bytes written, not including the terminating
1452 '\0'. If S is NULL, nothing will be written anywhere; so to
1453 determine how many bytes would be written, use NULL for S and
1454 ((size_t) -1) for MAXSIZE.
1456 This function behaves like emacs_strftimeu, except it allows null
1459 emacs_memftimeu (s
, maxsize
, format
, format_len
, tp
, ut
)
1464 const struct tm
*tp
;
1469 /* Loop through all the null-terminated strings in the format
1470 argument. Normally there's just one null-terminated string, but
1471 there can be arbitrarily many, concatenated together, if the
1472 format contains '\0' bytes. emacs_strftimeu stops at the first
1473 '\0' byte so we must invoke it separately for each such string. */
1482 result
= emacs_strftimeu (s
, maxsize
, format
, tp
, ut
);
1486 if (result
== 0 && s
[0] != '\0')
1491 maxsize
-= result
+ 1;
1493 len
= strlen (format
);
1494 if (len
== format_len
)
1498 format_len
-= len
+ 1;
1502 DEFUN ("format-time-string", Fformat_time_string
, Sformat_time_string
, 1, 3, 0,
1503 doc
: /* Use FORMAT-STRING to format the time TIME, or now if omitted.
1504 TIME is specified as (HIGH LOW . IGNORED), as returned by
1505 `current-time' or `file-attributes'. The obsolete form (HIGH . LOW)
1506 is also still accepted.
1507 The third, optional, argument UNIVERSAL, if non-nil, means describe TIME
1508 as Universal Time; nil means describe TIME in the local time zone.
1509 The value is a copy of FORMAT-STRING, but with certain constructs replaced
1510 by text that describes the specified date and time in TIME:
1512 %Y is the year, %y within the century, %C the century.
1513 %G is the year corresponding to the ISO week, %g within the century.
1514 %m is the numeric month.
1515 %b and %h are the locale's abbreviated month name, %B the full name.
1516 %d is the day of the month, zero-padded, %e is blank-padded.
1517 %u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.
1518 %a is the locale's abbreviated name of the day of week, %A the full name.
1519 %U is the week number starting on Sunday, %W starting on Monday,
1520 %V according to ISO 8601.
1521 %j is the day of the year.
1523 %H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H
1524 only blank-padded, %l is like %I blank-padded.
1525 %p is the locale's equivalent of either AM or PM.
1528 %Z is the time zone name, %z is the numeric form.
1529 %s is the number of seconds since 1970-01-01 00:00:00 +0000.
1531 %c is the locale's date and time format.
1532 %x is the locale's "preferred" date format.
1533 %D is like "%m/%d/%y".
1535 %R is like "%H:%M", %T is like "%H:%M:%S", %r is like "%I:%M:%S %p".
1536 %X is the locale's "preferred" time format.
1538 Finally, %n is a newline, %t is a tab, %% is a literal %.
1540 Certain flags and modifiers are available with some format controls.
1541 The flags are `_', `-', `^' and `#'. For certain characters X,
1542 %_X is like %X, but padded with blanks; %-X is like %X,
1543 but without padding. %^X is like %X, but with all textual
1544 characters up-cased; %#X is like %X, but with letter-case of
1545 all textual characters reversed.
1546 %NX (where N stands for an integer) is like %X,
1547 but takes up at least N (a number) positions.
1548 The modifiers are `E' and `O'. For certain characters X,
1549 %EX is a locale's alternative version of %X;
1550 %OX is like %X, but uses the locale's number symbols.
1552 For example, to produce full ISO 8601 format, use "%Y-%m-%dT%T%z". */)
1553 (format_string
, time
, universal
)
1554 Lisp_Object format_string
, time
, universal
;
1559 int ut
= ! NILP (universal
);
1561 CHECK_STRING (format_string
);
1563 if (! lisp_time_argument (time
, &value
, NULL
))
1564 error ("Invalid time specification");
1566 format_string
= code_convert_string_norecord (format_string
,
1567 Vlocale_coding_system
, 1);
1569 /* This is probably enough. */
1570 size
= SBYTES (format_string
) * 6 + 50;
1572 tm
= ut
? gmtime (&value
) : localtime (&value
);
1574 error ("Specified time is not representable");
1576 synchronize_system_time_locale ();
1580 char *buf
= (char *) alloca (size
+ 1);
1584 result
= emacs_memftimeu (buf
, size
, SDATA (format_string
),
1585 SBYTES (format_string
),
1587 if ((result
> 0 && result
< size
) || (result
== 0 && buf
[0] == '\0'))
1588 return code_convert_string_norecord (make_string (buf
, result
),
1589 Vlocale_coding_system
, 0);
1591 /* If buffer was too small, make it bigger and try again. */
1592 result
= emacs_memftimeu (NULL
, (size_t) -1,
1593 SDATA (format_string
),
1594 SBYTES (format_string
),
1600 DEFUN ("decode-time", Fdecode_time
, Sdecode_time
, 0, 1, 0,
1601 doc
: /* Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST ZONE).
1602 The optional SPECIFIED-TIME should be a list of (HIGH LOW . IGNORED),
1603 as from `current-time' and `file-attributes', or `nil' to use the
1604 current time. The obsolete form (HIGH . LOW) is also still accepted.
1605 The list has the following nine members: SEC is an integer between 0
1606 and 60; SEC is 60 for a leap second, which only some operating systems
1607 support. MINUTE is an integer between 0 and 59. HOUR is an integer
1608 between 0 and 23. DAY is an integer between 1 and 31. MONTH is an
1609 integer between 1 and 12. YEAR is an integer indicating the
1610 four-digit year. DOW is the day of week, an integer between 0 and 6,
1611 where 0 is Sunday. DST is t if daylight savings time is effect,
1612 otherwise nil. ZONE is an integer indicating the number of seconds
1613 east of Greenwich. (Note that Common Lisp has different meanings for
1616 Lisp_Object specified_time
;
1620 struct tm
*decoded_time
;
1621 Lisp_Object list_args
[9];
1623 if (! lisp_time_argument (specified_time
, &time_spec
, NULL
))
1624 error ("Invalid time specification");
1626 decoded_time
= localtime (&time_spec
);
1628 error ("Specified time is not representable");
1629 XSETFASTINT (list_args
[0], decoded_time
->tm_sec
);
1630 XSETFASTINT (list_args
[1], decoded_time
->tm_min
);
1631 XSETFASTINT (list_args
[2], decoded_time
->tm_hour
);
1632 XSETFASTINT (list_args
[3], decoded_time
->tm_mday
);
1633 XSETFASTINT (list_args
[4], decoded_time
->tm_mon
+ 1);
1634 XSETINT (list_args
[5], decoded_time
->tm_year
+ 1900);
1635 XSETFASTINT (list_args
[6], decoded_time
->tm_wday
);
1636 list_args
[7] = (decoded_time
->tm_isdst
)? Qt
: Qnil
;
1638 /* Make a copy, in case gmtime modifies the struct. */
1639 save_tm
= *decoded_time
;
1640 decoded_time
= gmtime (&time_spec
);
1641 if (decoded_time
== 0)
1642 list_args
[8] = Qnil
;
1644 XSETINT (list_args
[8], tm_diff (&save_tm
, decoded_time
));
1645 return Flist (9, list_args
);
1648 DEFUN ("encode-time", Fencode_time
, Sencode_time
, 6, MANY
, 0,
1649 doc
: /* Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.
1650 This is the reverse operation of `decode-time', which see.
1651 ZONE defaults to the current time zone rule. This can
1652 be a string or t (as from `set-time-zone-rule'), or it can be a list
1653 \(as from `current-time-zone') or an integer (as from `decode-time')
1654 applied without consideration for daylight savings time.
1656 You can pass more than 7 arguments; then the first six arguments
1657 are used as SECOND through YEAR, and the *last* argument is used as ZONE.
1658 The intervening arguments are ignored.
1659 This feature lets (apply 'encode-time (decode-time ...)) work.
1661 Out-of-range values for SECOND, MINUTE, HOUR, DAY, or MONTH are allowed;
1662 for example, a DAY of 0 means the day preceding the given month.
1663 Year numbers less than 100 are treated just like other year numbers.
1664 If you want them to stand for years in this century, you must do that yourself.
1666 Years before 1970 are not guaranteed to work. On some systems,
1667 year values as low as 1901 do work.
1669 usage: (encode-time SECOND MINUTE HOUR DAY MONTH YEAR &optional ZONE) */)
1672 register Lisp_Object
*args
;
1676 Lisp_Object zone
= (nargs
> 6 ? args
[nargs
- 1] : Qnil
);
1678 CHECK_NUMBER (args
[0]); /* second */
1679 CHECK_NUMBER (args
[1]); /* minute */
1680 CHECK_NUMBER (args
[2]); /* hour */
1681 CHECK_NUMBER (args
[3]); /* day */
1682 CHECK_NUMBER (args
[4]); /* month */
1683 CHECK_NUMBER (args
[5]); /* year */
1685 tm
.tm_sec
= XINT (args
[0]);
1686 tm
.tm_min
= XINT (args
[1]);
1687 tm
.tm_hour
= XINT (args
[2]);
1688 tm
.tm_mday
= XINT (args
[3]);
1689 tm
.tm_mon
= XINT (args
[4]) - 1;
1690 tm
.tm_year
= XINT (args
[5]) - 1900;
1696 time
= mktime (&tm
);
1701 char **oldenv
= environ
, **newenv
;
1705 else if (STRINGP (zone
))
1706 tzstring
= (char *) SDATA (zone
);
1707 else if (INTEGERP (zone
))
1709 int abszone
= abs (XINT (zone
));
1710 sprintf (tzbuf
, "XXX%s%d:%02d:%02d", "-" + (XINT (zone
) < 0),
1711 abszone
/ (60*60), (abszone
/60) % 60, abszone
% 60);
1715 error ("Invalid time zone specification");
1717 /* Set TZ before calling mktime; merely adjusting mktime's returned
1718 value doesn't suffice, since that would mishandle leap seconds. */
1719 set_time_zone_rule (tzstring
);
1721 time
= mktime (&tm
);
1723 /* Restore TZ to previous value. */
1727 #ifdef LOCALTIME_CACHE
1732 if (time
== (time_t) -1)
1733 error ("Specified time is not representable");
1735 return make_time (time
);
1738 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
, 0, 1, 0,
1739 doc
: /* Return the current time, as a human-readable string.
1740 Programs can use this function to decode a time,
1741 since the number of columns in each field is fixed.
1742 The format is `Sun Sep 16 01:03:52 1973'.
1743 However, see also the functions `decode-time' and `format-time-string'
1744 which provide a much more powerful and general facility.
1746 If SPECIFIED-TIME is given, it is a time to format instead of the
1747 current time. The argument should have the form (HIGH LOW . IGNORED).
1748 Thus, you can use times obtained from `current-time' and from
1749 `file-attributes'. SPECIFIED-TIME can also have the form (HIGH . LOW),
1750 but this is considered obsolete. */)
1752 Lisp_Object specified_time
;
1758 if (! lisp_time_argument (specified_time
, &value
, NULL
))
1760 tem
= (char *) ctime (&value
);
1762 strncpy (buf
, tem
, 24);
1765 return build_string (buf
);
1768 #define TM_YEAR_BASE 1900
1770 /* Yield A - B, measured in seconds.
1771 This function is copied from the GNU C Library. */
1776 /* Compute intervening leap days correctly even if year is negative.
1777 Take care to avoid int overflow in leap day calculations,
1778 but it's OK to assume that A and B are close to each other. */
1779 int a4
= (a
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (a
->tm_year
& 3);
1780 int b4
= (b
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (b
->tm_year
& 3);
1781 int a100
= a4
/ 25 - (a4
% 25 < 0);
1782 int b100
= b4
/ 25 - (b4
% 25 < 0);
1783 int a400
= a100
>> 2;
1784 int b400
= b100
>> 2;
1785 int intervening_leap_days
= (a4
- b4
) - (a100
- b100
) + (a400
- b400
);
1786 int years
= a
->tm_year
- b
->tm_year
;
1787 int days
= (365 * years
+ intervening_leap_days
1788 + (a
->tm_yday
- b
->tm_yday
));
1789 return (60 * (60 * (24 * days
+ (a
->tm_hour
- b
->tm_hour
))
1790 + (a
->tm_min
- b
->tm_min
))
1791 + (a
->tm_sec
- b
->tm_sec
));
1794 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 1, 0,
1795 doc
: /* Return the offset and name for the local time zone.
1796 This returns a list of the form (OFFSET NAME).
1797 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).
1798 A negative value means west of Greenwich.
1799 NAME is a string giving the name of the time zone.
1800 If SPECIFIED-TIME is given, the time zone offset is determined from it
1801 instead of using the current time. The argument should have the form
1802 (HIGH LOW . IGNORED). Thus, you can use times obtained from
1803 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
1804 have the form (HIGH . LOW), but this is considered obsolete.
1806 Some operating systems cannot provide all this information to Emacs;
1807 in this case, `current-time-zone' returns a list containing nil for
1808 the data it can't find. */)
1810 Lisp_Object specified_time
;
1816 if (lisp_time_argument (specified_time
, &value
, NULL
)
1817 && (t
= gmtime (&value
)) != 0
1818 && (gmt
= *t
, t
= localtime (&value
)) != 0)
1820 int offset
= tm_diff (t
, &gmt
);
1825 s
= (char *)t
->tm_zone
;
1826 #else /* not HAVE_TM_ZONE */
1828 if (t
->tm_isdst
== 0 || t
->tm_isdst
== 1)
1829 s
= tzname
[t
->tm_isdst
];
1831 #endif /* not HAVE_TM_ZONE */
1833 #if defined HAVE_TM_ZONE || defined HAVE_TZNAME
1836 /* On Japanese w32, we can get a Japanese string as time
1837 zone name. Don't accept that. */
1839 for (p
= s
; *p
&& (isalnum ((unsigned char)*p
) || *p
== ' '); ++p
)
1848 /* No local time zone name is available; use "+-NNNN" instead. */
1849 int am
= (offset
< 0 ? -offset
: offset
) / 60;
1850 sprintf (buf
, "%c%02d%02d", (offset
< 0 ? '-' : '+'), am
/60, am
%60);
1853 return Fcons (make_number (offset
), Fcons (build_string (s
), Qnil
));
1856 return Fmake_list (make_number (2), Qnil
);
1859 /* This holds the value of `environ' produced by the previous
1860 call to Fset_time_zone_rule, or 0 if Fset_time_zone_rule
1861 has never been called. */
1862 static char **environbuf
;
1864 DEFUN ("set-time-zone-rule", Fset_time_zone_rule
, Sset_time_zone_rule
, 1, 1, 0,
1865 doc
: /* Set the local time zone using TZ, a string specifying a time zone rule.
1866 If TZ is nil, use implementation-defined default time zone information.
1867 If TZ is t, use Universal Time. */)
1875 else if (EQ (tz
, Qt
))
1880 tzstring
= (char *) SDATA (tz
);
1883 set_time_zone_rule (tzstring
);
1886 environbuf
= environ
;
1891 #ifdef LOCALTIME_CACHE
1893 /* These two values are known to load tz files in buggy implementations,
1894 i.e. Solaris 1 executables running under either Solaris 1 or Solaris 2.
1895 Their values shouldn't matter in non-buggy implementations.
1896 We don't use string literals for these strings,
1897 since if a string in the environment is in readonly
1898 storage, it runs afoul of bugs in SVR4 and Solaris 2.3.
1899 See Sun bugs 1113095 and 1114114, ``Timezone routines
1900 improperly modify environment''. */
1902 static char set_time_zone_rule_tz1
[] = "TZ=GMT+0";
1903 static char set_time_zone_rule_tz2
[] = "TZ=GMT+1";
1907 /* Set the local time zone rule to TZSTRING.
1908 This allocates memory into `environ', which it is the caller's
1909 responsibility to free. */
1912 set_time_zone_rule (tzstring
)
1916 char **from
, **to
, **newenv
;
1918 /* Make the ENVIRON vector longer with room for TZSTRING. */
1919 for (from
= environ
; *from
; from
++)
1921 envptrs
= from
- environ
+ 2;
1922 newenv
= to
= (char **) xmalloc (envptrs
* sizeof (char *)
1923 + (tzstring
? strlen (tzstring
) + 4 : 0));
1925 /* Add TZSTRING to the end of environ, as a value for TZ. */
1928 char *t
= (char *) (to
+ envptrs
);
1930 strcat (t
, tzstring
);
1934 /* Copy the old environ vector elements into NEWENV,
1935 but don't copy the TZ variable.
1936 So we have only one definition of TZ, which came from TZSTRING. */
1937 for (from
= environ
; *from
; from
++)
1938 if (strncmp (*from
, "TZ=", 3) != 0)
1944 /* If we do have a TZSTRING, NEWENV points to the vector slot where
1945 the TZ variable is stored. If we do not have a TZSTRING,
1946 TO points to the vector slot which has the terminating null. */
1948 #ifdef LOCALTIME_CACHE
1950 /* In SunOS 4.1.3_U1 and 4.1.4, if TZ has a value like
1951 "US/Pacific" that loads a tz file, then changes to a value like
1952 "XXX0" that does not load a tz file, and then changes back to
1953 its original value, the last change is (incorrectly) ignored.
1954 Also, if TZ changes twice in succession to values that do
1955 not load a tz file, tzset can dump core (see Sun bug#1225179).
1956 The following code works around these bugs. */
1960 /* Temporarily set TZ to a value that loads a tz file
1961 and that differs from tzstring. */
1963 *newenv
= (strcmp (tzstring
, set_time_zone_rule_tz1
+ 3) == 0
1964 ? set_time_zone_rule_tz2
: set_time_zone_rule_tz1
);
1970 /* The implied tzstring is unknown, so temporarily set TZ to
1971 two different values that each load a tz file. */
1972 *to
= set_time_zone_rule_tz1
;
1975 *to
= set_time_zone_rule_tz2
;
1980 /* Now TZ has the desired value, and tzset can be invoked safely. */
1987 /* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC
1988 (if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a
1989 type of object is Lisp_String). INHERIT is passed to
1990 INSERT_FROM_STRING_FUNC as the last argument. */
1993 general_insert_function (insert_func
, insert_from_string_func
,
1994 inherit
, nargs
, args
)
1995 void (*insert_func
) P_ ((const unsigned char *, int));
1996 void (*insert_from_string_func
) P_ ((Lisp_Object
, int, int, int, int, int));
1998 register Lisp_Object
*args
;
2000 register int argnum
;
2001 register Lisp_Object val
;
2003 for (argnum
= 0; argnum
< nargs
; argnum
++)
2009 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2012 if (!NILP (current_buffer
->enable_multibyte_characters
))
2013 len
= CHAR_STRING (XFASTINT (val
), str
);
2016 str
[0] = (ASCII_CHAR_P (XINT (val
))
2018 : multibyte_char_to_unibyte (XINT (val
), Qnil
));
2021 (*insert_func
) (str
, len
);
2023 else if (STRINGP (val
))
2025 (*insert_from_string_func
) (val
, 0, 0,
2032 val
= wrong_type_argument (Qchar_or_string_p
, val
);
2046 /* Callers passing one argument to Finsert need not gcpro the
2047 argument "array", since the only element of the array will
2048 not be used after calling insert or insert_from_string, so
2049 we don't care if it gets trashed. */
2051 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
2052 doc
: /* Insert the arguments, either strings or characters, at point.
2053 Point and before-insertion markers move forward to end up
2054 after the inserted text.
2055 Any other markers at the point of insertion remain before the text.
2057 If the current buffer is multibyte, unibyte strings are converted
2058 to multibyte for insertion (see `string-make-multibyte').
2059 If the current buffer is unibyte, multibyte strings are converted
2060 to unibyte for insertion (see `string-make-unibyte').
2062 When operating on binary data, it may be necessary to preserve the
2063 original bytes of a unibyte string when inserting it into a multibyte
2064 buffer; to accomplish this, apply `string-as-multibyte' to the string
2065 and insert the result.
2067 usage: (insert &rest ARGS) */)
2070 register Lisp_Object
*args
;
2072 general_insert_function (insert
, insert_from_string
, 0, nargs
, args
);
2076 DEFUN ("insert-and-inherit", Finsert_and_inherit
, Sinsert_and_inherit
,
2078 doc
: /* Insert the arguments at point, inheriting properties from adjoining text.
2079 Point and before-insertion markers move forward to end up
2080 after the inserted text.
2081 Any other markers at the point of insertion remain before the text.
2083 If the current buffer is multibyte, unibyte strings are converted
2084 to multibyte for insertion (see `unibyte-char-to-multibyte').
2085 If the current buffer is unibyte, multibyte strings are converted
2086 to unibyte for insertion.
2088 usage: (insert-and-inherit &rest ARGS) */)
2091 register Lisp_Object
*args
;
2093 general_insert_function (insert_and_inherit
, insert_from_string
, 1,
2098 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
2099 doc
: /* Insert strings or characters at point, relocating markers after the text.
2100 Point and markers move forward to end up after the inserted text.
2102 If the current buffer is multibyte, unibyte strings are converted
2103 to multibyte for insertion (see `unibyte-char-to-multibyte').
2104 If the current buffer is unibyte, multibyte strings are converted
2105 to unibyte for insertion.
2107 usage: (insert-before-markers &rest ARGS) */)
2110 register Lisp_Object
*args
;
2112 general_insert_function (insert_before_markers
,
2113 insert_from_string_before_markers
, 0,
2118 DEFUN ("insert-before-markers-and-inherit", Finsert_and_inherit_before_markers
,
2119 Sinsert_and_inherit_before_markers
, 0, MANY
, 0,
2120 doc
: /* Insert text at point, relocating markers and inheriting properties.
2121 Point and markers move forward to end up after the inserted text.
2123 If the current buffer is multibyte, unibyte strings are converted
2124 to multibyte for insertion (see `unibyte-char-to-multibyte').
2125 If the current buffer is unibyte, multibyte strings are converted
2126 to unibyte for insertion.
2128 usage: (insert-before-markers-and-inherit &rest ARGS) */)
2131 register Lisp_Object
*args
;
2133 general_insert_function (insert_before_markers_and_inherit
,
2134 insert_from_string_before_markers
, 1,
2139 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 2, 3, 0,
2140 doc
: /* Insert COUNT (second arg) copies of CHARACTER (first arg).
2141 Both arguments are required.
2142 Point, and before-insertion markers, are relocated as in the function `insert'.
2143 The optional third arg INHERIT, if non-nil, says to inherit text properties
2144 from adjoining text, if those properties are sticky. */)
2145 (character
, count
, inherit
)
2146 Lisp_Object character
, count
, inherit
;
2148 register unsigned char *string
;
2149 register int strlen
;
2152 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2154 CHECK_NUMBER (character
);
2155 CHECK_NUMBER (count
);
2157 if (!NILP (current_buffer
->enable_multibyte_characters
))
2158 len
= CHAR_STRING (XFASTINT (character
), str
);
2160 str
[0] = XFASTINT (character
), len
= 1;
2161 n
= XINT (count
) * len
;
2164 strlen
= min (n
, 256 * len
);
2165 string
= (unsigned char *) alloca (strlen
);
2166 for (i
= 0; i
< strlen
; i
++)
2167 string
[i
] = str
[i
% len
];
2171 if (!NILP (inherit
))
2172 insert_and_inherit (string
, strlen
);
2174 insert (string
, strlen
);
2179 if (!NILP (inherit
))
2180 insert_and_inherit (string
, n
);
2187 DEFUN ("insert-byte", Finsert_byte
, Sinsert_byte
, 2, 3, 0,
2188 doc
: /* Insert COUNT (second arg) copies of BYTE (first arg).
2189 Both arguments are required.
2190 BYTE is a number of the range 0..255.
2192 If BYTE is 128..255 and the current buffer is multibyte, the
2193 corresponding eight-bit character is inserted.
2195 Point, and before-insertion markers, are relocated as in the function `insert'.
2196 The optional third arg INHERIT, if non-nil, says to inherit text properties
2197 from adjoining text, if those properties are sticky. */)
2198 (byte
, count
, inherit
)
2199 Lisp_Object byte
, count
, inherit
;
2201 CHECK_NUMBER (byte
);
2202 if (XINT (byte
) < 0 || XINT (byte
) > 255)
2203 args_out_of_range_3 (byte
, make_number (0), make_number (255));
2204 if (XINT (byte
) >= 128
2205 && ! NILP (current_buffer
->enable_multibyte_characters
))
2206 XSETFASTINT (byte
, BYTE8_TO_CHAR (XINT (byte
)));
2207 return Finsert_char (byte
, count
, inherit
);
2211 /* Making strings from buffer contents. */
2213 /* Return a Lisp_String containing the text of the current buffer from
2214 START to END. If text properties are in use and the current buffer
2215 has properties in the range specified, the resulting string will also
2216 have them, if PROPS is nonzero.
2218 We don't want to use plain old make_string here, because it calls
2219 make_uninit_string, which can cause the buffer arena to be
2220 compacted. make_string has no way of knowing that the data has
2221 been moved, and thus copies the wrong data into the string. This
2222 doesn't effect most of the other users of make_string, so it should
2223 be left as is. But we should use this function when conjuring
2224 buffer substrings. */
2227 make_buffer_string (start
, end
, props
)
2231 int start_byte
= CHAR_TO_BYTE (start
);
2232 int end_byte
= CHAR_TO_BYTE (end
);
2234 return make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
);
2237 /* Return a Lisp_String containing the text of the current buffer from
2238 START / START_BYTE to END / END_BYTE.
2240 If text properties are in use and the current buffer
2241 has properties in the range specified, the resulting string will also
2242 have them, if PROPS is nonzero.
2244 We don't want to use plain old make_string here, because it calls
2245 make_uninit_string, which can cause the buffer arena to be
2246 compacted. make_string has no way of knowing that the data has
2247 been moved, and thus copies the wrong data into the string. This
2248 doesn't effect most of the other users of make_string, so it should
2249 be left as is. But we should use this function when conjuring
2250 buffer substrings. */
2253 make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
)
2254 int start
, start_byte
, end
, end_byte
;
2257 Lisp_Object result
, tem
, tem1
;
2259 if (start
< GPT
&& GPT
< end
)
2262 if (! NILP (current_buffer
->enable_multibyte_characters
))
2263 result
= make_uninit_multibyte_string (end
- start
, end_byte
- start_byte
);
2265 result
= make_uninit_string (end
- start
);
2266 bcopy (BYTE_POS_ADDR (start_byte
), SDATA (result
),
2267 end_byte
- start_byte
);
2269 /* If desired, update and copy the text properties. */
2272 update_buffer_properties (start
, end
);
2274 tem
= Fnext_property_change (make_number (start
), Qnil
, make_number (end
));
2275 tem1
= Ftext_properties_at (make_number (start
), Qnil
);
2277 if (XINT (tem
) != end
|| !NILP (tem1
))
2278 copy_intervals_to_string (result
, current_buffer
, start
,
2285 /* Call Vbuffer_access_fontify_functions for the range START ... END
2286 in the current buffer, if necessary. */
2289 update_buffer_properties (start
, end
)
2292 /* If this buffer has some access functions,
2293 call them, specifying the range of the buffer being accessed. */
2294 if (!NILP (Vbuffer_access_fontify_functions
))
2296 Lisp_Object args
[3];
2299 args
[0] = Qbuffer_access_fontify_functions
;
2300 XSETINT (args
[1], start
);
2301 XSETINT (args
[2], end
);
2303 /* But don't call them if we can tell that the work
2304 has already been done. */
2305 if (!NILP (Vbuffer_access_fontified_property
))
2307 tem
= Ftext_property_any (args
[1], args
[2],
2308 Vbuffer_access_fontified_property
,
2311 Frun_hook_with_args (3, args
);
2314 Frun_hook_with_args (3, args
);
2318 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
2319 doc
: /* Return the contents of part of the current buffer as a string.
2320 The two arguments START and END are character positions;
2321 they can be in either order.
2322 The string returned is multibyte if the buffer is multibyte.
2324 This function copies the text properties of that part of the buffer
2325 into the result string; if you don't want the text properties,
2326 use `buffer-substring-no-properties' instead. */)
2328 Lisp_Object start
, end
;
2332 validate_region (&start
, &end
);
2336 return make_buffer_string (b
, e
, 1);
2339 DEFUN ("buffer-substring-no-properties", Fbuffer_substring_no_properties
,
2340 Sbuffer_substring_no_properties
, 2, 2, 0,
2341 doc
: /* Return the characters of part of the buffer, without the text properties.
2342 The two arguments START and END are character positions;
2343 they can be in either order. */)
2345 Lisp_Object start
, end
;
2349 validate_region (&start
, &end
);
2353 return make_buffer_string (b
, e
, 0);
2356 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
2357 doc
: /* Return the contents of the current buffer as a string.
2358 If narrowing is in effect, this function returns only the visible part
2362 return make_buffer_string (BEGV
, ZV
, 1);
2365 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
2367 doc
: /* Insert before point a substring of the contents of BUFFER.
2368 BUFFER may be a buffer or a buffer name.
2369 Arguments START and END are character positions specifying the substring.
2370 They default to the values of (point-min) and (point-max) in BUFFER. */)
2371 (buffer
, start
, end
)
2372 Lisp_Object buffer
, start
, end
;
2374 register int b
, e
, temp
;
2375 register struct buffer
*bp
, *obuf
;
2378 buf
= Fget_buffer (buffer
);
2382 if (NILP (bp
->name
))
2383 error ("Selecting deleted buffer");
2389 CHECK_NUMBER_COERCE_MARKER (start
);
2396 CHECK_NUMBER_COERCE_MARKER (end
);
2401 temp
= b
, b
= e
, e
= temp
;
2403 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
2404 args_out_of_range (start
, end
);
2406 obuf
= current_buffer
;
2407 set_buffer_internal_1 (bp
);
2408 update_buffer_properties (b
, e
);
2409 set_buffer_internal_1 (obuf
);
2411 insert_from_buffer (bp
, b
, e
- b
, 0);
2415 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
2417 doc
: /* Compare two substrings of two buffers; return result as number.
2418 the value is -N if first string is less after N-1 chars,
2419 +N if first string is greater after N-1 chars, or 0 if strings match.
2420 Each substring is represented as three arguments: BUFFER, START and END.
2421 That makes six args in all, three for each substring.
2423 The value of `case-fold-search' in the current buffer
2424 determines whether case is significant or ignored. */)
2425 (buffer1
, start1
, end1
, buffer2
, start2
, end2
)
2426 Lisp_Object buffer1
, start1
, end1
, buffer2
, start2
, end2
;
2428 register int begp1
, endp1
, begp2
, endp2
, temp
;
2429 register struct buffer
*bp1
, *bp2
;
2430 register Lisp_Object
*trt
2431 = (!NILP (current_buffer
->case_fold_search
)
2432 ? XCHAR_TABLE (current_buffer
->case_canon_table
)->contents
: 0);
2434 int i1
, i2
, i1_byte
, i2_byte
;
2436 /* Find the first buffer and its substring. */
2439 bp1
= current_buffer
;
2443 buf1
= Fget_buffer (buffer1
);
2446 bp1
= XBUFFER (buf1
);
2447 if (NILP (bp1
->name
))
2448 error ("Selecting deleted buffer");
2452 begp1
= BUF_BEGV (bp1
);
2455 CHECK_NUMBER_COERCE_MARKER (start1
);
2456 begp1
= XINT (start1
);
2459 endp1
= BUF_ZV (bp1
);
2462 CHECK_NUMBER_COERCE_MARKER (end1
);
2463 endp1
= XINT (end1
);
2467 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
2469 if (!(BUF_BEGV (bp1
) <= begp1
2471 && endp1
<= BUF_ZV (bp1
)))
2472 args_out_of_range (start1
, end1
);
2474 /* Likewise for second substring. */
2477 bp2
= current_buffer
;
2481 buf2
= Fget_buffer (buffer2
);
2484 bp2
= XBUFFER (buf2
);
2485 if (NILP (bp2
->name
))
2486 error ("Selecting deleted buffer");
2490 begp2
= BUF_BEGV (bp2
);
2493 CHECK_NUMBER_COERCE_MARKER (start2
);
2494 begp2
= XINT (start2
);
2497 endp2
= BUF_ZV (bp2
);
2500 CHECK_NUMBER_COERCE_MARKER (end2
);
2501 endp2
= XINT (end2
);
2505 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
2507 if (!(BUF_BEGV (bp2
) <= begp2
2509 && endp2
<= BUF_ZV (bp2
)))
2510 args_out_of_range (start2
, end2
);
2514 i1_byte
= buf_charpos_to_bytepos (bp1
, i1
);
2515 i2_byte
= buf_charpos_to_bytepos (bp2
, i2
);
2517 while (i1
< endp1
&& i2
< endp2
)
2519 /* When we find a mismatch, we must compare the
2520 characters, not just the bytes. */
2525 if (! NILP (bp1
->enable_multibyte_characters
))
2527 c1
= BUF_FETCH_MULTIBYTE_CHAR (bp1
, i1_byte
);
2528 BUF_INC_POS (bp1
, i1_byte
);
2533 c1
= BUF_FETCH_BYTE (bp1
, i1
);
2534 c1
= unibyte_char_to_multibyte (c1
);
2538 if (! NILP (bp2
->enable_multibyte_characters
))
2540 c2
= BUF_FETCH_MULTIBYTE_CHAR (bp2
, i2_byte
);
2541 BUF_INC_POS (bp2
, i2_byte
);
2546 c2
= BUF_FETCH_BYTE (bp2
, i2
);
2547 c2
= unibyte_char_to_multibyte (c2
);
2553 c1
= XINT (trt
[c1
]);
2554 c2
= XINT (trt
[c2
]);
2557 return make_number (- 1 - chars
);
2559 return make_number (chars
+ 1);
2564 /* The strings match as far as they go.
2565 If one is shorter, that one is less. */
2566 if (chars
< endp1
- begp1
)
2567 return make_number (chars
+ 1);
2568 else if (chars
< endp2
- begp2
)
2569 return make_number (- chars
- 1);
2571 /* Same length too => they are equal. */
2572 return make_number (0);
2576 subst_char_in_region_unwind (arg
)
2579 return current_buffer
->undo_list
= arg
;
2583 subst_char_in_region_unwind_1 (arg
)
2586 return current_buffer
->filename
= arg
;
2589 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
2590 Ssubst_char_in_region
, 4, 5, 0,
2591 doc
: /* From START to END, replace FROMCHAR with TOCHAR each time it occurs.
2592 If optional arg NOUNDO is non-nil, don't record this change for undo
2593 and don't mark the buffer as really changed.
2594 Both characters must have the same length of multi-byte form. */)
2595 (start
, end
, fromchar
, tochar
, noundo
)
2596 Lisp_Object start
, end
, fromchar
, tochar
, noundo
;
2598 register int pos
, pos_byte
, stop
, i
, len
, end_byte
;
2600 unsigned char fromstr
[MAX_MULTIBYTE_LENGTH
], tostr
[MAX_MULTIBYTE_LENGTH
];
2602 int count
= SPECPDL_INDEX ();
2603 #define COMBINING_NO 0
2604 #define COMBINING_BEFORE 1
2605 #define COMBINING_AFTER 2
2606 #define COMBINING_BOTH (COMBINING_BEFORE | COMBINING_AFTER)
2607 int maybe_byte_combining
= COMBINING_NO
;
2608 int last_changed
= 0;
2609 int multibyte_p
= !NILP (current_buffer
->enable_multibyte_characters
);
2611 validate_region (&start
, &end
);
2612 CHECK_NUMBER (fromchar
);
2613 CHECK_NUMBER (tochar
);
2617 len
= CHAR_STRING (XFASTINT (fromchar
), fromstr
);
2618 if (CHAR_STRING (XFASTINT (tochar
), tostr
) != len
)
2619 error ("Characters in subst-char-in-region have different byte-lengths");
2620 if (!ASCII_BYTE_P (*tostr
))
2622 /* If *TOSTR is in the range 0x80..0x9F and TOCHAR is not a
2623 complete multibyte character, it may be combined with the
2624 after bytes. If it is in the range 0xA0..0xFF, it may be
2625 combined with the before and after bytes. */
2626 if (!CHAR_HEAD_P (*tostr
))
2627 maybe_byte_combining
= COMBINING_BOTH
;
2628 else if (BYTES_BY_CHAR_HEAD (*tostr
) > len
)
2629 maybe_byte_combining
= COMBINING_AFTER
;
2635 fromstr
[0] = XFASTINT (fromchar
);
2636 tostr
[0] = XFASTINT (tochar
);
2640 pos_byte
= CHAR_TO_BYTE (pos
);
2641 stop
= CHAR_TO_BYTE (XINT (end
));
2644 /* If we don't want undo, turn off putting stuff on the list.
2645 That's faster than getting rid of things,
2646 and it prevents even the entry for a first change.
2647 Also inhibit locking the file. */
2650 record_unwind_protect (subst_char_in_region_unwind
,
2651 current_buffer
->undo_list
);
2652 current_buffer
->undo_list
= Qt
;
2653 /* Don't do file-locking. */
2654 record_unwind_protect (subst_char_in_region_unwind_1
,
2655 current_buffer
->filename
);
2656 current_buffer
->filename
= Qnil
;
2659 if (pos_byte
< GPT_BYTE
)
2660 stop
= min (stop
, GPT_BYTE
);
2663 int pos_byte_next
= pos_byte
;
2665 if (pos_byte
>= stop
)
2667 if (pos_byte
>= end_byte
) break;
2670 p
= BYTE_POS_ADDR (pos_byte
);
2672 INC_POS (pos_byte_next
);
2675 if (pos_byte_next
- pos_byte
== len
2676 && p
[0] == fromstr
[0]
2678 || (p
[1] == fromstr
[1]
2679 && (len
== 2 || (p
[2] == fromstr
[2]
2680 && (len
== 3 || p
[3] == fromstr
[3]))))))
2685 modify_region (current_buffer
, changed
, XINT (end
));
2687 if (! NILP (noundo
))
2689 if (MODIFF
- 1 == SAVE_MODIFF
)
2691 if (MODIFF
- 1 == current_buffer
->auto_save_modified
)
2692 current_buffer
->auto_save_modified
++;
2696 /* Take care of the case where the new character
2697 combines with neighboring bytes. */
2698 if (maybe_byte_combining
2699 && (maybe_byte_combining
== COMBINING_AFTER
2700 ? (pos_byte_next
< Z_BYTE
2701 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2702 : ((pos_byte_next
< Z_BYTE
2703 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2704 || (pos_byte
> BEG_BYTE
2705 && ! ASCII_BYTE_P (FETCH_BYTE (pos_byte
- 1))))))
2707 Lisp_Object tem
, string
;
2709 struct gcpro gcpro1
;
2711 tem
= current_buffer
->undo_list
;
2714 /* Make a multibyte string containing this single character. */
2715 string
= make_multibyte_string (tostr
, 1, len
);
2716 /* replace_range is less efficient, because it moves the gap,
2717 but it handles combining correctly. */
2718 replace_range (pos
, pos
+ 1, string
,
2720 pos_byte_next
= CHAR_TO_BYTE (pos
);
2721 if (pos_byte_next
> pos_byte
)
2722 /* Before combining happened. We should not increment
2723 POS. So, to cancel the later increment of POS,
2727 INC_POS (pos_byte_next
);
2729 if (! NILP (noundo
))
2730 current_buffer
->undo_list
= tem
;
2737 record_change (pos
, 1);
2738 for (i
= 0; i
< len
; i
++) *p
++ = tostr
[i
];
2740 last_changed
= pos
+ 1;
2742 pos_byte
= pos_byte_next
;
2748 signal_after_change (changed
,
2749 last_changed
- changed
, last_changed
- changed
);
2750 update_compositions (changed
, last_changed
, CHECK_ALL
);
2753 unbind_to (count
, Qnil
);
2758 static Lisp_Object check_translation
P_ ((int, int, int, Lisp_Object
));
2760 /* Helper function for Ftranslate_region_internal.
2762 Check if a character sequence at POS (POS_BYTE) matches an element
2763 of VAL. VAL is a list (([FROM-CHAR ...] . TO) ...). If a matching
2764 element is found, return it. Otherwise return Qnil. */
2767 check_translation (pos
, pos_byte
, end
, val
)
2768 int pos
, pos_byte
, end
;
2771 int buf_size
= 16, buf_used
= 0;
2772 int *buf
= alloca (sizeof (int) * buf_size
);
2774 for (; CONSP (val
); val
= XCDR (val
))
2783 if (! VECTORP (elt
))
2786 if (len
<= end
- pos
)
2788 for (i
= 0; i
< len
; i
++)
2792 unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
2795 if (buf_used
== buf_size
)
2800 newbuf
= alloca (sizeof (int) * buf_size
);
2801 memcpy (newbuf
, buf
, sizeof (int) * buf_used
);
2804 buf
[buf_used
++] = STRING_CHAR_AND_LENGTH (p
, 0, len
);
2807 if (XINT (AREF (elt
, i
)) != buf
[i
])
2818 DEFUN ("translate-region-internal", Ftranslate_region_internal
,
2819 Stranslate_region_internal
, 3, 3, 0,
2820 doc
: /* Internal use only.
2821 From START to END, translate characters according to TABLE.
2822 TABLE is a string or a char-table; the Nth character in it is the
2823 mapping for the character with code N.
2824 It returns the number of characters changed. */)
2828 register Lisp_Object table
;
2830 register unsigned char *tt
; /* Trans table. */
2831 register int nc
; /* New character. */
2832 int cnt
; /* Number of changes made. */
2833 int size
; /* Size of translate table. */
2834 int pos
, pos_byte
, end_pos
;
2835 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
2836 int string_multibyte
;
2839 validate_region (&start
, &end
);
2840 if (CHAR_TABLE_P (table
))
2842 if (! EQ (XCHAR_TABLE (table
)->purpose
, Qtranslation_table
))
2843 error ("Not a translation table");
2848 CHECK_STRING (table
);
2850 if (multibyte
!= (SCHARS (table
) < SBYTES (table
)))
2852 ? string_make_multibyte (table
)
2853 : string_make_unibyte (table
));
2854 string_multibyte
= SCHARS (table
) < SBYTES (table
);
2855 size
= SBYTES (table
);
2860 pos_byte
= CHAR_TO_BYTE (pos
);
2861 end_pos
= XINT (end
);
2862 modify_region (current_buffer
, pos
, end_pos
);
2865 for (; pos
< end_pos
; )
2867 register unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
2868 unsigned char *str
, buf
[MAX_MULTIBYTE_LENGTH
];
2874 nc
= oc
= STRING_CHAR_AND_LENGTH (p
, 0, len
);
2876 nc
= oc
= *p
, len
= 1;
2881 if (string_multibyte
)
2883 str
= tt
+ string_char_to_byte (table
, oc
);
2884 nc
= STRING_CHAR_AND_LENGTH (str
, 0, str_len
);
2889 nc
= tt
[oc
], str_len
= 1;
2895 val
= CHAR_TABLE_REF (table
, oc
);
2896 if (CHARACTERP (val
))
2898 nc
= XFASTINT (val
);
2899 str_len
= CHAR_STRING (nc
, buf
);
2902 else if (VECTORP (val
) || (CONSP (val
)))
2904 /* VAL is [TO_CHAR ...] or (([FROM-CHAR ...] . TO) ...)
2905 where TO is TO-CHAR or [TO-CHAR ...]. */
2914 /* Simple one char to one char translation. */
2919 /* This is less efficient, because it moves the gap,
2920 but it should handle multibyte characters correctly. */
2921 string
= make_multibyte_string (str
, 1, str_len
);
2922 replace_range (pos
, pos
+ 1, string
, 1, 0, 1);
2927 record_change (pos
, 1);
2928 while (str_len
-- > 0)
2930 signal_after_change (pos
, 1, 1);
2931 update_compositions (pos
, pos
+ 1, CHECK_BORDER
);
2941 val
= check_translation (pos
, pos_byte
, end_pos
, val
);
2948 /* VAL is ([FROM-CHAR ...] . TO). */
2949 len
= ASIZE (XCAR (val
));
2959 string
= Fmake_string (make_number (ASIZE (val
)),
2961 for (i
= 1; i
< ASIZE (val
); i
++)
2962 Faset (string
, make_number (i
), AREF (val
, i
));
2966 string
= Fmake_string (make_number (1), val
);
2968 replace_range (pos
, pos
+ len
, string
, 1, 0, 1);
2969 pos_byte
+= SBYTES (string
);
2970 pos
+= SCHARS (string
);
2971 cnt
+= SCHARS (string
);
2972 end_pos
+= SCHARS (string
) - len
;
2980 return make_number (cnt
);
2983 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
2984 doc
: /* Delete the text between point and mark.
2986 When called from a program, expects two arguments,
2987 positions (integers or markers) specifying the stretch to be deleted. */)
2989 Lisp_Object start
, end
;
2991 validate_region (&start
, &end
);
2992 del_range (XINT (start
), XINT (end
));
2996 DEFUN ("delete-and-extract-region", Fdelete_and_extract_region
,
2997 Sdelete_and_extract_region
, 2, 2, 0,
2998 doc
: /* Delete the text between START and END and return it. */)
3000 Lisp_Object start
, end
;
3002 validate_region (&start
, &end
);
3003 if (XINT (start
) == XINT (end
))
3004 return build_string ("");
3005 return del_range_1 (XINT (start
), XINT (end
), 1, 1);
3008 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
3009 doc
: /* Remove restrictions (narrowing) from current buffer.
3010 This allows the buffer's full text to be seen and edited. */)
3013 if (BEG
!= BEGV
|| Z
!= ZV
)
3014 current_buffer
->clip_changed
= 1;
3016 BEGV_BYTE
= BEG_BYTE
;
3017 SET_BUF_ZV_BOTH (current_buffer
, Z
, Z_BYTE
);
3018 /* Changing the buffer bounds invalidates any recorded current column. */
3019 invalidate_current_column ();
3023 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
3024 doc
: /* Restrict editing in this buffer to the current region.
3025 The rest of the text becomes temporarily invisible and untouchable
3026 but is not deleted; if you save the buffer in a file, the invisible
3027 text is included in the file. \\[widen] makes all visible again.
3028 See also `save-restriction'.
3030 When calling from a program, pass two arguments; positions (integers
3031 or markers) bounding the text that should remain visible. */)
3033 register Lisp_Object start
, end
;
3035 CHECK_NUMBER_COERCE_MARKER (start
);
3036 CHECK_NUMBER_COERCE_MARKER (end
);
3038 if (XINT (start
) > XINT (end
))
3041 tem
= start
; start
= end
; end
= tem
;
3044 if (!(BEG
<= XINT (start
) && XINT (start
) <= XINT (end
) && XINT (end
) <= Z
))
3045 args_out_of_range (start
, end
);
3047 if (BEGV
!= XFASTINT (start
) || ZV
!= XFASTINT (end
))
3048 current_buffer
->clip_changed
= 1;
3050 SET_BUF_BEGV (current_buffer
, XFASTINT (start
));
3051 SET_BUF_ZV (current_buffer
, XFASTINT (end
));
3052 if (PT
< XFASTINT (start
))
3053 SET_PT (XFASTINT (start
));
3054 if (PT
> XFASTINT (end
))
3055 SET_PT (XFASTINT (end
));
3056 /* Changing the buffer bounds invalidates any recorded current column. */
3057 invalidate_current_column ();
3062 save_restriction_save ()
3064 if (BEGV
== BEG
&& ZV
== Z
)
3065 /* The common case that the buffer isn't narrowed.
3066 We return just the buffer object, which save_restriction_restore
3067 recognizes as meaning `no restriction'. */
3068 return Fcurrent_buffer ();
3070 /* We have to save a restriction, so return a pair of markers, one
3071 for the beginning and one for the end. */
3073 Lisp_Object beg
, end
;
3075 beg
= buildmark (BEGV
, BEGV_BYTE
);
3076 end
= buildmark (ZV
, ZV_BYTE
);
3078 /* END must move forward if text is inserted at its exact location. */
3079 XMARKER(end
)->insertion_type
= 1;
3081 return Fcons (beg
, end
);
3086 save_restriction_restore (data
)
3090 /* A pair of marks bounding a saved restriction. */
3092 struct Lisp_Marker
*beg
= XMARKER (XCAR (data
));
3093 struct Lisp_Marker
*end
= XMARKER (XCDR (data
));
3094 struct buffer
*buf
= beg
->buffer
; /* END should have the same buffer. */
3096 if (buf
/* Verify marker still points to a buffer. */
3097 && (beg
->charpos
!= BUF_BEGV (buf
) || end
->charpos
!= BUF_ZV (buf
)))
3098 /* The restriction has changed from the saved one, so restore
3099 the saved restriction. */
3101 int pt
= BUF_PT (buf
);
3103 SET_BUF_BEGV_BOTH (buf
, beg
->charpos
, beg
->bytepos
);
3104 SET_BUF_ZV_BOTH (buf
, end
->charpos
, end
->bytepos
);
3106 if (pt
< beg
->charpos
|| pt
> end
->charpos
)
3107 /* The point is outside the new visible range, move it inside. */
3108 SET_BUF_PT_BOTH (buf
,
3109 clip_to_bounds (beg
->charpos
, pt
, end
->charpos
),
3110 clip_to_bounds (beg
->bytepos
, BUF_PT_BYTE (buf
),
3113 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3117 /* A buffer, which means that there was no old restriction. */
3119 struct buffer
*buf
= XBUFFER (data
);
3121 if (buf
/* Verify marker still points to a buffer. */
3122 && (BUF_BEGV (buf
) != BUF_BEG (buf
) || BUF_ZV (buf
) != BUF_Z (buf
)))
3123 /* The buffer has been narrowed, get rid of the narrowing. */
3125 SET_BUF_BEGV_BOTH (buf
, BUF_BEG (buf
), BUF_BEG_BYTE (buf
));
3126 SET_BUF_ZV_BOTH (buf
, BUF_Z (buf
), BUF_Z_BYTE (buf
));
3128 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3135 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
3136 doc
: /* Execute BODY, saving and restoring current buffer's restrictions.
3137 The buffer's restrictions make parts of the beginning and end invisible.
3138 (They are set up with `narrow-to-region' and eliminated with `widen'.)
3139 This special form, `save-restriction', saves the current buffer's restrictions
3140 when it is entered, and restores them when it is exited.
3141 So any `narrow-to-region' within BODY lasts only until the end of the form.
3142 The old restrictions settings are restored
3143 even in case of abnormal exit (throw or error).
3145 The value returned is the value of the last form in BODY.
3147 Note: if you are using both `save-excursion' and `save-restriction',
3148 use `save-excursion' outermost:
3149 (save-excursion (save-restriction ...))
3151 usage: (save-restriction &rest BODY) */)
3155 register Lisp_Object val
;
3156 int count
= SPECPDL_INDEX ();
3158 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
3159 val
= Fprogn (body
);
3160 return unbind_to (count
, val
);
3163 /* Buffer for the most recent text displayed by Fmessage_box. */
3164 static char *message_text
;
3166 /* Allocated length of that buffer. */
3167 static int message_length
;
3169 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
3170 doc
: /* Print a one-line message at the bottom of the screen.
3171 The first argument is a format control string, and the rest are data
3172 to be formatted under control of the string. See `format' for details.
3174 If the first argument is nil, clear any existing message; let the
3175 minibuffer contents show.
3177 usage: (message STRING &rest ARGS) */)
3183 || (STRINGP (args
[0])
3184 && SBYTES (args
[0]) == 0))
3191 register Lisp_Object val
;
3192 val
= Fformat (nargs
, args
);
3193 message3 (val
, SBYTES (val
), STRING_MULTIBYTE (val
));
3198 DEFUN ("message-box", Fmessage_box
, Smessage_box
, 1, MANY
, 0,
3199 doc
: /* Display a message, in a dialog box if possible.
3200 If a dialog box is not available, use the echo area.
3201 The first argument is a format control string, and the rest are data
3202 to be formatted under control of the string. See `format' for details.
3204 If the first argument is nil, clear any existing message; let the
3205 minibuffer contents show.
3207 usage: (message-box STRING &rest ARGS) */)
3219 register Lisp_Object val
;
3220 val
= Fformat (nargs
, args
);
3222 /* The MS-DOS frames support popup menus even though they are
3223 not FRAME_WINDOW_P. */
3224 if (FRAME_WINDOW_P (XFRAME (selected_frame
))
3225 || FRAME_MSDOS_P (XFRAME (selected_frame
)))
3227 Lisp_Object pane
, menu
, obj
;
3228 struct gcpro gcpro1
;
3229 pane
= Fcons (Fcons (build_string ("OK"), Qt
), Qnil
);
3231 menu
= Fcons (val
, pane
);
3232 obj
= Fx_popup_dialog (Qt
, menu
);
3236 #endif /* HAVE_MENUS */
3237 /* Copy the data so that it won't move when we GC. */
3240 message_text
= (char *)xmalloc (80);
3241 message_length
= 80;
3243 if (SBYTES (val
) > message_length
)
3245 message_length
= SBYTES (val
);
3246 message_text
= (char *)xrealloc (message_text
, message_length
);
3248 bcopy (SDATA (val
), message_text
, SBYTES (val
));
3249 message2 (message_text
, SBYTES (val
),
3250 STRING_MULTIBYTE (val
));
3255 extern Lisp_Object last_nonmenu_event
;
3258 DEFUN ("message-or-box", Fmessage_or_box
, Smessage_or_box
, 1, MANY
, 0,
3259 doc
: /* Display a message in a dialog box or in the echo area.
3260 If this command was invoked with the mouse, use a dialog box if
3261 `use-dialog-box' is non-nil.
3262 Otherwise, use the echo area.
3263 The first argument is a format control string, and the rest are data
3264 to be formatted under control of the string. See `format' for details.
3266 If the first argument is nil, clear any existing message; let the
3267 minibuffer contents show.
3269 usage: (message-or-box STRING &rest ARGS) */)
3275 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3277 return Fmessage_box (nargs
, args
);
3279 return Fmessage (nargs
, args
);
3282 DEFUN ("current-message", Fcurrent_message
, Scurrent_message
, 0, 0, 0,
3283 doc
: /* Return the string currently displayed in the echo area, or nil if none. */)
3286 return current_message ();
3290 DEFUN ("propertize", Fpropertize
, Spropertize
, 1, MANY
, 0,
3291 doc
: /* Return a copy of STRING with text properties added.
3292 First argument is the string to copy.
3293 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
3294 properties to add to the result.
3295 usage: (propertize STRING &rest PROPERTIES) */)
3300 Lisp_Object properties
, string
;
3301 struct gcpro gcpro1
, gcpro2
;
3304 /* Number of args must be odd. */
3305 if ((nargs
& 1) == 0 || nargs
< 1)
3306 error ("Wrong number of arguments");
3308 properties
= string
= Qnil
;
3309 GCPRO2 (properties
, string
);
3311 /* First argument must be a string. */
3312 CHECK_STRING (args
[0]);
3313 string
= Fcopy_sequence (args
[0]);
3315 for (i
= 1; i
< nargs
; i
+= 2)
3317 CHECK_SYMBOL (args
[i
]);
3318 properties
= Fcons (args
[i
], Fcons (args
[i
+ 1], properties
));
3321 Fadd_text_properties (make_number (0),
3322 make_number (SCHARS (string
)),
3323 properties
, string
);
3324 RETURN_UNGCPRO (string
);
3328 /* Number of bytes that STRING will occupy when put into the result.
3329 MULTIBYTE is nonzero if the result should be multibyte. */
3331 #define CONVERTED_BYTE_SIZE(MULTIBYTE, STRING) \
3332 (((MULTIBYTE) && ! STRING_MULTIBYTE (STRING)) \
3333 ? count_size_as_multibyte (SDATA (STRING), SBYTES (STRING)) \
3336 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
3337 doc
: /* Format a string out of a control-string and arguments.
3338 The first argument is a control string.
3339 The other arguments are substituted into it to make the result, a string.
3340 It may contain %-sequences meaning to substitute the next argument.
3341 %s means print a string argument. Actually, prints any object, with `princ'.
3342 %d means print as number in decimal (%o octal, %x hex).
3343 %X is like %x, but uses upper case.
3344 %e means print a number in exponential notation.
3345 %f means print a number in decimal-point notation.
3346 %g means print a number in exponential notation
3347 or decimal-point notation, whichever uses fewer characters.
3348 %c means print a number as a single character.
3349 %S means print any object as an s-expression (using `prin1').
3350 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.
3351 Use %% to put a single % into the output.
3353 The basic structure of a %-sequence is
3354 % <flags> <width> <precision> character
3355 where flags is [- #0]+, width is [0-9]+, and precision is .[0-9]+
3357 usage: (format STRING &rest OBJECTS) */)
3360 register Lisp_Object
*args
;
3362 register int n
; /* The number of the next arg to substitute */
3363 register int total
; /* An estimate of the final length */
3365 register unsigned char *format
, *end
, *format_start
;
3367 /* Nonzero if the output should be a multibyte string,
3368 which is true if any of the inputs is one. */
3370 /* When we make a multibyte string, we must pay attention to the
3371 byte combining problem, i.e., a byte may be combined with a
3372 multibyte charcter of the previous string. This flag tells if we
3373 must consider such a situation or not. */
3374 int maybe_combine_byte
;
3375 unsigned char *this_format
;
3376 /* Precision for each spec, or -1, a flag value meaning no precision
3377 was given in that spec. Element 0, corresonding to the format
3378 string itself, will not be used. Element NARGS, corresponding to
3379 no argument, *will* be assigned to in the case that a `%' and `.'
3380 occur after the final format specifier. */
3381 int *precision
= (int *) (alloca((nargs
+ 1) * sizeof (int)));
3384 int arg_intervals
= 0;
3387 /* discarded[I] is 1 if byte I of the format
3388 string was not copied into the output.
3389 It is 2 if byte I was not the first byte of its character. */
3390 char *discarded
= 0;
3392 /* Each element records, for one argument,
3393 the start and end bytepos in the output string,
3394 and whether the argument is a string with intervals.
3395 info[0] is unused. Unused elements have -1 for start. */
3398 int start
, end
, intervals
;
3401 /* It should not be necessary to GCPRO ARGS, because
3402 the caller in the interpreter should take care of that. */
3404 /* Try to determine whether the result should be multibyte.
3405 This is not always right; sometimes the result needs to be multibyte
3406 because of an object that we will pass through prin1,
3407 and in that case, we won't know it here. */
3408 for (n
= 0; n
< nargs
; n
++)
3410 if (STRINGP (args
[n
]) && STRING_MULTIBYTE (args
[n
]))
3412 /* Piggyback on this loop to initialize precision[N]. */
3415 precision
[nargs
] = -1;
3417 CHECK_STRING (args
[0]);
3418 /* We may have to change "%S" to "%s". */
3419 args
[0] = Fcopy_sequence (args
[0]);
3421 /* GC should never happen here, so abort if it does. */
3424 /* If we start out planning a unibyte result,
3425 then discover it has to be multibyte, we jump back to retry.
3426 That can only happen from the first large while loop below. */
3429 format
= SDATA (args
[0]);
3430 format_start
= format
;
3431 end
= format
+ SBYTES (args
[0]);
3434 /* Make room in result for all the non-%-codes in the control string. */
3435 total
= 5 + CONVERTED_BYTE_SIZE (multibyte
, args
[0]) + 1;
3437 /* Allocate the info and discarded tables. */
3439 int nbytes
= (nargs
+1) * sizeof *info
;
3442 info
= (struct info
*) alloca (nbytes
);
3443 bzero (info
, nbytes
);
3444 for (i
= 0; i
<= nargs
; i
++)
3447 SAFE_ALLOCA (discarded
, char *, SBYTES (args
[0]));
3448 bzero (discarded
, SBYTES (args
[0]));
3451 /* Add to TOTAL enough space to hold the converted arguments. */
3454 while (format
!= end
)
3455 if (*format
++ == '%')
3458 int actual_width
= 0;
3459 unsigned char *this_format_start
= format
- 1;
3460 int field_width
= 0;
3462 /* General format specifications look like
3464 '%' [flags] [field-width] [precision] format
3469 field-width ::= [0-9]+
3470 precision ::= '.' [0-9]*
3472 If a field-width is specified, it specifies to which width
3473 the output should be padded with blanks, iff the output
3474 string is shorter than field-width.
3476 If precision is specified, it specifies the number of
3477 digits to print after the '.' for floats, or the max.
3478 number of chars to print from a string. */
3480 while (index ("-0# ", *format
))
3483 if (*format
>= '0' && *format
<= '9')
3485 for (field_width
= 0; *format
>= '0' && *format
<= '9'; ++format
)
3486 field_width
= 10 * field_width
+ *format
- '0';
3489 /* N is not incremented for another few lines below, so refer to
3490 element N+1 (which might be precision[NARGS]). */
3494 for (precision
[n
+1] = 0; *format
>= '0' && *format
<= '9'; ++format
)
3495 precision
[n
+1] = 10 * precision
[n
+1] + *format
- '0';
3498 if (format
- this_format_start
+ 1 > longest_format
)
3499 longest_format
= format
- this_format_start
+ 1;
3502 error ("Format string ends in middle of format specifier");
3505 else if (++n
>= nargs
)
3506 error ("Not enough arguments for format string");
3507 else if (*format
== 'S')
3509 /* For `S', prin1 the argument and then treat like a string. */
3510 register Lisp_Object tem
;
3511 tem
= Fprin1_to_string (args
[n
], Qnil
);
3512 if (STRING_MULTIBYTE (tem
) && ! multibyte
)
3518 /* If we restart the loop, we should not come here again
3519 because args[n] is now a string and calling
3520 Fprin1_to_string on it produces superflous double
3521 quotes. So, change "%S" to "%s" now. */
3525 else if (SYMBOLP (args
[n
]))
3527 args
[n
] = SYMBOL_NAME (args
[n
]);
3528 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
3535 else if (STRINGP (args
[n
]))
3538 if (*format
!= 's' && *format
!= 'S')
3539 error ("Format specifier doesn't match argument type");
3540 /* In the case (PRECISION[N] > 0), THISSIZE may not need
3541 to be as large as is calculated here. Easy check for
3542 the case PRECISION = 0. */
3543 thissize
= precision
[n
] ? CONVERTED_BYTE_SIZE (multibyte
, args
[n
]) : 0;
3544 actual_width
= lisp_string_width (args
[n
], -1, NULL
, NULL
);
3546 /* Would get MPV otherwise, since Lisp_Int's `point' to low memory. */
3547 else if (INTEGERP (args
[n
]) && *format
!= 's')
3549 /* The following loop assumes the Lisp type indicates
3550 the proper way to pass the argument.
3551 So make sure we have a flonum if the argument should
3553 if (*format
== 'e' || *format
== 'f' || *format
== 'g')
3554 args
[n
] = Ffloat (args
[n
]);
3556 if (*format
!= 'd' && *format
!= 'o' && *format
!= 'x'
3557 && *format
!= 'i' && *format
!= 'X' && *format
!= 'c')
3558 error ("Invalid format operation %%%c", *format
);
3563 if (! ASCII_CHAR_P (XINT (args
[n
]))
3564 /* Note: No one can remeber why we have to treat
3565 the character 0 as a multibyte character here.
3566 But, until it causes a real problem, let's
3568 || XINT (args
[n
]) == 0)
3575 args
[n
] = Fchar_to_string (args
[n
]);
3576 thissize
= SBYTES (args
[n
]);
3578 else if (! ASCII_BYTE_P (XINT (args
[n
])) && multibyte
)
3581 = Fchar_to_string (Funibyte_char_to_multibyte (args
[n
]));
3582 thissize
= SBYTES (args
[n
]);
3586 else if (FLOATP (args
[n
]) && *format
!= 's')
3588 if (! (*format
== 'e' || *format
== 'f' || *format
== 'g'))
3590 if (*format
!= 'd' && *format
!= 'o' && *format
!= 'x'
3591 && *format
!= 'i' && *format
!= 'X' && *format
!= 'c')
3592 error ("Invalid format operation %%%c", *format
);
3593 args
[n
] = Ftruncate (args
[n
], Qnil
);
3596 /* Note that we're using sprintf to print floats,
3597 so we have to take into account what that function
3599 /* Filter out flag value of -1. */
3600 thissize
= (MAX_10_EXP
+ 100
3601 + (precision
[n
] > 0 ? precision
[n
] : 0));
3605 /* Anything but a string, convert to a string using princ. */
3606 register Lisp_Object tem
;
3607 tem
= Fprin1_to_string (args
[n
], Qt
);
3608 if (STRING_MULTIBYTE (tem
) && ! multibyte
)
3617 thissize
+= max (0, field_width
- actual_width
);
3618 total
+= thissize
+ 4;
3623 /* Now we can no longer jump to retry.
3624 TOTAL and LONGEST_FORMAT are known for certain. */
3626 this_format
= (unsigned char *) alloca (longest_format
+ 1);
3628 /* Allocate the space for the result.
3629 Note that TOTAL is an overestimate. */
3630 SAFE_ALLOCA (buf
, char *, total
);
3636 /* Scan the format and store result in BUF. */
3637 format
= SDATA (args
[0]);
3638 format_start
= format
;
3639 end
= format
+ SBYTES (args
[0]);
3640 maybe_combine_byte
= 0;
3641 while (format
!= end
)
3647 unsigned char *this_format_start
= format
;
3649 discarded
[format
- format_start
] = 1;
3652 while (index("-0# ", *format
))
3658 discarded
[format
- format_start
] = 1;
3662 minlen
= atoi (format
);
3664 while ((*format
>= '0' && *format
<= '9') || *format
== '.')
3666 discarded
[format
- format_start
] = 1;
3670 if (*format
++ == '%')
3679 discarded
[format
- format_start
- 1] = 1;
3680 info
[n
].start
= nchars
;
3682 if (STRINGP (args
[n
]))
3684 /* handle case (precision[n] >= 0) */
3687 int nbytes
, start
, end
;
3690 /* lisp_string_width ignores a precision of 0, but GNU
3691 libc functions print 0 characters when the precision
3692 is 0. Imitate libc behavior here. Changing
3693 lisp_string_width is the right thing, and will be
3694 done, but meanwhile we work with it. */
3696 if (precision
[n
] == 0)
3697 width
= nchars_string
= nbytes
= 0;
3698 else if (precision
[n
] > 0)
3699 width
= lisp_string_width (args
[n
], precision
[n
], &nchars_string
, &nbytes
);
3701 { /* no precision spec given for this argument */
3702 width
= lisp_string_width (args
[n
], -1, NULL
, NULL
);
3703 nbytes
= SBYTES (args
[n
]);
3704 nchars_string
= SCHARS (args
[n
]);
3707 /* If spec requires it, pad on right with spaces. */
3708 padding
= minlen
- width
;
3710 while (padding
-- > 0)
3717 nchars
+= nchars_string
;
3722 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3723 && STRING_MULTIBYTE (args
[n
])
3724 && !CHAR_HEAD_P (SREF (args
[n
], 0)))
3725 maybe_combine_byte
= 1;
3727 p
+= copy_text (SDATA (args
[n
]), p
,
3729 STRING_MULTIBYTE (args
[n
]), multibyte
);
3732 while (padding
-- > 0)
3738 /* If this argument has text properties, record where
3739 in the result string it appears. */
3740 if (STRING_INTERVALS (args
[n
]))
3741 info
[n
].intervals
= arg_intervals
= 1;
3743 else if (INTEGERP (args
[n
]) || FLOATP (args
[n
]))
3747 bcopy (this_format_start
, this_format
,
3748 format
- this_format_start
);
3749 this_format
[format
- this_format_start
] = 0;
3751 if (INTEGERP (args
[n
]))
3752 sprintf (p
, this_format
, XINT (args
[n
]));
3754 sprintf (p
, this_format
, XFLOAT_DATA (args
[n
]));
3758 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3759 && !CHAR_HEAD_P (*((unsigned char *) p
)))
3760 maybe_combine_byte
= 1;
3761 this_nchars
= strlen (p
);
3763 p
+= str_to_multibyte (p
, buf
+ total
- 1 - p
, this_nchars
);
3766 nchars
+= this_nchars
;
3769 info
[n
].end
= nchars
;
3771 else if (STRING_MULTIBYTE (args
[0]))
3773 /* Copy a whole multibyte character. */
3776 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3777 && !CHAR_HEAD_P (*format
))
3778 maybe_combine_byte
= 1;
3780 while (! CHAR_HEAD_P (*format
))
3782 discarded
[format
- format_start
] = 2;
3789 /* Convert a single-byte character to multibyte. */
3790 int len
= copy_text (format
, p
, 1, 0, 1);
3797 *p
++ = *format
++, nchars
++;
3800 if (p
> buf
+ total
)
3803 if (maybe_combine_byte
)
3804 nchars
= multibyte_chars_in_text (buf
, p
- buf
);
3805 val
= make_specified_string (buf
, nchars
, p
- buf
, multibyte
);
3807 /* If we allocated BUF with malloc, free it too. */
3810 /* If the format string has text properties, or any of the string
3811 arguments has text properties, set up text properties of the
3814 if (STRING_INTERVALS (args
[0]) || arg_intervals
)
3816 Lisp_Object len
, new_len
, props
;
3817 struct gcpro gcpro1
;
3819 /* Add text properties from the format string. */
3820 len
= make_number (SCHARS (args
[0]));
3821 props
= text_property_list (args
[0], make_number (0), len
, Qnil
);
3826 int bytepos
= 0, position
= 0, translated
= 0, argn
= 1;
3829 /* Adjust the bounds of each text property
3830 to the proper start and end in the output string. */
3832 /* Put the positions in PROPS in increasing order, so that
3833 we can do (effectively) one scan through the position
3834 space of the format string. */
3835 props
= Fnreverse (props
);
3837 /* BYTEPOS is the byte position in the format string,
3838 POSITION is the untranslated char position in it,
3839 TRANSLATED is the translated char position in BUF,
3840 and ARGN is the number of the next arg we will come to. */
3841 for (list
= props
; CONSP (list
); list
= XCDR (list
))
3848 /* First adjust the property start position. */
3849 pos
= XINT (XCAR (item
));
3851 /* Advance BYTEPOS, POSITION, TRANSLATED and ARGN
3852 up to this position. */
3853 for (; position
< pos
; bytepos
++)
3855 if (! discarded
[bytepos
])
3856 position
++, translated
++;
3857 else if (discarded
[bytepos
] == 1)
3860 if (translated
== info
[argn
].start
)
3862 translated
+= info
[argn
].end
- info
[argn
].start
;
3868 XSETCAR (item
, make_number (translated
));
3870 /* Likewise adjust the property end position. */
3871 pos
= XINT (XCAR (XCDR (item
)));
3873 for (; bytepos
< pos
; bytepos
++)
3875 if (! discarded
[bytepos
])
3876 position
++, translated
++;
3877 else if (discarded
[bytepos
] == 1)
3880 if (translated
== info
[argn
].start
)
3882 translated
+= info
[argn
].end
- info
[argn
].start
;
3888 XSETCAR (XCDR (item
), make_number (translated
));
3891 add_text_properties_from_list (val
, props
, make_number (0));
3894 /* Add text properties from arguments. */
3896 for (n
= 1; n
< nargs
; ++n
)
3897 if (info
[n
].intervals
)
3899 len
= make_number (SCHARS (args
[n
]));
3900 new_len
= make_number (info
[n
].end
- info
[n
].start
);
3901 props
= text_property_list (args
[n
], make_number (0), len
, Qnil
);
3902 extend_property_ranges (props
, len
, new_len
);
3903 /* If successive arguments have properites, be sure that
3904 the value of `composition' property be the copy. */
3905 if (n
> 1 && info
[n
- 1].end
)
3906 make_composition_value_copy (props
);
3907 add_text_properties_from_list (val
, props
,
3908 make_number (info
[n
].start
));
3918 format2 (string1
, arg0
, arg1
)
3920 Lisp_Object arg0
, arg1
;
3922 Lisp_Object args
[3];
3923 args
[0] = build_string (string1
);
3926 return Fformat (3, args
);
3929 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
3930 doc
: /* Return t if two characters match, optionally ignoring case.
3931 Both arguments must be characters (i.e. integers).
3932 Case is ignored if `case-fold-search' is non-nil in the current buffer. */)
3934 register Lisp_Object c1
, c2
;
3940 if (XINT (c1
) == XINT (c2
))
3942 if (NILP (current_buffer
->case_fold_search
))
3945 /* Do these in separate statements,
3946 then compare the variables.
3947 because of the way DOWNCASE uses temp variables. */
3949 if (NILP (current_buffer
->enable_multibyte_characters
)
3950 && ! ASCII_CHAR_P (i1
))
3952 MAKE_CHAR_MULTIBYTE (i1
);
3955 if (NILP (current_buffer
->enable_multibyte_characters
)
3956 && ! ASCII_CHAR_P (i2
))
3958 MAKE_CHAR_MULTIBYTE (i2
);
3962 return (i1
== i2
? Qt
: Qnil
);
3965 /* Transpose the markers in two regions of the current buffer, and
3966 adjust the ones between them if necessary (i.e.: if the regions
3969 START1, END1 are the character positions of the first region.
3970 START1_BYTE, END1_BYTE are the byte positions.
3971 START2, END2 are the character positions of the second region.
3972 START2_BYTE, END2_BYTE are the byte positions.
3974 Traverses the entire marker list of the buffer to do so, adding an
3975 appropriate amount to some, subtracting from some, and leaving the
3976 rest untouched. Most of this is copied from adjust_markers in insdel.c.
3978 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
3981 transpose_markers (start1
, end1
, start2
, end2
,
3982 start1_byte
, end1_byte
, start2_byte
, end2_byte
)
3983 register int start1
, end1
, start2
, end2
;
3984 register int start1_byte
, end1_byte
, start2_byte
, end2_byte
;
3986 register int amt1
, amt1_byte
, amt2
, amt2_byte
, diff
, diff_byte
, mpos
;
3987 register struct Lisp_Marker
*marker
;
3989 /* Update point as if it were a marker. */
3993 TEMP_SET_PT_BOTH (PT
+ (end2
- end1
),
3994 PT_BYTE
+ (end2_byte
- end1_byte
));
3995 else if (PT
< start2
)
3996 TEMP_SET_PT_BOTH (PT
+ (end2
- start2
) - (end1
- start1
),
3997 (PT_BYTE
+ (end2_byte
- start2_byte
)
3998 - (end1_byte
- start1_byte
)));
4000 TEMP_SET_PT_BOTH (PT
- (start2
- start1
),
4001 PT_BYTE
- (start2_byte
- start1_byte
));
4003 /* We used to adjust the endpoints here to account for the gap, but that
4004 isn't good enough. Even if we assume the caller has tried to move the
4005 gap out of our way, it might still be at start1 exactly, for example;
4006 and that places it `inside' the interval, for our purposes. The amount
4007 of adjustment is nontrivial if there's a `denormalized' marker whose
4008 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
4009 the dirty work to Fmarker_position, below. */
4011 /* The difference between the region's lengths */
4012 diff
= (end2
- start2
) - (end1
- start1
);
4013 diff_byte
= (end2_byte
- start2_byte
) - (end1_byte
- start1_byte
);
4015 /* For shifting each marker in a region by the length of the other
4016 region plus the distance between the regions. */
4017 amt1
= (end2
- start2
) + (start2
- end1
);
4018 amt2
= (end1
- start1
) + (start2
- end1
);
4019 amt1_byte
= (end2_byte
- start2_byte
) + (start2_byte
- end1_byte
);
4020 amt2_byte
= (end1_byte
- start1_byte
) + (start2_byte
- end1_byte
);
4022 for (marker
= BUF_MARKERS (current_buffer
); marker
; marker
= marker
->next
)
4024 mpos
= marker
->bytepos
;
4025 if (mpos
>= start1_byte
&& mpos
< end2_byte
)
4027 if (mpos
< end1_byte
)
4029 else if (mpos
< start2_byte
)
4033 marker
->bytepos
= mpos
;
4035 mpos
= marker
->charpos
;
4036 if (mpos
>= start1
&& mpos
< end2
)
4040 else if (mpos
< start2
)
4045 marker
->charpos
= mpos
;
4049 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
4050 doc
: /* Transpose region STARTR1 to ENDR1 with STARTR2 to ENDR2.
4051 The regions may not be overlapping, because the size of the buffer is
4052 never changed in a transposition.
4054 Optional fifth arg LEAVE-MARKERS, if non-nil, means don't update
4055 any markers that happen to be located in the regions.
4057 Transposing beyond buffer boundaries is an error. */)
4058 (startr1
, endr1
, startr2
, endr2
, leave_markers
)
4059 Lisp_Object startr1
, endr1
, startr2
, endr2
, leave_markers
;
4061 register int start1
, end1
, start2
, end2
;
4062 int start1_byte
, start2_byte
, len1_byte
, len2_byte
;
4063 int gap
, len1
, len_mid
, len2
;
4064 unsigned char *start1_addr
, *start2_addr
, *temp
;
4066 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
;
4067 cur_intv
= BUF_INTERVALS (current_buffer
);
4069 validate_region (&startr1
, &endr1
);
4070 validate_region (&startr2
, &endr2
);
4072 start1
= XFASTINT (startr1
);
4073 end1
= XFASTINT (endr1
);
4074 start2
= XFASTINT (startr2
);
4075 end2
= XFASTINT (endr2
);
4078 /* Swap the regions if they're reversed. */
4081 register int glumph
= start1
;
4089 len1
= end1
- start1
;
4090 len2
= end2
- start2
;
4093 error ("Transposed regions overlap");
4094 else if (start1
== end1
|| start2
== end2
)
4095 error ("Transposed region has length 0");
4097 /* The possibilities are:
4098 1. Adjacent (contiguous) regions, or separate but equal regions
4099 (no, really equal, in this case!), or
4100 2. Separate regions of unequal size.
4102 The worst case is usually No. 2. It means that (aside from
4103 potential need for getting the gap out of the way), there also
4104 needs to be a shifting of the text between the two regions. So
4105 if they are spread far apart, we are that much slower... sigh. */
4107 /* It must be pointed out that the really studly thing to do would
4108 be not to move the gap at all, but to leave it in place and work
4109 around it if necessary. This would be extremely efficient,
4110 especially considering that people are likely to do
4111 transpositions near where they are working interactively, which
4112 is exactly where the gap would be found. However, such code
4113 would be much harder to write and to read. So, if you are
4114 reading this comment and are feeling squirrely, by all means have
4115 a go! I just didn't feel like doing it, so I will simply move
4116 the gap the minimum distance to get it out of the way, and then
4117 deal with an unbroken array. */
4119 /* Make sure the gap won't interfere, by moving it out of the text
4120 we will operate on. */
4121 if (start1
< gap
&& gap
< end2
)
4123 if (gap
- start1
< end2
- gap
)
4129 start1_byte
= CHAR_TO_BYTE (start1
);
4130 start2_byte
= CHAR_TO_BYTE (start2
);
4131 len1_byte
= CHAR_TO_BYTE (end1
) - start1_byte
;
4132 len2_byte
= CHAR_TO_BYTE (end2
) - start2_byte
;
4134 #ifdef BYTE_COMBINING_DEBUG
4137 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4138 len2_byte
, start1
, start1_byte
)
4139 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4140 len1_byte
, end2
, start2_byte
+ len2_byte
)
4141 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4142 len1_byte
, end2
, start2_byte
+ len2_byte
))
4147 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4148 len2_byte
, start1
, start1_byte
)
4149 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4150 len1_byte
, start2
, start2_byte
)
4151 || count_combining_after (BYTE_POS_ADDR (start2_byte
),
4152 len2_byte
, end1
, start1_byte
+ len1_byte
)
4153 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4154 len1_byte
, end2
, start2_byte
+ len2_byte
))
4159 /* Hmmm... how about checking to see if the gap is large
4160 enough to use as the temporary storage? That would avoid an
4161 allocation... interesting. Later, don't fool with it now. */
4163 /* Working without memmove, for portability (sigh), so must be
4164 careful of overlapping subsections of the array... */
4166 if (end1
== start2
) /* adjacent regions */
4168 modify_region (current_buffer
, start1
, end2
);
4169 record_change (start1
, len1
+ len2
);
4171 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4172 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4173 Fset_text_properties (make_number (start1
), make_number (end2
),
4176 /* First region smaller than second. */
4177 if (len1_byte
< len2_byte
)
4181 SAFE_ALLOCA (temp
, unsigned char *, len2_byte
);
4183 /* Don't precompute these addresses. We have to compute them
4184 at the last minute, because the relocating allocator might
4185 have moved the buffer around during the xmalloc. */
4186 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4187 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4189 bcopy (start2_addr
, temp
, len2_byte
);
4190 bcopy (start1_addr
, start1_addr
+ len2_byte
, len1_byte
);
4191 bcopy (temp
, start1_addr
, len2_byte
);
4195 /* First region not smaller than second. */
4199 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4200 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4201 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4202 bcopy (start1_addr
, temp
, len1_byte
);
4203 bcopy (start2_addr
, start1_addr
, len2_byte
);
4204 bcopy (temp
, start1_addr
+ len2_byte
, len1_byte
);
4207 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
4208 len1
, current_buffer
, 0);
4209 graft_intervals_into_buffer (tmp_interval2
, start1
,
4210 len2
, current_buffer
, 0);
4211 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4212 update_compositions (start1
+ len2
, end2
, CHECK_TAIL
);
4214 /* Non-adjacent regions, because end1 != start2, bleagh... */
4217 len_mid
= start2_byte
- (start1_byte
+ len1_byte
);
4219 if (len1_byte
== len2_byte
)
4220 /* Regions are same size, though, how nice. */
4224 modify_region (current_buffer
, start1
, end1
);
4225 modify_region (current_buffer
, start2
, end2
);
4226 record_change (start1
, len1
);
4227 record_change (start2
, len2
);
4228 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4229 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4230 Fset_text_properties (make_number (start1
), make_number (end1
),
4232 Fset_text_properties (make_number (start2
), make_number (end2
),
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 (temp
, start2_addr
, len1_byte
);
4243 graft_intervals_into_buffer (tmp_interval1
, start2
,
4244 len1
, current_buffer
, 0);
4245 graft_intervals_into_buffer (tmp_interval2
, start1
,
4246 len2
, current_buffer
, 0);
4249 else if (len1_byte
< len2_byte
) /* Second region larger than first */
4250 /* Non-adjacent & unequal size, area between must also be shifted. */
4254 modify_region (current_buffer
, start1
, end2
);
4255 record_change (start1
, (end2
- start1
));
4256 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4257 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4258 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4259 Fset_text_properties (make_number (start1
), make_number (end2
),
4262 /* holds region 2 */
4263 SAFE_ALLOCA (temp
, unsigned char *, len2_byte
);
4264 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4265 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4266 bcopy (start2_addr
, temp
, len2_byte
);
4267 bcopy (start1_addr
, start1_addr
+ len_mid
+ len2_byte
, len1_byte
);
4268 safe_bcopy (start1_addr
+ len1_byte
, start1_addr
+ len2_byte
, len_mid
);
4269 bcopy (temp
, start1_addr
, len2_byte
);
4272 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4273 len1
, current_buffer
, 0);
4274 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4275 len_mid
, current_buffer
, 0);
4276 graft_intervals_into_buffer (tmp_interval2
, start1
,
4277 len2
, current_buffer
, 0);
4280 /* Second region smaller than first. */
4284 record_change (start1
, (end2
- start1
));
4285 modify_region (current_buffer
, start1
, end2
);
4287 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4288 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4289 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4290 Fset_text_properties (make_number (start1
), make_number (end2
),
4293 /* holds region 1 */
4294 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4295 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4296 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4297 bcopy (start1_addr
, temp
, len1_byte
);
4298 bcopy (start2_addr
, start1_addr
, len2_byte
);
4299 bcopy (start1_addr
+ len1_byte
, start1_addr
+ len2_byte
, len_mid
);
4300 bcopy (temp
, start1_addr
+ len2_byte
+ len_mid
, len1_byte
);
4303 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4304 len1
, current_buffer
, 0);
4305 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4306 len_mid
, current_buffer
, 0);
4307 graft_intervals_into_buffer (tmp_interval2
, start1
,
4308 len2
, current_buffer
, 0);
4311 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4312 update_compositions (end2
- len1
, end2
, CHECK_BORDER
);
4315 /* When doing multiple transpositions, it might be nice
4316 to optimize this. Perhaps the markers in any one buffer
4317 should be organized in some sorted data tree. */
4318 if (NILP (leave_markers
))
4320 transpose_markers (start1
, end1
, start2
, end2
,
4321 start1_byte
, start1_byte
+ len1_byte
,
4322 start2_byte
, start2_byte
+ len2_byte
);
4323 fix_start_end_in_overlays (start1
, end2
);
4335 Qbuffer_access_fontify_functions
4336 = intern ("buffer-access-fontify-functions");
4337 staticpro (&Qbuffer_access_fontify_functions
);
4339 DEFVAR_LISP ("inhibit-field-text-motion", &Vinhibit_field_text_motion
,
4340 doc
: /* Non-nil means text motion commands don't notice fields. */);
4341 Vinhibit_field_text_motion
= Qnil
;
4343 DEFVAR_LISP ("buffer-access-fontify-functions",
4344 &Vbuffer_access_fontify_functions
,
4345 doc
: /* List of functions called by `buffer-substring' to fontify if necessary.
4346 Each function is called with two arguments which specify the range
4347 of the buffer being accessed. */);
4348 Vbuffer_access_fontify_functions
= Qnil
;
4352 extern Lisp_Object Vprin1_to_string_buffer
;
4353 obuf
= Fcurrent_buffer ();
4354 /* Do this here, because init_buffer_once is too early--it won't work. */
4355 Fset_buffer (Vprin1_to_string_buffer
);
4356 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
4357 Fset (Fmake_local_variable (intern ("buffer-access-fontify-functions")),
4362 DEFVAR_LISP ("buffer-access-fontified-property",
4363 &Vbuffer_access_fontified_property
,
4364 doc
: /* Property which (if non-nil) indicates text has been fontified.
4365 `buffer-substring' need not call the `buffer-access-fontify-functions'
4366 functions if all the text being accessed has this property. */);
4367 Vbuffer_access_fontified_property
= Qnil
;
4369 DEFVAR_LISP ("system-name", &Vsystem_name
,
4370 doc
: /* The name of the machine Emacs is running on. */);
4372 DEFVAR_LISP ("user-full-name", &Vuser_full_name
,
4373 doc
: /* The full name of the user logged in. */);
4375 DEFVAR_LISP ("user-login-name", &Vuser_login_name
,
4376 doc
: /* The user's name, taken from environment variables if possible. */);
4378 DEFVAR_LISP ("user-real-login-name", &Vuser_real_login_name
,
4379 doc
: /* The user's name, based upon the real uid only. */);
4381 defsubr (&Spropertize
);
4382 defsubr (&Schar_equal
);
4383 defsubr (&Sgoto_char
);
4384 defsubr (&Sstring_to_char
);
4385 defsubr (&Schar_to_string
);
4386 defsubr (&Sbuffer_substring
);
4387 defsubr (&Sbuffer_substring_no_properties
);
4388 defsubr (&Sbuffer_string
);
4390 defsubr (&Spoint_marker
);
4391 defsubr (&Smark_marker
);
4393 defsubr (&Sregion_beginning
);
4394 defsubr (&Sregion_end
);
4396 staticpro (&Qfield
);
4397 Qfield
= intern ("field");
4398 staticpro (&Qboundary
);
4399 Qboundary
= intern ("boundary");
4400 defsubr (&Sfield_beginning
);
4401 defsubr (&Sfield_end
);
4402 defsubr (&Sfield_string
);
4403 defsubr (&Sfield_string_no_properties
);
4404 defsubr (&Sdelete_field
);
4405 defsubr (&Sconstrain_to_field
);
4407 defsubr (&Sline_beginning_position
);
4408 defsubr (&Sline_end_position
);
4410 /* defsubr (&Smark); */
4411 /* defsubr (&Sset_mark); */
4412 defsubr (&Ssave_excursion
);
4413 defsubr (&Ssave_current_buffer
);
4415 defsubr (&Sbufsize
);
4416 defsubr (&Spoint_max
);
4417 defsubr (&Spoint_min
);
4418 defsubr (&Spoint_min_marker
);
4419 defsubr (&Spoint_max_marker
);
4420 defsubr (&Sgap_position
);
4421 defsubr (&Sgap_size
);
4422 defsubr (&Sposition_bytes
);
4423 defsubr (&Sbyte_to_position
);
4429 defsubr (&Sfollowing_char
);
4430 defsubr (&Sprevious_char
);
4431 defsubr (&Schar_after
);
4432 defsubr (&Schar_before
);
4434 defsubr (&Sinsert_before_markers
);
4435 defsubr (&Sinsert_and_inherit
);
4436 defsubr (&Sinsert_and_inherit_before_markers
);
4437 defsubr (&Sinsert_char
);
4438 defsubr (&Sinsert_byte
);
4440 defsubr (&Suser_login_name
);
4441 defsubr (&Suser_real_login_name
);
4442 defsubr (&Suser_uid
);
4443 defsubr (&Suser_real_uid
);
4444 defsubr (&Suser_full_name
);
4445 defsubr (&Semacs_pid
);
4446 defsubr (&Scurrent_time
);
4447 defsubr (&Sformat_time_string
);
4448 defsubr (&Sfloat_time
);
4449 defsubr (&Sdecode_time
);
4450 defsubr (&Sencode_time
);
4451 defsubr (&Scurrent_time_string
);
4452 defsubr (&Scurrent_time_zone
);
4453 defsubr (&Sset_time_zone_rule
);
4454 defsubr (&Ssystem_name
);
4455 defsubr (&Smessage
);
4456 defsubr (&Smessage_box
);
4457 defsubr (&Smessage_or_box
);
4458 defsubr (&Scurrent_message
);
4461 defsubr (&Sinsert_buffer_substring
);
4462 defsubr (&Scompare_buffer_substrings
);
4463 defsubr (&Ssubst_char_in_region
);
4464 defsubr (&Stranslate_region_internal
);
4465 defsubr (&Sdelete_region
);
4466 defsubr (&Sdelete_and_extract_region
);
4468 defsubr (&Snarrow_to_region
);
4469 defsubr (&Ssave_restriction
);
4470 defsubr (&Stranspose_regions
);
4473 /* arch-tag: fc3827d8-6f60-4067-b11e-c3218031b018
4474 (do not change this comment) */