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 return del_range_1 (XINT (start
), XINT (end
), 1, 1);
3006 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
3007 doc
: /* Remove restrictions (narrowing) from current buffer.
3008 This allows the buffer's full text to be seen and edited. */)
3011 if (BEG
!= BEGV
|| Z
!= ZV
)
3012 current_buffer
->clip_changed
= 1;
3014 BEGV_BYTE
= BEG_BYTE
;
3015 SET_BUF_ZV_BOTH (current_buffer
, Z
, Z_BYTE
);
3016 /* Changing the buffer bounds invalidates any recorded current column. */
3017 invalidate_current_column ();
3021 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
3022 doc
: /* Restrict editing in this buffer to the current region.
3023 The rest of the text becomes temporarily invisible and untouchable
3024 but is not deleted; if you save the buffer in a file, the invisible
3025 text is included in the file. \\[widen] makes all visible again.
3026 See also `save-restriction'.
3028 When calling from a program, pass two arguments; positions (integers
3029 or markers) bounding the text that should remain visible. */)
3031 register Lisp_Object start
, end
;
3033 CHECK_NUMBER_COERCE_MARKER (start
);
3034 CHECK_NUMBER_COERCE_MARKER (end
);
3036 if (XINT (start
) > XINT (end
))
3039 tem
= start
; start
= end
; end
= tem
;
3042 if (!(BEG
<= XINT (start
) && XINT (start
) <= XINT (end
) && XINT (end
) <= Z
))
3043 args_out_of_range (start
, end
);
3045 if (BEGV
!= XFASTINT (start
) || ZV
!= XFASTINT (end
))
3046 current_buffer
->clip_changed
= 1;
3048 SET_BUF_BEGV (current_buffer
, XFASTINT (start
));
3049 SET_BUF_ZV (current_buffer
, XFASTINT (end
));
3050 if (PT
< XFASTINT (start
))
3051 SET_PT (XFASTINT (start
));
3052 if (PT
> XFASTINT (end
))
3053 SET_PT (XFASTINT (end
));
3054 /* Changing the buffer bounds invalidates any recorded current column. */
3055 invalidate_current_column ();
3060 save_restriction_save ()
3062 if (BEGV
== BEG
&& ZV
== Z
)
3063 /* The common case that the buffer isn't narrowed.
3064 We return just the buffer object, which save_restriction_restore
3065 recognizes as meaning `no restriction'. */
3066 return Fcurrent_buffer ();
3068 /* We have to save a restriction, so return a pair of markers, one
3069 for the beginning and one for the end. */
3071 Lisp_Object beg
, end
;
3073 beg
= buildmark (BEGV
, BEGV_BYTE
);
3074 end
= buildmark (ZV
, ZV_BYTE
);
3076 /* END must move forward if text is inserted at its exact location. */
3077 XMARKER(end
)->insertion_type
= 1;
3079 return Fcons (beg
, end
);
3084 save_restriction_restore (data
)
3088 /* A pair of marks bounding a saved restriction. */
3090 struct Lisp_Marker
*beg
= XMARKER (XCAR (data
));
3091 struct Lisp_Marker
*end
= XMARKER (XCDR (data
));
3092 struct buffer
*buf
= beg
->buffer
; /* END should have the same buffer. */
3094 if (buf
/* Verify marker still points to a buffer. */
3095 && (beg
->charpos
!= BUF_BEGV (buf
) || end
->charpos
!= BUF_ZV (buf
)))
3096 /* The restriction has changed from the saved one, so restore
3097 the saved restriction. */
3099 int pt
= BUF_PT (buf
);
3101 SET_BUF_BEGV_BOTH (buf
, beg
->charpos
, beg
->bytepos
);
3102 SET_BUF_ZV_BOTH (buf
, end
->charpos
, end
->bytepos
);
3104 if (pt
< beg
->charpos
|| pt
> end
->charpos
)
3105 /* The point is outside the new visible range, move it inside. */
3106 SET_BUF_PT_BOTH (buf
,
3107 clip_to_bounds (beg
->charpos
, pt
, end
->charpos
),
3108 clip_to_bounds (beg
->bytepos
, BUF_PT_BYTE (buf
),
3111 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3115 /* A buffer, which means that there was no old restriction. */
3117 struct buffer
*buf
= XBUFFER (data
);
3119 if (buf
/* Verify marker still points to a buffer. */
3120 && (BUF_BEGV (buf
) != BUF_BEG (buf
) || BUF_ZV (buf
) != BUF_Z (buf
)))
3121 /* The buffer has been narrowed, get rid of the narrowing. */
3123 SET_BUF_BEGV_BOTH (buf
, BUF_BEG (buf
), BUF_BEG_BYTE (buf
));
3124 SET_BUF_ZV_BOTH (buf
, BUF_Z (buf
), BUF_Z_BYTE (buf
));
3126 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3133 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
3134 doc
: /* Execute BODY, saving and restoring current buffer's restrictions.
3135 The buffer's restrictions make parts of the beginning and end invisible.
3136 (They are set up with `narrow-to-region' and eliminated with `widen'.)
3137 This special form, `save-restriction', saves the current buffer's restrictions
3138 when it is entered, and restores them when it is exited.
3139 So any `narrow-to-region' within BODY lasts only until the end of the form.
3140 The old restrictions settings are restored
3141 even in case of abnormal exit (throw or error).
3143 The value returned is the value of the last form in BODY.
3145 Note: if you are using both `save-excursion' and `save-restriction',
3146 use `save-excursion' outermost:
3147 (save-excursion (save-restriction ...))
3149 usage: (save-restriction &rest BODY) */)
3153 register Lisp_Object val
;
3154 int count
= SPECPDL_INDEX ();
3156 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
3157 val
= Fprogn (body
);
3158 return unbind_to (count
, val
);
3161 /* Buffer for the most recent text displayed by Fmessage_box. */
3162 static char *message_text
;
3164 /* Allocated length of that buffer. */
3165 static int message_length
;
3167 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
3168 doc
: /* Print a one-line message at the bottom of the screen.
3169 The first argument is a format control string, and the rest are data
3170 to be formatted under control of the string. See `format' for details.
3172 If the first argument is nil, clear any existing message; let the
3173 minibuffer contents show.
3175 usage: (message STRING &rest ARGS) */)
3181 || (STRINGP (args
[0])
3182 && SBYTES (args
[0]) == 0))
3189 register Lisp_Object val
;
3190 val
= Fformat (nargs
, args
);
3191 message3 (val
, SBYTES (val
), STRING_MULTIBYTE (val
));
3196 DEFUN ("message-box", Fmessage_box
, Smessage_box
, 1, MANY
, 0,
3197 doc
: /* Display a message, in a dialog box if possible.
3198 If a dialog box is not available, use the echo area.
3199 The first argument is a format control string, and the rest are data
3200 to be formatted under control of the string. See `format' for details.
3202 If the first argument is nil, clear any existing message; let the
3203 minibuffer contents show.
3205 usage: (message-box STRING &rest ARGS) */)
3217 register Lisp_Object val
;
3218 val
= Fformat (nargs
, args
);
3220 /* The MS-DOS frames support popup menus even though they are
3221 not FRAME_WINDOW_P. */
3222 if (FRAME_WINDOW_P (XFRAME (selected_frame
))
3223 || FRAME_MSDOS_P (XFRAME (selected_frame
)))
3225 Lisp_Object pane
, menu
, obj
;
3226 struct gcpro gcpro1
;
3227 pane
= Fcons (Fcons (build_string ("OK"), Qt
), Qnil
);
3229 menu
= Fcons (val
, pane
);
3230 obj
= Fx_popup_dialog (Qt
, menu
);
3234 #endif /* HAVE_MENUS */
3235 /* Copy the data so that it won't move when we GC. */
3238 message_text
= (char *)xmalloc (80);
3239 message_length
= 80;
3241 if (SBYTES (val
) > message_length
)
3243 message_length
= SBYTES (val
);
3244 message_text
= (char *)xrealloc (message_text
, message_length
);
3246 bcopy (SDATA (val
), message_text
, SBYTES (val
));
3247 message2 (message_text
, SBYTES (val
),
3248 STRING_MULTIBYTE (val
));
3253 extern Lisp_Object last_nonmenu_event
;
3256 DEFUN ("message-or-box", Fmessage_or_box
, Smessage_or_box
, 1, MANY
, 0,
3257 doc
: /* Display a message in a dialog box or in the echo area.
3258 If this command was invoked with the mouse, use a dialog box if
3259 `use-dialog-box' is non-nil.
3260 Otherwise, use the echo area.
3261 The first argument is a format control string, and the rest are data
3262 to be formatted under control of the string. See `format' for details.
3264 If the first argument is nil, clear any existing message; let the
3265 minibuffer contents show.
3267 usage: (message-or-box STRING &rest ARGS) */)
3273 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3275 return Fmessage_box (nargs
, args
);
3277 return Fmessage (nargs
, args
);
3280 DEFUN ("current-message", Fcurrent_message
, Scurrent_message
, 0, 0, 0,
3281 doc
: /* Return the string currently displayed in the echo area, or nil if none. */)
3284 return current_message ();
3288 DEFUN ("propertize", Fpropertize
, Spropertize
, 1, MANY
, 0,
3289 doc
: /* Return a copy of STRING with text properties added.
3290 First argument is the string to copy.
3291 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
3292 properties to add to the result.
3293 usage: (propertize STRING &rest PROPERTIES) */)
3298 Lisp_Object properties
, string
;
3299 struct gcpro gcpro1
, gcpro2
;
3302 /* Number of args must be odd. */
3303 if ((nargs
& 1) == 0 || nargs
< 1)
3304 error ("Wrong number of arguments");
3306 properties
= string
= Qnil
;
3307 GCPRO2 (properties
, string
);
3309 /* First argument must be a string. */
3310 CHECK_STRING (args
[0]);
3311 string
= Fcopy_sequence (args
[0]);
3313 for (i
= 1; i
< nargs
; i
+= 2)
3315 CHECK_SYMBOL (args
[i
]);
3316 properties
= Fcons (args
[i
], Fcons (args
[i
+ 1], properties
));
3319 Fadd_text_properties (make_number (0),
3320 make_number (SCHARS (string
)),
3321 properties
, string
);
3322 RETURN_UNGCPRO (string
);
3326 /* Number of bytes that STRING will occupy when put into the result.
3327 MULTIBYTE is nonzero if the result should be multibyte. */
3329 #define CONVERTED_BYTE_SIZE(MULTIBYTE, STRING) \
3330 (((MULTIBYTE) && ! STRING_MULTIBYTE (STRING)) \
3331 ? count_size_as_multibyte (SDATA (STRING), SBYTES (STRING)) \
3334 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
3335 doc
: /* Format a string out of a control-string and arguments.
3336 The first argument is a control string.
3337 The other arguments are substituted into it to make the result, a string.
3338 It may contain %-sequences meaning to substitute the next argument.
3339 %s means print a string argument. Actually, prints any object, with `princ'.
3340 %d means print as number in decimal (%o octal, %x hex).
3341 %X is like %x, but uses upper case.
3342 %e means print a number in exponential notation.
3343 %f means print a number in decimal-point notation.
3344 %g means print a number in exponential notation
3345 or decimal-point notation, whichever uses fewer characters.
3346 %c means print a number as a single character.
3347 %S means print any object as an s-expression (using `prin1').
3348 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.
3349 Use %% to put a single % into the output.
3351 The basic structure of a %-sequence is
3352 % <flags> <width> <precision> character
3353 where flags is [- #0]+, width is [0-9]+, and precision is .[0-9]+
3355 usage: (format STRING &rest OBJECTS) */)
3358 register Lisp_Object
*args
;
3360 register int n
; /* The number of the next arg to substitute */
3361 register int total
; /* An estimate of the final length */
3363 register unsigned char *format
, *end
, *format_start
;
3365 /* Nonzero if the output should be a multibyte string,
3366 which is true if any of the inputs is one. */
3368 /* When we make a multibyte string, we must pay attention to the
3369 byte combining problem, i.e., a byte may be combined with a
3370 multibyte charcter of the previous string. This flag tells if we
3371 must consider such a situation or not. */
3372 int maybe_combine_byte
;
3373 unsigned char *this_format
;
3374 /* Precision for each spec, or -1, a flag value meaning no precision
3375 was given in that spec. Element 0, corresonding to the format
3376 string itself, will not be used. Element NARGS, corresponding to
3377 no argument, *will* be assigned to in the case that a `%' and `.'
3378 occur after the final format specifier. */
3379 int *precision
= (int *) (alloca((nargs
+ 1) * sizeof (int)));
3382 int arg_intervals
= 0;
3385 /* discarded[I] is 1 if byte I of the format
3386 string was not copied into the output.
3387 It is 2 if byte I was not the first byte of its character. */
3390 /* Each element records, for one argument,
3391 the start and end bytepos in the output string,
3392 and whether the argument is a string with intervals.
3393 info[0] is unused. Unused elements have -1 for start. */
3396 int start
, end
, intervals
;
3399 /* It should not be necessary to GCPRO ARGS, because
3400 the caller in the interpreter should take care of that. */
3402 /* Try to determine whether the result should be multibyte.
3403 This is not always right; sometimes the result needs to be multibyte
3404 because of an object that we will pass through prin1,
3405 and in that case, we won't know it here. */
3406 for (n
= 0; n
< nargs
; n
++)
3408 if (STRINGP (args
[n
]) && STRING_MULTIBYTE (args
[n
]))
3410 /* Piggyback on this loop to initialize precision[N]. */
3414 CHECK_STRING (args
[0]);
3415 /* We may have to change "%S" to "%s". */
3416 args
[0] = Fcopy_sequence (args
[0]);
3418 /* GC should never happen here, so abort if it does. */
3421 /* If we start out planning a unibyte result,
3422 then discover it has to be multibyte, we jump back to retry.
3423 That can only happen from the first large while loop below. */
3426 format
= SDATA (args
[0]);
3427 format_start
= format
;
3428 end
= format
+ SBYTES (args
[0]);
3431 /* Make room in result for all the non-%-codes in the control string. */
3432 total
= 5 + CONVERTED_BYTE_SIZE (multibyte
, args
[0]) + 1;
3434 /* Allocate the info and discarded tables. */
3436 int nbytes
= nargs
* sizeof *info
;
3438 info
= (struct info
*) alloca (nbytes
);
3439 bzero (info
, nbytes
);
3440 for (i
= 0; i
< nargs
; i
++)
3442 discarded
= (char *) alloca (SBYTES (args
[0]));
3443 bzero (discarded
, SBYTES (args
[0]));
3446 /* Add to TOTAL enough space to hold the converted arguments. */
3449 while (format
!= end
)
3450 if (*format
++ == '%')
3453 int actual_width
= 0;
3454 unsigned char *this_format_start
= format
- 1;
3455 int field_width
= 0;
3457 /* General format specifications look like
3459 '%' [flags] [field-width] [precision] format
3464 field-width ::= [0-9]+
3465 precision ::= '.' [0-9]*
3467 If a field-width is specified, it specifies to which width
3468 the output should be padded with blanks, iff the output
3469 string is shorter than field-width.
3471 If precision is specified, it specifies the number of
3472 digits to print after the '.' for floats, or the max.
3473 number of chars to print from a string. */
3475 while (index ("-0# ", *format
))
3478 if (*format
>= '0' && *format
<= '9')
3480 for (field_width
= 0; *format
>= '0' && *format
<= '9'; ++format
)
3481 field_width
= 10 * field_width
+ *format
- '0';
3484 /* N is not incremented for another few lines below, so refer to
3485 element N+1 (which might be precision[NARGS]). */
3489 for (precision
[n
+1] = 0; *format
>= '0' && *format
<= '9'; ++format
)
3490 precision
[n
+1] = 10 * precision
[n
+1] + *format
- '0';
3493 if (format
- this_format_start
+ 1 > longest_format
)
3494 longest_format
= format
- this_format_start
+ 1;
3497 error ("Format string ends in middle of format specifier");
3500 else if (++n
>= nargs
)
3501 error ("Not enough arguments for format string");
3502 else if (*format
== 'S')
3504 /* For `S', prin1 the argument and then treat like a string. */
3505 register Lisp_Object tem
;
3506 tem
= Fprin1_to_string (args
[n
], Qnil
);
3507 if (STRING_MULTIBYTE (tem
) && ! multibyte
)
3513 /* If we restart the loop, we should not come here again
3514 because args[n] is now a string and calling
3515 Fprin1_to_string on it produces superflous double
3516 quotes. So, change "%S" to "%s" now. */
3520 else if (SYMBOLP (args
[n
]))
3522 args
[n
] = SYMBOL_NAME (args
[n
]);
3523 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
3530 else if (STRINGP (args
[n
]))
3533 if (*format
!= 's' && *format
!= 'S')
3534 error ("Format specifier doesn't match argument type");
3535 /* In the case (PRECISION[N] > 0), THISSIZE may not need
3536 to be as large as is calculated here. Easy check for
3537 the case PRECISION = 0. */
3538 thissize
= precision
[n
] ? CONVERTED_BYTE_SIZE (multibyte
, args
[n
]) : 0;
3539 actual_width
= lisp_string_width (args
[n
], -1, NULL
, NULL
);
3541 /* Would get MPV otherwise, since Lisp_Int's `point' to low memory. */
3542 else if (INTEGERP (args
[n
]) && *format
!= 's')
3544 /* The following loop assumes the Lisp type indicates
3545 the proper way to pass the argument.
3546 So make sure we have a flonum if the argument should
3548 if (*format
== 'e' || *format
== 'f' || *format
== 'g')
3549 args
[n
] = Ffloat (args
[n
]);
3551 if (*format
!= 'd' && *format
!= 'o' && *format
!= 'x'
3552 && *format
!= 'i' && *format
!= 'X' && *format
!= 'c')
3553 error ("Invalid format operation %%%c", *format
);
3558 if (! ASCII_CHAR_P (XINT (args
[n
]))
3559 /* Note: No one can remeber why we have to treat
3560 the character 0 as a multibyte character here.
3561 But, until it causes a real problem, let's
3563 || XINT (args
[n
]) == 0)
3570 args
[n
] = Fchar_to_string (args
[n
]);
3571 thissize
= SBYTES (args
[n
]);
3573 else if (! ASCII_BYTE_P (XINT (args
[n
])) && multibyte
)
3576 = Fchar_to_string (Funibyte_char_to_multibyte (args
[n
]));
3577 thissize
= SBYTES (args
[n
]);
3581 else if (FLOATP (args
[n
]) && *format
!= 's')
3583 if (! (*format
== 'e' || *format
== 'f' || *format
== 'g'))
3585 if (*format
!= 'd' && *format
!= 'o' && *format
!= 'x'
3586 && *format
!= 'i' && *format
!= 'X' && *format
!= 'c')
3587 error ("Invalid format operation %%%c", *format
);
3588 args
[n
] = Ftruncate (args
[n
], Qnil
);
3591 /* Note that we're using sprintf to print floats,
3592 so we have to take into account what that function
3594 /* Filter out flag value of -1. */
3595 thissize
= (MAX_10_EXP
+ 100
3596 + (precision
[n
] > 0 ? precision
[n
] : 0));
3600 /* Anything but a string, convert to a string using princ. */
3601 register Lisp_Object tem
;
3602 tem
= Fprin1_to_string (args
[n
], Qt
);
3603 if (STRING_MULTIBYTE (tem
) && ! multibyte
)
3612 thissize
+= max (0, field_width
- actual_width
);
3613 total
+= thissize
+ 4;
3618 /* Now we can no longer jump to retry.
3619 TOTAL and LONGEST_FORMAT are known for certain. */
3621 this_format
= (unsigned char *) alloca (longest_format
+ 1);
3623 /* Allocate the space for the result.
3624 Note that TOTAL is an overestimate. */
3625 SAFE_ALLOCA (buf
, char *, total
);
3631 /* Scan the format and store result in BUF. */
3632 format
= SDATA (args
[0]);
3633 format_start
= format
;
3634 end
= format
+ SBYTES (args
[0]);
3635 maybe_combine_byte
= 0;
3636 while (format
!= end
)
3642 unsigned char *this_format_start
= format
;
3644 discarded
[format
- format_start
] = 1;
3647 while (index("-0# ", *format
))
3653 discarded
[format
- format_start
] = 1;
3657 minlen
= atoi (format
);
3659 while ((*format
>= '0' && *format
<= '9') || *format
== '.')
3661 discarded
[format
- format_start
] = 1;
3665 if (*format
++ == '%')
3674 discarded
[format
- format_start
- 1] = 1;
3675 info
[n
].start
= nchars
;
3677 if (STRINGP (args
[n
]))
3679 /* handle case (precision[n] >= 0) */
3682 int nbytes
, start
, end
;
3685 /* lisp_string_width ignores a precision of 0, but GNU
3686 libc functions print 0 characters when the precision
3687 is 0. Imitate libc behavior here. Changing
3688 lisp_string_width is the right thing, and will be
3689 done, but meanwhile we work with it. */
3691 if (precision
[n
] == 0)
3692 width
= nchars_string
= nbytes
= 0;
3693 else if (precision
[n
] > 0)
3694 width
= lisp_string_width (args
[n
], precision
[n
], &nchars_string
, &nbytes
);
3696 { /* no precision spec given for this argument */
3697 width
= lisp_string_width (args
[n
], -1, NULL
, NULL
);
3698 nbytes
= SBYTES (args
[n
]);
3699 nchars_string
= SCHARS (args
[n
]);
3702 /* If spec requires it, pad on right with spaces. */
3703 padding
= minlen
- width
;
3705 while (padding
-- > 0)
3712 nchars
+= nchars_string
;
3717 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3718 && STRING_MULTIBYTE (args
[n
])
3719 && !CHAR_HEAD_P (SREF (args
[n
], 0)))
3720 maybe_combine_byte
= 1;
3722 p
+= copy_text (SDATA (args
[n
]), p
,
3724 STRING_MULTIBYTE (args
[n
]), multibyte
);
3727 while (padding
-- > 0)
3733 /* If this argument has text properties, record where
3734 in the result string it appears. */
3735 if (STRING_INTERVALS (args
[n
]))
3736 info
[n
].intervals
= arg_intervals
= 1;
3738 else if (INTEGERP (args
[n
]) || FLOATP (args
[n
]))
3742 bcopy (this_format_start
, this_format
,
3743 format
- this_format_start
);
3744 this_format
[format
- this_format_start
] = 0;
3746 if (INTEGERP (args
[n
]))
3747 sprintf (p
, this_format
, XINT (args
[n
]));
3749 sprintf (p
, this_format
, XFLOAT_DATA (args
[n
]));
3753 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3754 && !CHAR_HEAD_P (*((unsigned char *) p
)))
3755 maybe_combine_byte
= 1;
3756 this_nchars
= strlen (p
);
3758 p
+= str_to_multibyte (p
, buf
+ total
- 1 - p
, this_nchars
);
3761 nchars
+= this_nchars
;
3764 info
[n
].end
= nchars
;
3766 else if (STRING_MULTIBYTE (args
[0]))
3768 /* Copy a whole multibyte character. */
3771 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3772 && !CHAR_HEAD_P (*format
))
3773 maybe_combine_byte
= 1;
3775 while (! CHAR_HEAD_P (*format
))
3777 discarded
[format
- format_start
] = 2;
3784 /* Convert a single-byte character to multibyte. */
3785 int len
= copy_text (format
, p
, 1, 0, 1);
3792 *p
++ = *format
++, nchars
++;
3795 if (p
> buf
+ total
)
3798 if (maybe_combine_byte
)
3799 nchars
= multibyte_chars_in_text (buf
, p
- buf
);
3800 val
= make_specified_string (buf
, nchars
, p
- buf
, multibyte
);
3802 /* If we allocated BUF with malloc, free it too. */
3805 /* If the format string has text properties, or any of the string
3806 arguments has text properties, set up text properties of the
3809 if (STRING_INTERVALS (args
[0]) || arg_intervals
)
3811 Lisp_Object len
, new_len
, props
;
3812 struct gcpro gcpro1
;
3814 /* Add text properties from the format string. */
3815 len
= make_number (SCHARS (args
[0]));
3816 props
= text_property_list (args
[0], make_number (0), len
, Qnil
);
3821 int bytepos
= 0, position
= 0, translated
= 0, argn
= 1;
3824 /* Adjust the bounds of each text property
3825 to the proper start and end in the output string. */
3826 /* We take advantage of the fact that the positions in PROPS
3827 are in increasing order, so that we can do (effectively)
3828 one scan through the position space of the format string.
3830 BYTEPOS is the byte position in the format string,
3831 POSITION is the untranslated char position in it,
3832 TRANSLATED is the translated char position in BUF,
3833 and ARGN is the number of the next arg we will come to. */
3834 for (list
= props
; CONSP (list
); list
= XCDR (list
))
3841 /* First adjust the property start position. */
3842 pos
= XINT (XCAR (item
));
3844 /* Advance BYTEPOS, POSITION, TRANSLATED and ARGN
3845 up to this position. */
3846 for (; position
< pos
; bytepos
++)
3848 if (! discarded
[bytepos
])
3849 position
++, translated
++;
3850 else if (discarded
[bytepos
] == 1)
3853 if (translated
== info
[argn
].start
)
3855 translated
+= info
[argn
].end
- info
[argn
].start
;
3861 XSETCAR (item
, make_number (translated
));
3863 /* Likewise adjust the property end position. */
3864 pos
= XINT (XCAR (XCDR (item
)));
3866 for (; bytepos
< pos
; bytepos
++)
3868 if (! discarded
[bytepos
])
3869 position
++, translated
++;
3870 else if (discarded
[bytepos
] == 1)
3873 if (translated
== info
[argn
].start
)
3875 translated
+= info
[argn
].end
- info
[argn
].start
;
3881 XSETCAR (XCDR (item
), make_number (translated
));
3884 add_text_properties_from_list (val
, props
, make_number (0));
3887 /* Add text properties from arguments. */
3889 for (n
= 1; n
< nargs
; ++n
)
3890 if (info
[n
].intervals
)
3892 len
= make_number (SCHARS (args
[n
]));
3893 new_len
= make_number (info
[n
].end
- info
[n
].start
);
3894 props
= text_property_list (args
[n
], make_number (0), len
, Qnil
);
3895 extend_property_ranges (props
, len
, new_len
);
3896 /* If successive arguments have properites, be sure that
3897 the value of `composition' property be the copy. */
3898 if (n
> 1 && info
[n
- 1].end
)
3899 make_composition_value_copy (props
);
3900 add_text_properties_from_list (val
, props
,
3901 make_number (info
[n
].start
));
3911 format2 (string1
, arg0
, arg1
)
3913 Lisp_Object arg0
, arg1
;
3915 Lisp_Object args
[3];
3916 args
[0] = build_string (string1
);
3919 return Fformat (3, args
);
3922 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
3923 doc
: /* Return t if two characters match, optionally ignoring case.
3924 Both arguments must be characters (i.e. integers).
3925 Case is ignored if `case-fold-search' is non-nil in the current buffer. */)
3927 register Lisp_Object c1
, c2
;
3933 if (XINT (c1
) == XINT (c2
))
3935 if (NILP (current_buffer
->case_fold_search
))
3938 /* Do these in separate statements,
3939 then compare the variables.
3940 because of the way DOWNCASE uses temp variables. */
3942 if (NILP (current_buffer
->enable_multibyte_characters
)
3943 && ! ASCII_CHAR_P (i1
))
3945 MAKE_CHAR_MULTIBYTE (i1
);
3948 if (NILP (current_buffer
->enable_multibyte_characters
)
3949 && ! ASCII_CHAR_P (i2
))
3951 MAKE_CHAR_MULTIBYTE (i2
);
3955 return (i1
== i2
? Qt
: Qnil
);
3958 /* Transpose the markers in two regions of the current buffer, and
3959 adjust the ones between them if necessary (i.e.: if the regions
3962 START1, END1 are the character positions of the first region.
3963 START1_BYTE, END1_BYTE are the byte positions.
3964 START2, END2 are the character positions of the second region.
3965 START2_BYTE, END2_BYTE are the byte positions.
3967 Traverses the entire marker list of the buffer to do so, adding an
3968 appropriate amount to some, subtracting from some, and leaving the
3969 rest untouched. Most of this is copied from adjust_markers in insdel.c.
3971 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
3974 transpose_markers (start1
, end1
, start2
, end2
,
3975 start1_byte
, end1_byte
, start2_byte
, end2_byte
)
3976 register int start1
, end1
, start2
, end2
;
3977 register int start1_byte
, end1_byte
, start2_byte
, end2_byte
;
3979 register int amt1
, amt1_byte
, amt2
, amt2_byte
, diff
, diff_byte
, mpos
;
3980 register struct Lisp_Marker
*marker
;
3982 /* Update point as if it were a marker. */
3986 TEMP_SET_PT_BOTH (PT
+ (end2
- end1
),
3987 PT_BYTE
+ (end2_byte
- end1_byte
));
3988 else if (PT
< start2
)
3989 TEMP_SET_PT_BOTH (PT
+ (end2
- start2
) - (end1
- start1
),
3990 (PT_BYTE
+ (end2_byte
- start2_byte
)
3991 - (end1_byte
- start1_byte
)));
3993 TEMP_SET_PT_BOTH (PT
- (start2
- start1
),
3994 PT_BYTE
- (start2_byte
- start1_byte
));
3996 /* We used to adjust the endpoints here to account for the gap, but that
3997 isn't good enough. Even if we assume the caller has tried to move the
3998 gap out of our way, it might still be at start1 exactly, for example;
3999 and that places it `inside' the interval, for our purposes. The amount
4000 of adjustment is nontrivial if there's a `denormalized' marker whose
4001 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
4002 the dirty work to Fmarker_position, below. */
4004 /* The difference between the region's lengths */
4005 diff
= (end2
- start2
) - (end1
- start1
);
4006 diff_byte
= (end2_byte
- start2_byte
) - (end1_byte
- start1_byte
);
4008 /* For shifting each marker in a region by the length of the other
4009 region plus the distance between the regions. */
4010 amt1
= (end2
- start2
) + (start2
- end1
);
4011 amt2
= (end1
- start1
) + (start2
- end1
);
4012 amt1_byte
= (end2_byte
- start2_byte
) + (start2_byte
- end1_byte
);
4013 amt2_byte
= (end1_byte
- start1_byte
) + (start2_byte
- end1_byte
);
4015 for (marker
= BUF_MARKERS (current_buffer
); marker
; marker
= marker
->next
)
4017 mpos
= marker
->bytepos
;
4018 if (mpos
>= start1_byte
&& mpos
< end2_byte
)
4020 if (mpos
< end1_byte
)
4022 else if (mpos
< start2_byte
)
4026 marker
->bytepos
= mpos
;
4028 mpos
= marker
->charpos
;
4029 if (mpos
>= start1
&& mpos
< end2
)
4033 else if (mpos
< start2
)
4038 marker
->charpos
= mpos
;
4042 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
4043 doc
: /* Transpose region STARTR1 to ENDR1 with STARTR2 to ENDR2.
4044 The regions may not be overlapping, because the size of the buffer is
4045 never changed in a transposition.
4047 Optional fifth arg LEAVE-MARKERS, if non-nil, means don't update
4048 any markers that happen to be located in the regions.
4050 Transposing beyond buffer boundaries is an error. */)
4051 (startr1
, endr1
, startr2
, endr2
, leave_markers
)
4052 Lisp_Object startr1
, endr1
, startr2
, endr2
, leave_markers
;
4054 register int start1
, end1
, start2
, end2
;
4055 int start1_byte
, start2_byte
, len1_byte
, len2_byte
;
4056 int gap
, len1
, len_mid
, len2
;
4057 unsigned char *start1_addr
, *start2_addr
, *temp
;
4059 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
;
4060 cur_intv
= BUF_INTERVALS (current_buffer
);
4062 validate_region (&startr1
, &endr1
);
4063 validate_region (&startr2
, &endr2
);
4065 start1
= XFASTINT (startr1
);
4066 end1
= XFASTINT (endr1
);
4067 start2
= XFASTINT (startr2
);
4068 end2
= XFASTINT (endr2
);
4071 /* Swap the regions if they're reversed. */
4074 register int glumph
= start1
;
4082 len1
= end1
- start1
;
4083 len2
= end2
- start2
;
4086 error ("Transposed regions overlap");
4087 else if (start1
== end1
|| start2
== end2
)
4088 error ("Transposed region has length 0");
4090 /* The possibilities are:
4091 1. Adjacent (contiguous) regions, or separate but equal regions
4092 (no, really equal, in this case!), or
4093 2. Separate regions of unequal size.
4095 The worst case is usually No. 2. It means that (aside from
4096 potential need for getting the gap out of the way), there also
4097 needs to be a shifting of the text between the two regions. So
4098 if they are spread far apart, we are that much slower... sigh. */
4100 /* It must be pointed out that the really studly thing to do would
4101 be not to move the gap at all, but to leave it in place and work
4102 around it if necessary. This would be extremely efficient,
4103 especially considering that people are likely to do
4104 transpositions near where they are working interactively, which
4105 is exactly where the gap would be found. However, such code
4106 would be much harder to write and to read. So, if you are
4107 reading this comment and are feeling squirrely, by all means have
4108 a go! I just didn't feel like doing it, so I will simply move
4109 the gap the minimum distance to get it out of the way, and then
4110 deal with an unbroken array. */
4112 /* Make sure the gap won't interfere, by moving it out of the text
4113 we will operate on. */
4114 if (start1
< gap
&& gap
< end2
)
4116 if (gap
- start1
< end2
- gap
)
4122 start1_byte
= CHAR_TO_BYTE (start1
);
4123 start2_byte
= CHAR_TO_BYTE (start2
);
4124 len1_byte
= CHAR_TO_BYTE (end1
) - start1_byte
;
4125 len2_byte
= CHAR_TO_BYTE (end2
) - start2_byte
;
4127 #ifdef BYTE_COMBINING_DEBUG
4130 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4131 len2_byte
, start1
, start1_byte
)
4132 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4133 len1_byte
, end2
, start2_byte
+ len2_byte
)
4134 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4135 len1_byte
, end2
, start2_byte
+ len2_byte
))
4140 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4141 len2_byte
, start1
, start1_byte
)
4142 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4143 len1_byte
, start2
, start2_byte
)
4144 || count_combining_after (BYTE_POS_ADDR (start2_byte
),
4145 len2_byte
, end1
, start1_byte
+ len1_byte
)
4146 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4147 len1_byte
, end2
, start2_byte
+ len2_byte
))
4152 /* Hmmm... how about checking to see if the gap is large
4153 enough to use as the temporary storage? That would avoid an
4154 allocation... interesting. Later, don't fool with it now. */
4156 /* Working without memmove, for portability (sigh), so must be
4157 careful of overlapping subsections of the array... */
4159 if (end1
== start2
) /* adjacent regions */
4161 modify_region (current_buffer
, start1
, end2
);
4162 record_change (start1
, len1
+ len2
);
4164 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4165 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4166 Fset_text_properties (make_number (start1
), make_number (end2
),
4169 /* First region smaller than second. */
4170 if (len1_byte
< len2_byte
)
4174 SAFE_ALLOCA (temp
, unsigned char *, len2_byte
);
4176 /* Don't precompute these addresses. We have to compute them
4177 at the last minute, because the relocating allocator might
4178 have moved the buffer around during the xmalloc. */
4179 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4180 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4182 bcopy (start2_addr
, temp
, len2_byte
);
4183 bcopy (start1_addr
, start1_addr
+ len2_byte
, len1_byte
);
4184 bcopy (temp
, start1_addr
, len2_byte
);
4185 SAFE_FREE (len2_byte
);
4188 /* First region not smaller than second. */
4192 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4193 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4194 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4195 bcopy (start1_addr
, temp
, len1_byte
);
4196 bcopy (start2_addr
, start1_addr
, len2_byte
);
4197 bcopy (temp
, start1_addr
+ len2_byte
, len1_byte
);
4198 SAFE_FREE (len1_byte
);
4200 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
4201 len1
, current_buffer
, 0);
4202 graft_intervals_into_buffer (tmp_interval2
, start1
,
4203 len2
, current_buffer
, 0);
4204 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4205 update_compositions (start1
+ len2
, end2
, CHECK_TAIL
);
4207 /* Non-adjacent regions, because end1 != start2, bleagh... */
4210 len_mid
= start2_byte
- (start1_byte
+ len1_byte
);
4212 if (len1_byte
== len2_byte
)
4213 /* Regions are same size, though, how nice. */
4217 modify_region (current_buffer
, start1
, end1
);
4218 modify_region (current_buffer
, start2
, end2
);
4219 record_change (start1
, len1
);
4220 record_change (start2
, len2
);
4221 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4222 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4223 Fset_text_properties (make_number (start1
), make_number (end1
),
4225 Fset_text_properties (make_number (start2
), make_number (end2
),
4228 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4229 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4230 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4231 bcopy (start1_addr
, temp
, len1_byte
);
4232 bcopy (start2_addr
, start1_addr
, len2_byte
);
4233 bcopy (temp
, start2_addr
, len1_byte
);
4234 SAFE_FREE (len1_byte
);
4236 graft_intervals_into_buffer (tmp_interval1
, start2
,
4237 len1
, current_buffer
, 0);
4238 graft_intervals_into_buffer (tmp_interval2
, start1
,
4239 len2
, current_buffer
, 0);
4242 else if (len1_byte
< len2_byte
) /* Second region larger than first */
4243 /* Non-adjacent & unequal size, area between must also be shifted. */
4247 modify_region (current_buffer
, start1
, end2
);
4248 record_change (start1
, (end2
- start1
));
4249 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4250 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4251 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4252 Fset_text_properties (make_number (start1
), make_number (end2
),
4255 /* holds region 2 */
4256 SAFE_ALLOCA (temp
, unsigned char *, len2_byte
);
4257 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4258 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4259 bcopy (start2_addr
, temp
, len2_byte
);
4260 bcopy (start1_addr
, start1_addr
+ len_mid
+ len2_byte
, len1_byte
);
4261 safe_bcopy (start1_addr
+ len1_byte
, start1_addr
+ len2_byte
, len_mid
);
4262 bcopy (temp
, start1_addr
, len2_byte
);
4263 SAFE_FREE (len2_byte
);
4265 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4266 len1
, current_buffer
, 0);
4267 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4268 len_mid
, current_buffer
, 0);
4269 graft_intervals_into_buffer (tmp_interval2
, start1
,
4270 len2
, current_buffer
, 0);
4273 /* Second region smaller than first. */
4277 record_change (start1
, (end2
- start1
));
4278 modify_region (current_buffer
, start1
, end2
);
4280 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4281 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4282 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4283 Fset_text_properties (make_number (start1
), make_number (end2
),
4286 /* holds region 1 */
4287 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4288 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4289 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4290 bcopy (start1_addr
, temp
, len1_byte
);
4291 bcopy (start2_addr
, start1_addr
, len2_byte
);
4292 bcopy (start1_addr
+ len1_byte
, start1_addr
+ len2_byte
, len_mid
);
4293 bcopy (temp
, start1_addr
+ len2_byte
+ len_mid
, len1_byte
);
4294 SAFE_FREE (len1_byte
);
4296 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4297 len1
, current_buffer
, 0);
4298 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4299 len_mid
, current_buffer
, 0);
4300 graft_intervals_into_buffer (tmp_interval2
, start1
,
4301 len2
, current_buffer
, 0);
4304 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4305 update_compositions (end2
- len1
, end2
, CHECK_BORDER
);
4308 /* When doing multiple transpositions, it might be nice
4309 to optimize this. Perhaps the markers in any one buffer
4310 should be organized in some sorted data tree. */
4311 if (NILP (leave_markers
))
4313 transpose_markers (start1
, end1
, start2
, end2
,
4314 start1_byte
, start1_byte
+ len1_byte
,
4315 start2_byte
, start2_byte
+ len2_byte
);
4316 fix_start_end_in_overlays (start1
, end2
);
4328 Qbuffer_access_fontify_functions
4329 = intern ("buffer-access-fontify-functions");
4330 staticpro (&Qbuffer_access_fontify_functions
);
4332 DEFVAR_LISP ("inhibit-field-text-motion", &Vinhibit_field_text_motion
,
4333 doc
: /* Non-nil means text motion commands don't notice fields. */);
4334 Vinhibit_field_text_motion
= Qnil
;
4336 DEFVAR_LISP ("buffer-access-fontify-functions",
4337 &Vbuffer_access_fontify_functions
,
4338 doc
: /* List of functions called by `buffer-substring' to fontify if necessary.
4339 Each function is called with two arguments which specify the range
4340 of the buffer being accessed. */);
4341 Vbuffer_access_fontify_functions
= Qnil
;
4345 extern Lisp_Object Vprin1_to_string_buffer
;
4346 obuf
= Fcurrent_buffer ();
4347 /* Do this here, because init_buffer_once is too early--it won't work. */
4348 Fset_buffer (Vprin1_to_string_buffer
);
4349 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
4350 Fset (Fmake_local_variable (intern ("buffer-access-fontify-functions")),
4355 DEFVAR_LISP ("buffer-access-fontified-property",
4356 &Vbuffer_access_fontified_property
,
4357 doc
: /* Property which (if non-nil) indicates text has been fontified.
4358 `buffer-substring' need not call the `buffer-access-fontify-functions'
4359 functions if all the text being accessed has this property. */);
4360 Vbuffer_access_fontified_property
= Qnil
;
4362 DEFVAR_LISP ("system-name", &Vsystem_name
,
4363 doc
: /* The name of the machine Emacs is running on. */);
4365 DEFVAR_LISP ("user-full-name", &Vuser_full_name
,
4366 doc
: /* The full name of the user logged in. */);
4368 DEFVAR_LISP ("user-login-name", &Vuser_login_name
,
4369 doc
: /* The user's name, taken from environment variables if possible. */);
4371 DEFVAR_LISP ("user-real-login-name", &Vuser_real_login_name
,
4372 doc
: /* The user's name, based upon the real uid only. */);
4374 defsubr (&Spropertize
);
4375 defsubr (&Schar_equal
);
4376 defsubr (&Sgoto_char
);
4377 defsubr (&Sstring_to_char
);
4378 defsubr (&Schar_to_string
);
4379 defsubr (&Sbuffer_substring
);
4380 defsubr (&Sbuffer_substring_no_properties
);
4381 defsubr (&Sbuffer_string
);
4383 defsubr (&Spoint_marker
);
4384 defsubr (&Smark_marker
);
4386 defsubr (&Sregion_beginning
);
4387 defsubr (&Sregion_end
);
4389 staticpro (&Qfield
);
4390 Qfield
= intern ("field");
4391 staticpro (&Qboundary
);
4392 Qboundary
= intern ("boundary");
4393 defsubr (&Sfield_beginning
);
4394 defsubr (&Sfield_end
);
4395 defsubr (&Sfield_string
);
4396 defsubr (&Sfield_string_no_properties
);
4397 defsubr (&Sdelete_field
);
4398 defsubr (&Sconstrain_to_field
);
4400 defsubr (&Sline_beginning_position
);
4401 defsubr (&Sline_end_position
);
4403 /* defsubr (&Smark); */
4404 /* defsubr (&Sset_mark); */
4405 defsubr (&Ssave_excursion
);
4406 defsubr (&Ssave_current_buffer
);
4408 defsubr (&Sbufsize
);
4409 defsubr (&Spoint_max
);
4410 defsubr (&Spoint_min
);
4411 defsubr (&Spoint_min_marker
);
4412 defsubr (&Spoint_max_marker
);
4413 defsubr (&Sgap_position
);
4414 defsubr (&Sgap_size
);
4415 defsubr (&Sposition_bytes
);
4416 defsubr (&Sbyte_to_position
);
4422 defsubr (&Sfollowing_char
);
4423 defsubr (&Sprevious_char
);
4424 defsubr (&Schar_after
);
4425 defsubr (&Schar_before
);
4427 defsubr (&Sinsert_before_markers
);
4428 defsubr (&Sinsert_and_inherit
);
4429 defsubr (&Sinsert_and_inherit_before_markers
);
4430 defsubr (&Sinsert_char
);
4431 defsubr (&Sinsert_byte
);
4433 defsubr (&Suser_login_name
);
4434 defsubr (&Suser_real_login_name
);
4435 defsubr (&Suser_uid
);
4436 defsubr (&Suser_real_uid
);
4437 defsubr (&Suser_full_name
);
4438 defsubr (&Semacs_pid
);
4439 defsubr (&Scurrent_time
);
4440 defsubr (&Sformat_time_string
);
4441 defsubr (&Sfloat_time
);
4442 defsubr (&Sdecode_time
);
4443 defsubr (&Sencode_time
);
4444 defsubr (&Scurrent_time_string
);
4445 defsubr (&Scurrent_time_zone
);
4446 defsubr (&Sset_time_zone_rule
);
4447 defsubr (&Ssystem_name
);
4448 defsubr (&Smessage
);
4449 defsubr (&Smessage_box
);
4450 defsubr (&Smessage_or_box
);
4451 defsubr (&Scurrent_message
);
4454 defsubr (&Sinsert_buffer_substring
);
4455 defsubr (&Scompare_buffer_substrings
);
4456 defsubr (&Ssubst_char_in_region
);
4457 defsubr (&Stranslate_region_internal
);
4458 defsubr (&Sdelete_region
);
4459 defsubr (&Sdelete_and_extract_region
);
4461 defsubr (&Snarrow_to_region
);
4462 defsubr (&Ssave_restriction
);
4463 defsubr (&Stranspose_regions
);
4466 /* arch-tag: fc3827d8-6f60-4067-b11e-c3218031b018
4467 (do not change this comment) */