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>
37 /* systime.h includes <sys/time.h> which, on some systems, is required
38 for <sys/resource.h>; thus systime.h must be included before
42 #if defined HAVE_SYS_RESOURCE_H
43 #include <sys/resource.h>
49 #include "intervals.h"
51 #include "character.h"
58 #define MAX_10_EXP DBL_MAX_10_EXP
60 #define MAX_10_EXP 310
68 extern char **environ
;
71 extern Lisp_Object make_time
P_ ((time_t));
72 extern size_t emacs_strftimeu
P_ ((char *, size_t, const char *,
73 const struct tm
*, int));
74 static int tm_diff
P_ ((struct tm
*, struct tm
*));
75 static void find_field
P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
, int *, Lisp_Object
, int *));
76 static void update_buffer_properties
P_ ((int, int));
77 static Lisp_Object region_limit
P_ ((int));
78 int lisp_time_argument
P_ ((Lisp_Object
, time_t *, int *));
79 static size_t emacs_memftimeu
P_ ((char *, size_t, const char *,
80 size_t, const struct tm
*, int));
81 static void general_insert_function
P_ ((void (*) (const unsigned char *, int),
82 void (*) (Lisp_Object
, int, int, int,
84 int, int, Lisp_Object
*));
85 static Lisp_Object subst_char_in_region_unwind
P_ ((Lisp_Object
));
86 static Lisp_Object subst_char_in_region_unwind_1
P_ ((Lisp_Object
));
87 static void transpose_markers
P_ ((int, int, int, int, int, int, int, int));
90 extern char *index
P_ ((const char *, int));
93 Lisp_Object Vbuffer_access_fontify_functions
;
94 Lisp_Object Qbuffer_access_fontify_functions
;
95 Lisp_Object Vbuffer_access_fontified_property
;
97 Lisp_Object Fuser_full_name
P_ ((Lisp_Object
));
99 /* Non-nil means don't stop at field boundary in text motion commands. */
101 Lisp_Object Vinhibit_field_text_motion
;
103 /* Some static data, and a function to initialize it for each run */
105 Lisp_Object Vsystem_name
;
106 Lisp_Object Vuser_real_login_name
; /* login name of current user ID */
107 Lisp_Object Vuser_full_name
; /* full name of current user */
108 Lisp_Object Vuser_login_name
; /* user name from LOGNAME or USER */
110 /* Symbol for the text property used to mark fields. */
114 /* A special value for Qfield properties. */
116 Lisp_Object Qboundary
;
123 register unsigned char *p
;
124 struct passwd
*pw
; /* password entry for the current user */
127 /* Set up system_name even when dumping. */
131 /* Don't bother with this on initial start when just dumping out */
134 #endif /* not CANNOT_DUMP */
136 pw
= (struct passwd
*) getpwuid (getuid ());
138 /* We let the real user name default to "root" because that's quite
139 accurate on MSDOG and because it lets Emacs find the init file.
140 (The DVX libraries override the Djgpp libraries here.) */
141 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "root");
143 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "unknown");
146 /* Get the effective user name, by consulting environment variables,
147 or the effective uid if those are unset. */
148 user_name
= (char *) getenv ("LOGNAME");
151 user_name
= (char *) getenv ("USERNAME"); /* it's USERNAME on NT */
152 #else /* WINDOWSNT */
153 user_name
= (char *) getenv ("USER");
154 #endif /* WINDOWSNT */
157 pw
= (struct passwd
*) getpwuid (geteuid ());
158 user_name
= (char *) (pw
? pw
->pw_name
: "unknown");
160 Vuser_login_name
= build_string (user_name
);
162 /* If the user name claimed in the environment vars differs from
163 the real uid, use the claimed name to find the full name. */
164 tem
= Fstring_equal (Vuser_login_name
, Vuser_real_login_name
);
165 Vuser_full_name
= Fuser_full_name (NILP (tem
)? make_number (geteuid())
168 p
= (unsigned char *) getenv ("NAME");
170 Vuser_full_name
= build_string (p
);
171 else if (NILP (Vuser_full_name
))
172 Vuser_full_name
= build_string ("unknown");
175 DEFUN ("char-to-string", Fchar_to_string
, Schar_to_string
, 1, 1, 0,
176 doc
: /* Convert arg CHAR to a string containing that character.
177 usage: (char-to-string CHAR) */)
179 Lisp_Object character
;
182 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
184 CHECK_NUMBER (character
);
186 len
= CHAR_STRING (XFASTINT (character
), str
);
187 return make_string_from_bytes (str
, 1, len
);
190 DEFUN ("string-to-char", Fstring_to_char
, Sstring_to_char
, 1, 1, 0,
191 doc
: /* Convert arg STRING to a character, the first character of that string.
192 A multibyte character is handled correctly. */)
194 register Lisp_Object string
;
196 register Lisp_Object val
;
197 CHECK_STRING (string
);
200 if (STRING_MULTIBYTE (string
))
201 XSETFASTINT (val
, STRING_CHAR (SDATA (string
), SBYTES (string
)));
203 XSETFASTINT (val
, SREF (string
, 0));
206 XSETFASTINT (val
, 0);
211 buildmark (charpos
, bytepos
)
212 int charpos
, bytepos
;
214 register Lisp_Object mark
;
215 mark
= Fmake_marker ();
216 set_marker_both (mark
, Qnil
, charpos
, bytepos
);
220 DEFUN ("point", Fpoint
, Spoint
, 0, 0, 0,
221 doc
: /* Return value of point, as an integer.
222 Beginning of buffer is position (point-min). */)
226 XSETFASTINT (temp
, PT
);
230 DEFUN ("point-marker", Fpoint_marker
, Spoint_marker
, 0, 0, 0,
231 doc
: /* Return value of point, as a marker object. */)
234 return buildmark (PT
, PT_BYTE
);
238 clip_to_bounds (lower
, num
, upper
)
239 int lower
, num
, upper
;
243 else if (num
> upper
)
249 DEFUN ("goto-char", Fgoto_char
, Sgoto_char
, 1, 1, "NGoto char: ",
250 doc
: /* Set point to POSITION, a number or marker.
251 Beginning of buffer is position (point-min), end is (point-max). */)
253 register Lisp_Object position
;
257 if (MARKERP (position
)
258 && current_buffer
== XMARKER (position
)->buffer
)
260 pos
= marker_position (position
);
262 SET_PT_BOTH (BEGV
, BEGV_BYTE
);
264 SET_PT_BOTH (ZV
, ZV_BYTE
);
266 SET_PT_BOTH (pos
, marker_byte_position (position
));
271 CHECK_NUMBER_COERCE_MARKER (position
);
273 pos
= clip_to_bounds (BEGV
, XINT (position
), ZV
);
279 /* Return the start or end position of the region.
280 BEGINNINGP non-zero means return the start.
281 If there is no region active, signal an error. */
284 region_limit (beginningp
)
287 extern Lisp_Object Vmark_even_if_inactive
; /* Defined in callint.c. */
290 if (!NILP (Vtransient_mark_mode
)
291 && NILP (Vmark_even_if_inactive
)
292 && NILP (current_buffer
->mark_active
))
293 Fsignal (Qmark_inactive
, Qnil
);
295 m
= Fmarker_position (current_buffer
->mark
);
297 error ("The mark is not set now, so there is no region");
299 if ((PT
< XFASTINT (m
)) == (beginningp
!= 0))
300 m
= make_number (PT
);
304 DEFUN ("region-beginning", Fregion_beginning
, Sregion_beginning
, 0, 0, 0,
305 doc
: /* Return position of beginning of region, as an integer. */)
308 return region_limit (1);
311 DEFUN ("region-end", Fregion_end
, Sregion_end
, 0, 0, 0,
312 doc
: /* Return position of end of region, as an integer. */)
315 return region_limit (0);
318 DEFUN ("mark-marker", Fmark_marker
, Smark_marker
, 0, 0, 0,
319 doc
: /* Return this buffer's mark, as a marker object.
320 Watch out! Moving this marker changes the mark position.
321 If you set the marker not to point anywhere, the buffer will have no mark. */)
324 return current_buffer
->mark
;
328 /* Find all the overlays in the current buffer that touch position POS.
329 Return the number found, and store them in a vector in VEC
333 overlays_around (pos
, vec
, len
)
338 Lisp_Object overlay
, start
, end
;
339 struct Lisp_Overlay
*tail
;
340 int startpos
, endpos
;
343 for (tail
= current_buffer
->overlays_before
; tail
; tail
= tail
->next
)
345 XSETMISC (overlay
, tail
);
347 end
= OVERLAY_END (overlay
);
348 endpos
= OVERLAY_POSITION (end
);
351 start
= OVERLAY_START (overlay
);
352 startpos
= OVERLAY_POSITION (start
);
357 /* Keep counting overlays even if we can't return them all. */
362 for (tail
= current_buffer
->overlays_after
; tail
; tail
= tail
->next
)
364 XSETMISC (overlay
, tail
);
366 start
= OVERLAY_START (overlay
);
367 startpos
= OVERLAY_POSITION (start
);
370 end
= OVERLAY_END (overlay
);
371 endpos
= OVERLAY_POSITION (end
);
383 /* Return the value of property PROP, in OBJECT at POSITION.
384 It's the value of PROP that a char inserted at POSITION would get.
385 OBJECT is optional and defaults to the current buffer.
386 If OBJECT is a buffer, then overlay properties are considered as well as
388 If OBJECT is a window, then that window's buffer is used, but
389 window-specific overlays are considered only if they are associated
392 get_pos_property (position
, prop
, object
)
393 Lisp_Object position
, object
;
394 register Lisp_Object prop
;
396 CHECK_NUMBER_COERCE_MARKER (position
);
399 XSETBUFFER (object
, current_buffer
);
400 else if (WINDOWP (object
))
401 object
= XWINDOW (object
)->buffer
;
403 if (!BUFFERP (object
))
404 /* pos-property only makes sense in buffers right now, since strings
405 have no overlays and no notion of insertion for which stickiness
407 return Fget_text_property (position
, prop
, object
);
410 int posn
= XINT (position
);
412 Lisp_Object
*overlay_vec
, tem
;
413 struct buffer
*obuf
= current_buffer
;
415 set_buffer_temp (XBUFFER (object
));
417 /* First try with room for 40 overlays. */
419 overlay_vec
= (Lisp_Object
*) alloca (noverlays
* sizeof (Lisp_Object
));
420 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
422 /* If there are more than 40,
423 make enough space for all, and try again. */
426 overlay_vec
= (Lisp_Object
*) alloca (noverlays
* sizeof (Lisp_Object
));
427 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
429 noverlays
= sort_overlays (overlay_vec
, noverlays
, NULL
);
431 set_buffer_temp (obuf
);
433 /* Now check the overlays in order of decreasing priority. */
434 while (--noverlays
>= 0)
436 Lisp_Object ol
= overlay_vec
[noverlays
];
437 tem
= Foverlay_get (ol
, prop
);
440 /* Check the overlay is indeed active at point. */
441 Lisp_Object start
= OVERLAY_START (ol
), finish
= OVERLAY_END (ol
);
442 if ((OVERLAY_POSITION (start
) == posn
443 && XMARKER (start
)->insertion_type
== 1)
444 || (OVERLAY_POSITION (finish
) == posn
445 && XMARKER (finish
)->insertion_type
== 0))
446 ; /* The overlay will not cover a char inserted at point. */
454 { /* Now check the text-properties. */
455 int stickiness
= text_property_stickiness (prop
, position
, object
);
457 return Fget_text_property (position
, prop
, object
);
458 else if (stickiness
< 0
459 && XINT (position
) > BUF_BEGV (XBUFFER (object
)))
460 return Fget_text_property (make_number (XINT (position
) - 1),
468 /* Find the field surrounding POS in *BEG and *END. If POS is nil,
469 the value of point is used instead. If BEG or END null,
470 means don't store the beginning or end of the field.
472 BEG_LIMIT and END_LIMIT serve to limit the ranged of the returned
473 results; they do not effect boundary behavior.
475 If MERGE_AT_BOUNDARY is nonzero, then if POS is at the very first
476 position of a field, then the beginning of the previous field is
477 returned instead of the beginning of POS's field (since the end of a
478 field is actually also the beginning of the next input field, this
479 behavior is sometimes useful). Additionally in the MERGE_AT_BOUNDARY
480 true case, if two fields are separated by a field with the special
481 value `boundary', and POS lies within it, then the two separated
482 fields are considered to be adjacent, and POS between them, when
483 finding the beginning and ending of the "merged" field.
485 Either BEG or END may be 0, in which case the corresponding value
489 find_field (pos
, merge_at_boundary
, beg_limit
, beg
, end_limit
, end
)
491 Lisp_Object merge_at_boundary
;
492 Lisp_Object beg_limit
, end_limit
;
495 /* Fields right before and after the point. */
496 Lisp_Object before_field
, after_field
;
497 /* 1 if POS counts as the start of a field. */
498 int at_field_start
= 0;
499 /* 1 if POS counts as the end of a field. */
500 int at_field_end
= 0;
503 XSETFASTINT (pos
, PT
);
505 CHECK_NUMBER_COERCE_MARKER (pos
);
508 = get_char_property_and_overlay (pos
, Qfield
, Qnil
, NULL
);
510 = (XFASTINT (pos
) > BEGV
511 ? get_char_property_and_overlay (make_number (XINT (pos
) - 1),
515 /* See if we need to handle the case where MERGE_AT_BOUNDARY is nil
516 and POS is at beginning of a field, which can also be interpreted
517 as the end of the previous field. Note that the case where if
518 MERGE_AT_BOUNDARY is non-nil (see function comment) is actually the
519 more natural one; then we avoid treating the beginning of a field
521 if (NILP (merge_at_boundary
))
523 Lisp_Object field
= get_pos_property (pos
, Qfield
, Qnil
);
524 if (!EQ (field
, after_field
))
526 if (!EQ (field
, before_field
))
528 if (NILP (field
) && at_field_start
&& at_field_end
)
529 /* If an inserted char would have a nil field while the surrounding
530 text is non-nil, we're probably not looking at a
531 zero-length field, but instead at a non-nil field that's
532 not intended for editing (such as comint's prompts). */
533 at_field_end
= at_field_start
= 0;
536 /* Note about special `boundary' fields:
538 Consider the case where the point (`.') is between the fields `x' and `y':
542 In this situation, if merge_at_boundary is true, we consider the
543 `x' and `y' fields as forming one big merged field, and so the end
544 of the field is the end of `y'.
546 However, if `x' and `y' are separated by a special `boundary' field
547 (a field with a `field' char-property of 'boundary), then we ignore
548 this special field when merging adjacent fields. Here's the same
549 situation, but with a `boundary' field between the `x' and `y' fields:
553 Here, if point is at the end of `x', the beginning of `y', or
554 anywhere in-between (within the `boundary' field), we merge all
555 three fields and consider the beginning as being the beginning of
556 the `x' field, and the end as being the end of the `y' field. */
561 /* POS is at the edge of a field, and we should consider it as
562 the beginning of the following field. */
563 *beg
= XFASTINT (pos
);
565 /* Find the previous field boundary. */
568 if (!NILP (merge_at_boundary
) && EQ (before_field
, Qboundary
))
569 /* Skip a `boundary' field. */
570 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
573 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
575 *beg
= NILP (p
) ? BEGV
: XFASTINT (p
);
582 /* POS is at the edge of a field, and we should consider it as
583 the end of the previous field. */
584 *end
= XFASTINT (pos
);
586 /* Find the next field boundary. */
588 if (!NILP (merge_at_boundary
) && EQ (after_field
, Qboundary
))
589 /* Skip a `boundary' field. */
590 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
593 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
595 *end
= NILP (pos
) ? ZV
: XFASTINT (pos
);
601 DEFUN ("delete-field", Fdelete_field
, Sdelete_field
, 0, 1, 0,
602 doc
: /* Delete the field surrounding POS.
603 A field is a region of text with the same `field' property.
604 If POS is nil, the value of point is used for POS. */)
609 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
611 del_range (beg
, end
);
615 DEFUN ("field-string", Ffield_string
, Sfield_string
, 0, 1, 0,
616 doc
: /* Return the contents of the field surrounding POS as a string.
617 A field is a region of text with the same `field' property.
618 If POS is nil, the value of point is used for POS. */)
623 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
624 return make_buffer_string (beg
, end
, 1);
627 DEFUN ("field-string-no-properties", Ffield_string_no_properties
, Sfield_string_no_properties
, 0, 1, 0,
628 doc
: /* Return the contents of the field around POS, without text-properties.
629 A field is a region of text with the same `field' property.
630 If POS is nil, the value of point is used for POS. */)
635 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
636 return make_buffer_string (beg
, end
, 0);
639 DEFUN ("field-beginning", Ffield_beginning
, Sfield_beginning
, 0, 3, 0,
640 doc
: /* Return the beginning of the field surrounding POS.
641 A field is a region of text with the same `field' property.
642 If POS is nil, the value of point is used for POS.
643 If ESCAPE-FROM-EDGE is non-nil and POS is at the beginning of its
644 field, then the beginning of the *previous* field is returned.
645 If LIMIT is non-nil, it is a buffer position; if the beginning of the field
646 is before LIMIT, then LIMIT will be returned instead. */)
647 (pos
, escape_from_edge
, limit
)
648 Lisp_Object pos
, escape_from_edge
, limit
;
651 find_field (pos
, escape_from_edge
, limit
, &beg
, Qnil
, 0);
652 return make_number (beg
);
655 DEFUN ("field-end", Ffield_end
, Sfield_end
, 0, 3, 0,
656 doc
: /* Return the end of the field surrounding POS.
657 A field is a region of text with the same `field' property.
658 If POS is nil, the value of point is used for POS.
659 If ESCAPE-FROM-EDGE is non-nil and POS is at the end of its field,
660 then the end of the *following* field is returned.
661 If LIMIT is non-nil, it is a buffer position; if the end of the field
662 is after LIMIT, then LIMIT will be returned instead. */)
663 (pos
, escape_from_edge
, limit
)
664 Lisp_Object pos
, escape_from_edge
, limit
;
667 find_field (pos
, escape_from_edge
, Qnil
, 0, limit
, &end
);
668 return make_number (end
);
671 DEFUN ("constrain-to-field", Fconstrain_to_field
, Sconstrain_to_field
, 2, 5, 0,
672 doc
: /* Return the position closest to NEW-POS that is in the same field as OLD-POS.
674 A field is a region of text with the same `field' property.
675 If NEW-POS is nil, then the current point is used instead, and set to the
676 constrained position if that is different.
678 If OLD-POS is at the boundary of two fields, then the allowable
679 positions for NEW-POS depends on the value of the optional argument
680 ESCAPE-FROM-EDGE: If ESCAPE-FROM-EDGE is nil, then NEW-POS is
681 constrained to the field that has the same `field' char-property
682 as any new characters inserted at OLD-POS, whereas if ESCAPE-FROM-EDGE
683 is non-nil, NEW-POS is constrained to the union of the two adjacent
684 fields. Additionally, if two fields are separated by another field with
685 the special value `boundary', then any point within this special field is
686 also considered to be `on the boundary'.
688 If the optional argument ONLY-IN-LINE is non-nil and constraining
689 NEW-POS would move it to a different line, NEW-POS is returned
690 unconstrained. This useful for commands that move by line, like
691 \\[next-line] or \\[beginning-of-line], which should generally respect field boundaries
692 only in the case where they can still move to the right line.
694 If the optional argument INHIBIT-CAPTURE-PROPERTY is non-nil, and OLD-POS has
695 a non-nil property of that name, then any field boundaries are ignored.
697 Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */)
698 (new_pos
, old_pos
, escape_from_edge
, only_in_line
, inhibit_capture_property
)
699 Lisp_Object new_pos
, old_pos
;
700 Lisp_Object escape_from_edge
, only_in_line
, inhibit_capture_property
;
702 /* If non-zero, then the original point, before re-positioning. */
706 /* Use the current point, and afterwards, set it. */
709 XSETFASTINT (new_pos
, PT
);
712 if (NILP (Vinhibit_field_text_motion
)
713 && !EQ (new_pos
, old_pos
)
714 && (!NILP (Fget_char_property (new_pos
, Qfield
, Qnil
))
715 || !NILP (Fget_char_property (old_pos
, Qfield
, Qnil
)))
716 && (NILP (inhibit_capture_property
)
717 || NILP (Fget_char_property(old_pos
, inhibit_capture_property
, Qnil
))))
718 /* NEW_POS is not within the same field as OLD_POS; try to
719 move NEW_POS so that it is. */
722 Lisp_Object field_bound
;
724 CHECK_NUMBER_COERCE_MARKER (new_pos
);
725 CHECK_NUMBER_COERCE_MARKER (old_pos
);
727 fwd
= (XFASTINT (new_pos
) > XFASTINT (old_pos
));
730 field_bound
= Ffield_end (old_pos
, escape_from_edge
, new_pos
);
732 field_bound
= Ffield_beginning (old_pos
, escape_from_edge
, new_pos
);
734 if (/* See if ESCAPE_FROM_EDGE caused FIELD_BOUND to jump to the
735 other side of NEW_POS, which would mean that NEW_POS is
736 already acceptable, and it's not necessary to constrain it
738 ((XFASTINT (field_bound
) < XFASTINT (new_pos
)) ? fwd
: !fwd
)
739 /* NEW_POS should be constrained, but only if either
740 ONLY_IN_LINE is nil (in which case any constraint is OK),
741 or NEW_POS and FIELD_BOUND are on the same line (in which
742 case the constraint is OK even if ONLY_IN_LINE is non-nil). */
743 && (NILP (only_in_line
)
744 /* This is the ONLY_IN_LINE case, check that NEW_POS and
745 FIELD_BOUND are on the same line by seeing whether
746 there's an intervening newline or not. */
747 || (scan_buffer ('\n',
748 XFASTINT (new_pos
), XFASTINT (field_bound
),
749 fwd
? -1 : 1, &shortage
, 1),
751 /* Constrain NEW_POS to FIELD_BOUND. */
752 new_pos
= field_bound
;
754 if (orig_point
&& XFASTINT (new_pos
) != orig_point
)
755 /* The NEW_POS argument was originally nil, so automatically set PT. */
756 SET_PT (XFASTINT (new_pos
));
763 DEFUN ("line-beginning-position",
764 Fline_beginning_position
, Sline_beginning_position
, 0, 1, 0,
765 doc
: /* Return the character position of the first character on the current line.
766 With argument N not nil or 1, move forward N - 1 lines first.
767 If scan reaches end of buffer, return that position.
769 The scan does not cross a field boundary unless doing so would move
770 beyond there to a different line; if N is nil or 1, and scan starts at a
771 field boundary, the scan stops as soon as it starts. To ignore field
772 boundaries bind `inhibit-field-text-motion' to t.
774 This function does not move point. */)
778 int orig
, orig_byte
, end
;
787 Fforward_line (make_number (XINT (n
) - 1));
790 SET_PT_BOTH (orig
, orig_byte
);
792 /* Return END constrained to the current input field. */
793 return Fconstrain_to_field (make_number (end
), make_number (orig
),
794 XINT (n
) != 1 ? Qt
: Qnil
,
798 DEFUN ("line-end-position", Fline_end_position
, Sline_end_position
, 0, 1, 0,
799 doc
: /* Return the character position of the last character on the current line.
800 With argument N not nil or 1, move forward N - 1 lines first.
801 If scan reaches end of buffer, return that position.
803 The scan does not cross a field boundary unless doing so would move
804 beyond there to a different line; if N is nil or 1, and scan starts at a
805 field boundary, the scan stops as soon as it starts. To ignore field
806 boundaries bind `inhibit-field-text-motion' to t.
808 This function does not move point. */)
820 end_pos
= find_before_next_newline (orig
, 0, XINT (n
) - (XINT (n
) <= 0));
822 /* Return END_POS constrained to the current input field. */
823 return Fconstrain_to_field (make_number (end_pos
), make_number (orig
),
829 save_excursion_save ()
831 int visible
= (XBUFFER (XWINDOW (selected_window
)->buffer
)
834 return Fcons (Fpoint_marker (),
835 Fcons (Fcopy_marker (current_buffer
->mark
, Qnil
),
836 Fcons (visible
? Qt
: Qnil
,
837 Fcons (current_buffer
->mark_active
,
842 save_excursion_restore (info
)
845 Lisp_Object tem
, tem1
, omark
, nmark
;
846 struct gcpro gcpro1
, gcpro2
, gcpro3
;
849 tem
= Fmarker_buffer (XCAR (info
));
850 /* If buffer being returned to is now deleted, avoid error */
851 /* Otherwise could get error here while unwinding to top level
853 /* In that case, Fmarker_buffer returns nil now. */
857 omark
= nmark
= Qnil
;
858 GCPRO3 (info
, omark
, nmark
);
865 unchain_marker (XMARKER (tem
));
870 omark
= Fmarker_position (current_buffer
->mark
);
871 Fset_marker (current_buffer
->mark
, tem
, Fcurrent_buffer ());
872 nmark
= Fmarker_position (tem
);
873 unchain_marker (XMARKER (tem
));
877 visible_p
= !NILP (XCAR (info
));
879 #if 0 /* We used to make the current buffer visible in the selected window
880 if that was true previously. That avoids some anomalies.
881 But it creates others, and it wasn't documented, and it is simpler
882 and cleaner never to alter the window/buffer connections. */
885 && current_buffer
!= XBUFFER (XWINDOW (selected_window
)->buffer
))
886 Fswitch_to_buffer (Fcurrent_buffer (), Qnil
);
892 tem1
= current_buffer
->mark_active
;
893 current_buffer
->mark_active
= tem
;
895 if (!NILP (Vrun_hooks
))
897 /* If mark is active now, and either was not active
898 or was at a different place, run the activate hook. */
899 if (! NILP (current_buffer
->mark_active
))
901 if (! EQ (omark
, nmark
))
902 call1 (Vrun_hooks
, intern ("activate-mark-hook"));
904 /* If mark has ceased to be active, run deactivate hook. */
905 else if (! NILP (tem1
))
906 call1 (Vrun_hooks
, intern ("deactivate-mark-hook"));
909 /* If buffer was visible in a window, and a different window was
910 selected, and the old selected window is still showing this
911 buffer, restore point in that window. */
914 && !EQ (tem
, selected_window
)
915 && (tem1
= XWINDOW (tem
)->buffer
,
916 (/* Window is live... */
918 /* ...and it shows the current buffer. */
919 && XBUFFER (tem1
) == current_buffer
)))
920 Fset_window_point (tem
, make_number (PT
));
926 DEFUN ("save-excursion", Fsave_excursion
, Ssave_excursion
, 0, UNEVALLED
, 0,
927 doc
: /* Save point, mark, and current buffer; execute BODY; restore those things.
928 Executes BODY just like `progn'.
929 The values of point, mark and the current buffer are restored
930 even in case of abnormal exit (throw or error).
931 The state of activation of the mark is also restored.
933 This construct does not save `deactivate-mark', and therefore
934 functions that change the buffer will still cause deactivation
935 of the mark at the end of the command. To prevent that, bind
936 `deactivate-mark' with `let'.
938 usage: (save-excursion &rest BODY) */)
942 register Lisp_Object val
;
943 int count
= SPECPDL_INDEX ();
945 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
948 return unbind_to (count
, val
);
951 DEFUN ("save-current-buffer", Fsave_current_buffer
, Ssave_current_buffer
, 0, UNEVALLED
, 0,
952 doc
: /* Save the current buffer; execute BODY; restore the current buffer.
953 Executes BODY just like `progn'.
954 usage: (save-current-buffer &rest BODY) */)
959 int count
= SPECPDL_INDEX ();
961 record_unwind_protect (set_buffer_if_live
, Fcurrent_buffer ());
964 return unbind_to (count
, val
);
967 DEFUN ("buffer-size", Fbufsize
, Sbufsize
, 0, 1, 0,
968 doc
: /* Return the number of characters in the current buffer.
969 If BUFFER, return the number of characters in that buffer instead. */)
974 return make_number (Z
- BEG
);
977 CHECK_BUFFER (buffer
);
978 return make_number (BUF_Z (XBUFFER (buffer
))
979 - BUF_BEG (XBUFFER (buffer
)));
983 DEFUN ("point-min", Fpoint_min
, Spoint_min
, 0, 0, 0,
984 doc
: /* Return the minimum permissible value of point in the current buffer.
985 This is 1, unless narrowing (a buffer restriction) is in effect. */)
989 XSETFASTINT (temp
, BEGV
);
993 DEFUN ("point-min-marker", Fpoint_min_marker
, Spoint_min_marker
, 0, 0, 0,
994 doc
: /* Return a marker to the minimum permissible value of point in this buffer.
995 This is the beginning, unless narrowing (a buffer restriction) is in effect. */)
998 return buildmark (BEGV
, BEGV_BYTE
);
1001 DEFUN ("point-max", Fpoint_max
, Spoint_max
, 0, 0, 0,
1002 doc
: /* Return the maximum permissible value of point in the current buffer.
1003 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1004 is in effect, in which case it is less. */)
1008 XSETFASTINT (temp
, ZV
);
1012 DEFUN ("point-max-marker", Fpoint_max_marker
, Spoint_max_marker
, 0, 0, 0,
1013 doc
: /* Return a marker to the maximum permissible value of point in this buffer.
1014 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1015 is in effect, in which case it is less. */)
1018 return buildmark (ZV
, ZV_BYTE
);
1021 DEFUN ("gap-position", Fgap_position
, Sgap_position
, 0, 0, 0,
1022 doc
: /* Return the position of the gap, in the current buffer.
1023 See also `gap-size'. */)
1027 XSETFASTINT (temp
, GPT
);
1031 DEFUN ("gap-size", Fgap_size
, Sgap_size
, 0, 0, 0,
1032 doc
: /* Return the size of the current buffer's gap.
1033 See also `gap-position'. */)
1037 XSETFASTINT (temp
, GAP_SIZE
);
1041 DEFUN ("position-bytes", Fposition_bytes
, Sposition_bytes
, 1, 1, 0,
1042 doc
: /* Return the byte position for character position POSITION.
1043 If POSITION is out of range, the value is nil. */)
1045 Lisp_Object position
;
1047 CHECK_NUMBER_COERCE_MARKER (position
);
1048 if (XINT (position
) < BEG
|| XINT (position
) > Z
)
1050 return make_number (CHAR_TO_BYTE (XINT (position
)));
1053 DEFUN ("byte-to-position", Fbyte_to_position
, Sbyte_to_position
, 1, 1, 0,
1054 doc
: /* Return the character position for byte position BYTEPOS.
1055 If BYTEPOS is out of range, the value is nil. */)
1057 Lisp_Object bytepos
;
1059 CHECK_NUMBER (bytepos
);
1060 if (XINT (bytepos
) < BEG_BYTE
|| XINT (bytepos
) > Z_BYTE
)
1062 return make_number (BYTE_TO_CHAR (XINT (bytepos
)));
1065 DEFUN ("following-char", Ffollowing_char
, Sfollowing_char
, 0, 0, 0,
1066 doc
: /* Return the character following point, as a number.
1067 At the end of the buffer or accessible region, return 0. */)
1072 XSETFASTINT (temp
, 0);
1074 XSETFASTINT (temp
, FETCH_CHAR (PT_BYTE
));
1078 DEFUN ("preceding-char", Fprevious_char
, Sprevious_char
, 0, 0, 0,
1079 doc
: /* Return the character preceding point, as a number.
1080 At the beginning of the buffer or accessible region, return 0. */)
1085 XSETFASTINT (temp
, 0);
1086 else if (!NILP (current_buffer
->enable_multibyte_characters
))
1090 XSETFASTINT (temp
, FETCH_CHAR (pos
));
1093 XSETFASTINT (temp
, FETCH_BYTE (PT_BYTE
- 1));
1097 DEFUN ("bobp", Fbobp
, Sbobp
, 0, 0, 0,
1098 doc
: /* Return t if point is at the beginning of the buffer.
1099 If the buffer is narrowed, this means the beginning of the narrowed part. */)
1107 DEFUN ("eobp", Feobp
, Seobp
, 0, 0, 0,
1108 doc
: /* Return t if point is at the end of the buffer.
1109 If the buffer is narrowed, this means the end of the narrowed part. */)
1117 DEFUN ("bolp", Fbolp
, Sbolp
, 0, 0, 0,
1118 doc
: /* Return t if point is at the beginning of a line. */)
1121 if (PT
== BEGV
|| FETCH_BYTE (PT_BYTE
- 1) == '\n')
1126 DEFUN ("eolp", Feolp
, Seolp
, 0, 0, 0,
1127 doc
: /* Return t if point is at the end of a line.
1128 `End of a line' includes point being at the end of the buffer. */)
1131 if (PT
== ZV
|| FETCH_BYTE (PT_BYTE
) == '\n')
1136 DEFUN ("char-after", Fchar_after
, Schar_after
, 0, 1, 0,
1137 doc
: /* Return character in current buffer at position POS.
1138 POS is an integer or a marker and defaults to point.
1139 If POS is out of range, the value is nil. */)
1143 register int pos_byte
;
1148 XSETFASTINT (pos
, PT
);
1153 pos_byte
= marker_byte_position (pos
);
1154 if (pos_byte
< BEGV_BYTE
|| pos_byte
>= ZV_BYTE
)
1159 CHECK_NUMBER_COERCE_MARKER (pos
);
1160 if (XINT (pos
) < BEGV
|| XINT (pos
) >= ZV
)
1163 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1166 return make_number (FETCH_CHAR (pos_byte
));
1169 DEFUN ("char-before", Fchar_before
, Schar_before
, 0, 1, 0,
1170 doc
: /* Return character in current buffer preceding position POS.
1171 POS is an integer or a marker and defaults to point.
1172 If POS is out of range, the value is nil. */)
1176 register Lisp_Object val
;
1177 register int pos_byte
;
1182 XSETFASTINT (pos
, PT
);
1187 pos_byte
= marker_byte_position (pos
);
1189 if (pos_byte
<= BEGV_BYTE
|| pos_byte
> ZV_BYTE
)
1194 CHECK_NUMBER_COERCE_MARKER (pos
);
1196 if (XINT (pos
) <= BEGV
|| XINT (pos
) > ZV
)
1199 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1202 if (!NILP (current_buffer
->enable_multibyte_characters
))
1205 XSETFASTINT (val
, FETCH_CHAR (pos_byte
));
1210 XSETFASTINT (val
, FETCH_BYTE (pos_byte
));
1215 DEFUN ("user-login-name", Fuser_login_name
, Suser_login_name
, 0, 1, 0,
1216 doc
: /* Return the name under which the user logged in, as a string.
1217 This is based on the effective uid, not the real uid.
1218 Also, if the environment variables LOGNAME or USER are set,
1219 that determines the value of this function.
1221 If optional argument UID is an integer, return the login name of the user
1222 with that uid, or nil if there is no such user. */)
1228 /* Set up the user name info if we didn't do it before.
1229 (That can happen if Emacs is dumpable
1230 but you decide to run `temacs -l loadup' and not dump. */
1231 if (INTEGERP (Vuser_login_name
))
1235 return Vuser_login_name
;
1238 pw
= (struct passwd
*) getpwuid (XINT (uid
));
1239 return (pw
? build_string (pw
->pw_name
) : Qnil
);
1242 DEFUN ("user-real-login-name", Fuser_real_login_name
, Suser_real_login_name
,
1244 doc
: /* Return the name of the user's real uid, as a string.
1245 This ignores the environment variables LOGNAME and USER, so it differs from
1246 `user-login-name' when running under `su'. */)
1249 /* Set up the user name info if we didn't do it before.
1250 (That can happen if Emacs is dumpable
1251 but you decide to run `temacs -l loadup' and not dump. */
1252 if (INTEGERP (Vuser_login_name
))
1254 return Vuser_real_login_name
;
1257 DEFUN ("user-uid", Fuser_uid
, Suser_uid
, 0, 0, 0,
1258 doc
: /* Return the effective uid of Emacs.
1259 Value is an integer or float, depending on the value. */)
1262 return make_fixnum_or_float (geteuid ());
1265 DEFUN ("user-real-uid", Fuser_real_uid
, Suser_real_uid
, 0, 0, 0,
1266 doc
: /* Return the real uid of Emacs.
1267 Value is an integer or float, depending on the value. */)
1270 return make_fixnum_or_float (getuid ());
1273 DEFUN ("user-full-name", Fuser_full_name
, Suser_full_name
, 0, 1, 0,
1274 doc
: /* Return the full name of the user logged in, as a string.
1275 If the full name corresponding to Emacs's userid is not known,
1278 If optional argument UID is an integer or float, return the full name
1279 of the user with that uid, or nil if there is no such user.
1280 If UID is a string, return the full name of the user with that login
1281 name, or nil if there is no such user. */)
1286 register unsigned char *p
, *q
;
1290 return Vuser_full_name
;
1291 else if (NUMBERP (uid
))
1292 pw
= (struct passwd
*) getpwuid ((uid_t
) XFLOATINT (uid
));
1293 else if (STRINGP (uid
))
1294 pw
= (struct passwd
*) getpwnam (SDATA (uid
));
1296 error ("Invalid UID specification");
1301 p
= (unsigned char *) USER_FULL_NAME
;
1302 /* Chop off everything after the first comma. */
1303 q
= (unsigned char *) index (p
, ',');
1304 full
= make_string (p
, q
? q
- p
: strlen (p
));
1306 #ifdef AMPERSAND_FULL_NAME
1308 q
= (unsigned char *) index (p
, '&');
1309 /* Substitute the login name for the &, upcasing the first character. */
1312 register unsigned char *r
;
1315 login
= Fuser_login_name (make_number (pw
->pw_uid
));
1316 r
= (unsigned char *) alloca (strlen (p
) + SCHARS (login
) + 1);
1317 bcopy (p
, r
, q
- p
);
1319 strcat (r
, SDATA (login
));
1320 r
[q
- p
] = UPCASE (r
[q
- p
]);
1322 full
= build_string (r
);
1324 #endif /* AMPERSAND_FULL_NAME */
1329 DEFUN ("system-name", Fsystem_name
, Ssystem_name
, 0, 0, 0,
1330 doc
: /* Return the name of the machine you are running on, as a string. */)
1333 return Vsystem_name
;
1336 /* For the benefit of callers who don't want to include lisp.h */
1341 if (STRINGP (Vsystem_name
))
1342 return (char *) SDATA (Vsystem_name
);
1347 DEFUN ("emacs-pid", Femacs_pid
, Semacs_pid
, 0, 0, 0,
1348 doc
: /* Return the process ID of Emacs, as an integer. */)
1351 return make_number (getpid ());
1354 DEFUN ("current-time", Fcurrent_time
, Scurrent_time
, 0, 0, 0,
1355 doc
: /* Return the current time, as the number of seconds since 1970-01-01 00:00:00.
1356 The time is returned as a list of three integers. The first has the
1357 most significant 16 bits of the seconds, while the second has the
1358 least significant 16 bits. The third integer gives the microsecond
1361 The microsecond count is zero on systems that do not provide
1362 resolution finer than a second. */)
1366 Lisp_Object result
[3];
1369 XSETINT (result
[0], (EMACS_SECS (t
) >> 16) & 0xffff);
1370 XSETINT (result
[1], (EMACS_SECS (t
) >> 0) & 0xffff);
1371 XSETINT (result
[2], EMACS_USECS (t
));
1373 return Flist (3, result
);
1376 DEFUN ("get-internal-run-time", Fget_internal_run_time
, Sget_internal_run_time
,
1378 doc
: /* Return the current run time used by Emacs.
1379 The time is returned as a list of three integers. The first has the
1380 most significant 16 bits of the seconds, while the second has the
1381 least significant 16 bits. The third integer gives the microsecond
1384 On systems that can't determine the run time, get-internal-run-time
1385 does the same thing as current-time. The microsecond count is zero on
1386 systems that do not provide resolution finer than a second. */)
1389 #ifdef HAVE_GETRUSAGE
1390 struct rusage usage
;
1391 Lisp_Object result
[3];
1394 if (getrusage (RUSAGE_SELF
, &usage
) < 0)
1395 /* This shouldn't happen. What action is appropriate? */
1396 Fsignal (Qerror
, Qnil
);
1398 /* Sum up user time and system time. */
1399 secs
= usage
.ru_utime
.tv_sec
+ usage
.ru_stime
.tv_sec
;
1400 usecs
= usage
.ru_utime
.tv_usec
+ usage
.ru_stime
.tv_usec
;
1401 if (usecs
>= 1000000)
1407 XSETINT (result
[0], (secs
>> 16) & 0xffff);
1408 XSETINT (result
[1], (secs
>> 0) & 0xffff);
1409 XSETINT (result
[2], usecs
);
1411 return Flist (3, result
);
1413 return Fcurrent_time ();
1419 lisp_time_argument (specified_time
, result
, usec
)
1420 Lisp_Object specified_time
;
1424 if (NILP (specified_time
))
1431 *usec
= EMACS_USECS (t
);
1432 *result
= EMACS_SECS (t
);
1436 return time (result
) != -1;
1440 Lisp_Object high
, low
;
1441 high
= Fcar (specified_time
);
1442 CHECK_NUMBER (high
);
1443 low
= Fcdr (specified_time
);
1448 Lisp_Object usec_l
= Fcdr (low
);
1450 usec_l
= Fcar (usec_l
);
1455 CHECK_NUMBER (usec_l
);
1456 *usec
= XINT (usec_l
);
1464 *result
= (XINT (high
) << 16) + (XINT (low
) & 0xffff);
1465 return *result
>> 16 == XINT (high
);
1469 DEFUN ("float-time", Ffloat_time
, Sfloat_time
, 0, 1, 0,
1470 doc
: /* Return the current time, as a float number of seconds since the epoch.
1471 If SPECIFIED-TIME is given, it is the time to convert to float
1472 instead of the current time. The argument should have the form
1473 (HIGH LOW . IGNORED). Thus, you can use times obtained from
1474 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
1475 have the form (HIGH . LOW), but this is considered obsolete.
1477 WARNING: Since the result is floating point, it may not be exact.
1478 Do not use this function if precise time stamps are required. */)
1480 Lisp_Object specified_time
;
1485 if (! lisp_time_argument (specified_time
, &sec
, &usec
))
1486 error ("Invalid time specification");
1488 return make_float ((sec
* 1e6
+ usec
) / 1e6
);
1491 /* Write information into buffer S of size MAXSIZE, according to the
1492 FORMAT of length FORMAT_LEN, using time information taken from *TP.
1493 Default to Universal Time if UT is nonzero, local time otherwise.
1494 Return the number of bytes written, not including the terminating
1495 '\0'. If S is NULL, nothing will be written anywhere; so to
1496 determine how many bytes would be written, use NULL for S and
1497 ((size_t) -1) for MAXSIZE.
1499 This function behaves like emacs_strftimeu, except it allows null
1502 emacs_memftimeu (s
, maxsize
, format
, format_len
, tp
, ut
)
1507 const struct tm
*tp
;
1512 /* Loop through all the null-terminated strings in the format
1513 argument. Normally there's just one null-terminated string, but
1514 there can be arbitrarily many, concatenated together, if the
1515 format contains '\0' bytes. emacs_strftimeu stops at the first
1516 '\0' byte so we must invoke it separately for each such string. */
1525 result
= emacs_strftimeu (s
, maxsize
, format
, tp
, ut
);
1529 if (result
== 0 && s
[0] != '\0')
1534 maxsize
-= result
+ 1;
1536 len
= strlen (format
);
1537 if (len
== format_len
)
1541 format_len
-= len
+ 1;
1545 DEFUN ("format-time-string", Fformat_time_string
, Sformat_time_string
, 1, 3, 0,
1546 doc
: /* Use FORMAT-STRING to format the time TIME, or now if omitted.
1547 TIME is specified as (HIGH LOW . IGNORED), as returned by
1548 `current-time' or `file-attributes'. The obsolete form (HIGH . LOW)
1549 is also still accepted.
1550 The third, optional, argument UNIVERSAL, if non-nil, means describe TIME
1551 as Universal Time; nil means describe TIME in the local time zone.
1552 The value is a copy of FORMAT-STRING, but with certain constructs replaced
1553 by text that describes the specified date and time in TIME:
1555 %Y is the year, %y within the century, %C the century.
1556 %G is the year corresponding to the ISO week, %g within the century.
1557 %m is the numeric month.
1558 %b and %h are the locale's abbreviated month name, %B the full name.
1559 %d is the day of the month, zero-padded, %e is blank-padded.
1560 %u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.
1561 %a is the locale's abbreviated name of the day of week, %A the full name.
1562 %U is the week number starting on Sunday, %W starting on Monday,
1563 %V according to ISO 8601.
1564 %j is the day of the year.
1566 %H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H
1567 only blank-padded, %l is like %I blank-padded.
1568 %p is the locale's equivalent of either AM or PM.
1571 %Z is the time zone name, %z is the numeric form.
1572 %s is the number of seconds since 1970-01-01 00:00:00 +0000.
1574 %c is the locale's date and time format.
1575 %x is the locale's "preferred" date format.
1576 %D is like "%m/%d/%y".
1578 %R is like "%H:%M", %T is like "%H:%M:%S", %r is like "%I:%M:%S %p".
1579 %X is the locale's "preferred" time format.
1581 Finally, %n is a newline, %t is a tab, %% is a literal %.
1583 Certain flags and modifiers are available with some format controls.
1584 The flags are `_', `-', `^' and `#'. For certain characters X,
1585 %_X is like %X, but padded with blanks; %-X is like %X,
1586 but without padding. %^X is like %X, but with all textual
1587 characters up-cased; %#X is like %X, but with letter-case of
1588 all textual characters reversed.
1589 %NX (where N stands for an integer) is like %X,
1590 but takes up at least N (a number) positions.
1591 The modifiers are `E' and `O'. For certain characters X,
1592 %EX is a locale's alternative version of %X;
1593 %OX is like %X, but uses the locale's number symbols.
1595 For example, to produce full ISO 8601 format, use "%Y-%m-%dT%T%z". */)
1596 (format_string
, time
, universal
)
1597 Lisp_Object format_string
, time
, universal
;
1602 int ut
= ! NILP (universal
);
1604 CHECK_STRING (format_string
);
1606 if (! lisp_time_argument (time
, &value
, NULL
))
1607 error ("Invalid time specification");
1609 format_string
= code_convert_string_norecord (format_string
,
1610 Vlocale_coding_system
, 1);
1612 /* This is probably enough. */
1613 size
= SBYTES (format_string
) * 6 + 50;
1615 tm
= ut
? gmtime (&value
) : localtime (&value
);
1617 error ("Specified time is not representable");
1619 synchronize_system_time_locale ();
1623 char *buf
= (char *) alloca (size
+ 1);
1627 result
= emacs_memftimeu (buf
, size
, SDATA (format_string
),
1628 SBYTES (format_string
),
1630 if ((result
> 0 && result
< size
) || (result
== 0 && buf
[0] == '\0'))
1631 return code_convert_string_norecord (make_string (buf
, result
),
1632 Vlocale_coding_system
, 0);
1634 /* If buffer was too small, make it bigger and try again. */
1635 result
= emacs_memftimeu (NULL
, (size_t) -1,
1636 SDATA (format_string
),
1637 SBYTES (format_string
),
1643 DEFUN ("decode-time", Fdecode_time
, Sdecode_time
, 0, 1, 0,
1644 doc
: /* Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST ZONE).
1645 The optional SPECIFIED-TIME should be a list of (HIGH LOW . IGNORED),
1646 as from `current-time' and `file-attributes', or `nil' to use the
1647 current time. The obsolete form (HIGH . LOW) is also still accepted.
1648 The list has the following nine members: SEC is an integer between 0
1649 and 60; SEC is 60 for a leap second, which only some operating systems
1650 support. MINUTE is an integer between 0 and 59. HOUR is an integer
1651 between 0 and 23. DAY is an integer between 1 and 31. MONTH is an
1652 integer between 1 and 12. YEAR is an integer indicating the
1653 four-digit year. DOW is the day of week, an integer between 0 and 6,
1654 where 0 is Sunday. DST is t if daylight savings time is effect,
1655 otherwise nil. ZONE is an integer indicating the number of seconds
1656 east of Greenwich. (Note that Common Lisp has different meanings for
1659 Lisp_Object specified_time
;
1663 struct tm
*decoded_time
;
1664 Lisp_Object list_args
[9];
1666 if (! lisp_time_argument (specified_time
, &time_spec
, NULL
))
1667 error ("Invalid time specification");
1669 decoded_time
= localtime (&time_spec
);
1671 error ("Specified time is not representable");
1672 XSETFASTINT (list_args
[0], decoded_time
->tm_sec
);
1673 XSETFASTINT (list_args
[1], decoded_time
->tm_min
);
1674 XSETFASTINT (list_args
[2], decoded_time
->tm_hour
);
1675 XSETFASTINT (list_args
[3], decoded_time
->tm_mday
);
1676 XSETFASTINT (list_args
[4], decoded_time
->tm_mon
+ 1);
1677 XSETINT (list_args
[5], decoded_time
->tm_year
+ 1900);
1678 XSETFASTINT (list_args
[6], decoded_time
->tm_wday
);
1679 list_args
[7] = (decoded_time
->tm_isdst
)? Qt
: Qnil
;
1681 /* Make a copy, in case gmtime modifies the struct. */
1682 save_tm
= *decoded_time
;
1683 decoded_time
= gmtime (&time_spec
);
1684 if (decoded_time
== 0)
1685 list_args
[8] = Qnil
;
1687 XSETINT (list_args
[8], tm_diff (&save_tm
, decoded_time
));
1688 return Flist (9, list_args
);
1691 DEFUN ("encode-time", Fencode_time
, Sencode_time
, 6, MANY
, 0,
1692 doc
: /* Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.
1693 This is the reverse operation of `decode-time', which see.
1694 ZONE defaults to the current time zone rule. This can
1695 be a string or t (as from `set-time-zone-rule'), or it can be a list
1696 \(as from `current-time-zone') or an integer (as from `decode-time')
1697 applied without consideration for daylight savings time.
1699 You can pass more than 7 arguments; then the first six arguments
1700 are used as SECOND through YEAR, and the *last* argument is used as ZONE.
1701 The intervening arguments are ignored.
1702 This feature lets (apply 'encode-time (decode-time ...)) work.
1704 Out-of-range values for SECOND, MINUTE, HOUR, DAY, or MONTH are allowed;
1705 for example, a DAY of 0 means the day preceding the given month.
1706 Year numbers less than 100 are treated just like other year numbers.
1707 If you want them to stand for years in this century, you must do that yourself.
1709 Years before 1970 are not guaranteed to work. On some systems,
1710 year values as low as 1901 do work.
1712 usage: (encode-time SECOND MINUTE HOUR DAY MONTH YEAR &optional ZONE) */)
1715 register Lisp_Object
*args
;
1719 Lisp_Object zone
= (nargs
> 6 ? args
[nargs
- 1] : Qnil
);
1721 CHECK_NUMBER (args
[0]); /* second */
1722 CHECK_NUMBER (args
[1]); /* minute */
1723 CHECK_NUMBER (args
[2]); /* hour */
1724 CHECK_NUMBER (args
[3]); /* day */
1725 CHECK_NUMBER (args
[4]); /* month */
1726 CHECK_NUMBER (args
[5]); /* year */
1728 tm
.tm_sec
= XINT (args
[0]);
1729 tm
.tm_min
= XINT (args
[1]);
1730 tm
.tm_hour
= XINT (args
[2]);
1731 tm
.tm_mday
= XINT (args
[3]);
1732 tm
.tm_mon
= XINT (args
[4]) - 1;
1733 tm
.tm_year
= XINT (args
[5]) - 1900;
1739 time
= mktime (&tm
);
1744 char **oldenv
= environ
, **newenv
;
1748 else if (STRINGP (zone
))
1749 tzstring
= (char *) SDATA (zone
);
1750 else if (INTEGERP (zone
))
1752 int abszone
= abs (XINT (zone
));
1753 sprintf (tzbuf
, "XXX%s%d:%02d:%02d", "-" + (XINT (zone
) < 0),
1754 abszone
/ (60*60), (abszone
/60) % 60, abszone
% 60);
1758 error ("Invalid time zone specification");
1760 /* Set TZ before calling mktime; merely adjusting mktime's returned
1761 value doesn't suffice, since that would mishandle leap seconds. */
1762 set_time_zone_rule (tzstring
);
1764 time
= mktime (&tm
);
1766 /* Restore TZ to previous value. */
1770 #ifdef LOCALTIME_CACHE
1775 if (time
== (time_t) -1)
1776 error ("Specified time is not representable");
1778 return make_time (time
);
1781 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
, 0, 1, 0,
1782 doc
: /* Return the current time, as a human-readable string.
1783 Programs can use this function to decode a time,
1784 since the number of columns in each field is fixed.
1785 The format is `Sun Sep 16 01:03:52 1973'.
1786 However, see also the functions `decode-time' and `format-time-string'
1787 which provide a much more powerful and general facility.
1789 If SPECIFIED-TIME is given, it is a time to format instead of the
1790 current time. The argument should have the form (HIGH LOW . IGNORED).
1791 Thus, you can use times obtained from `current-time' and from
1792 `file-attributes'. SPECIFIED-TIME can also have the form (HIGH . LOW),
1793 but this is considered obsolete. */)
1795 Lisp_Object specified_time
;
1801 if (! lisp_time_argument (specified_time
, &value
, NULL
))
1803 tem
= (char *) ctime (&value
);
1805 strncpy (buf
, tem
, 24);
1808 return build_string (buf
);
1811 #define TM_YEAR_BASE 1900
1813 /* Yield A - B, measured in seconds.
1814 This function is copied from the GNU C Library. */
1819 /* Compute intervening leap days correctly even if year is negative.
1820 Take care to avoid int overflow in leap day calculations,
1821 but it's OK to assume that A and B are close to each other. */
1822 int a4
= (a
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (a
->tm_year
& 3);
1823 int b4
= (b
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (b
->tm_year
& 3);
1824 int a100
= a4
/ 25 - (a4
% 25 < 0);
1825 int b100
= b4
/ 25 - (b4
% 25 < 0);
1826 int a400
= a100
>> 2;
1827 int b400
= b100
>> 2;
1828 int intervening_leap_days
= (a4
- b4
) - (a100
- b100
) + (a400
- b400
);
1829 int years
= a
->tm_year
- b
->tm_year
;
1830 int days
= (365 * years
+ intervening_leap_days
1831 + (a
->tm_yday
- b
->tm_yday
));
1832 return (60 * (60 * (24 * days
+ (a
->tm_hour
- b
->tm_hour
))
1833 + (a
->tm_min
- b
->tm_min
))
1834 + (a
->tm_sec
- b
->tm_sec
));
1837 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 1, 0,
1838 doc
: /* Return the offset and name for the local time zone.
1839 This returns a list of the form (OFFSET NAME).
1840 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).
1841 A negative value means west of Greenwich.
1842 NAME is a string giving the name of the time zone.
1843 If SPECIFIED-TIME is given, the time zone offset is determined from it
1844 instead of using the current time. The argument should have the form
1845 (HIGH LOW . IGNORED). Thus, you can use times obtained from
1846 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
1847 have the form (HIGH . LOW), but this is considered obsolete.
1849 Some operating systems cannot provide all this information to Emacs;
1850 in this case, `current-time-zone' returns a list containing nil for
1851 the data it can't find. */)
1853 Lisp_Object specified_time
;
1859 if (lisp_time_argument (specified_time
, &value
, NULL
)
1860 && (t
= gmtime (&value
)) != 0
1861 && (gmt
= *t
, t
= localtime (&value
)) != 0)
1863 int offset
= tm_diff (t
, &gmt
);
1868 s
= (char *)t
->tm_zone
;
1869 #else /* not HAVE_TM_ZONE */
1871 if (t
->tm_isdst
== 0 || t
->tm_isdst
== 1)
1872 s
= tzname
[t
->tm_isdst
];
1874 #endif /* not HAVE_TM_ZONE */
1876 #if defined HAVE_TM_ZONE || defined HAVE_TZNAME
1879 /* On Japanese w32, we can get a Japanese string as time
1880 zone name. Don't accept that. */
1882 for (p
= s
; *p
&& (isalnum ((unsigned char)*p
) || *p
== ' '); ++p
)
1891 /* No local time zone name is available; use "+-NNNN" instead. */
1892 int am
= (offset
< 0 ? -offset
: offset
) / 60;
1893 sprintf (buf
, "%c%02d%02d", (offset
< 0 ? '-' : '+'), am
/60, am
%60);
1896 return Fcons (make_number (offset
), Fcons (build_string (s
), Qnil
));
1899 return Fmake_list (make_number (2), Qnil
);
1902 /* This holds the value of `environ' produced by the previous
1903 call to Fset_time_zone_rule, or 0 if Fset_time_zone_rule
1904 has never been called. */
1905 static char **environbuf
;
1907 DEFUN ("set-time-zone-rule", Fset_time_zone_rule
, Sset_time_zone_rule
, 1, 1, 0,
1908 doc
: /* Set the local time zone using TZ, a string specifying a time zone rule.
1909 If TZ is nil, use implementation-defined default time zone information.
1910 If TZ is t, use Universal Time. */)
1918 else if (EQ (tz
, Qt
))
1923 tzstring
= (char *) SDATA (tz
);
1926 set_time_zone_rule (tzstring
);
1929 environbuf
= environ
;
1934 #ifdef LOCALTIME_CACHE
1936 /* These two values are known to load tz files in buggy implementations,
1937 i.e. Solaris 1 executables running under either Solaris 1 or Solaris 2.
1938 Their values shouldn't matter in non-buggy implementations.
1939 We don't use string literals for these strings,
1940 since if a string in the environment is in readonly
1941 storage, it runs afoul of bugs in SVR4 and Solaris 2.3.
1942 See Sun bugs 1113095 and 1114114, ``Timezone routines
1943 improperly modify environment''. */
1945 static char set_time_zone_rule_tz1
[] = "TZ=GMT+0";
1946 static char set_time_zone_rule_tz2
[] = "TZ=GMT+1";
1950 /* Set the local time zone rule to TZSTRING.
1951 This allocates memory into `environ', which it is the caller's
1952 responsibility to free. */
1955 set_time_zone_rule (tzstring
)
1959 char **from
, **to
, **newenv
;
1961 /* Make the ENVIRON vector longer with room for TZSTRING. */
1962 for (from
= environ
; *from
; from
++)
1964 envptrs
= from
- environ
+ 2;
1965 newenv
= to
= (char **) xmalloc (envptrs
* sizeof (char *)
1966 + (tzstring
? strlen (tzstring
) + 4 : 0));
1968 /* Add TZSTRING to the end of environ, as a value for TZ. */
1971 char *t
= (char *) (to
+ envptrs
);
1973 strcat (t
, tzstring
);
1977 /* Copy the old environ vector elements into NEWENV,
1978 but don't copy the TZ variable.
1979 So we have only one definition of TZ, which came from TZSTRING. */
1980 for (from
= environ
; *from
; from
++)
1981 if (strncmp (*from
, "TZ=", 3) != 0)
1987 /* If we do have a TZSTRING, NEWENV points to the vector slot where
1988 the TZ variable is stored. If we do not have a TZSTRING,
1989 TO points to the vector slot which has the terminating null. */
1991 #ifdef LOCALTIME_CACHE
1993 /* In SunOS 4.1.3_U1 and 4.1.4, if TZ has a value like
1994 "US/Pacific" that loads a tz file, then changes to a value like
1995 "XXX0" that does not load a tz file, and then changes back to
1996 its original value, the last change is (incorrectly) ignored.
1997 Also, if TZ changes twice in succession to values that do
1998 not load a tz file, tzset can dump core (see Sun bug#1225179).
1999 The following code works around these bugs. */
2003 /* Temporarily set TZ to a value that loads a tz file
2004 and that differs from tzstring. */
2006 *newenv
= (strcmp (tzstring
, set_time_zone_rule_tz1
+ 3) == 0
2007 ? set_time_zone_rule_tz2
: set_time_zone_rule_tz1
);
2013 /* The implied tzstring is unknown, so temporarily set TZ to
2014 two different values that each load a tz file. */
2015 *to
= set_time_zone_rule_tz1
;
2018 *to
= set_time_zone_rule_tz2
;
2023 /* Now TZ has the desired value, and tzset can be invoked safely. */
2030 /* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC
2031 (if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a
2032 type of object is Lisp_String). INHERIT is passed to
2033 INSERT_FROM_STRING_FUNC as the last argument. */
2036 general_insert_function (insert_func
, insert_from_string_func
,
2037 inherit
, nargs
, args
)
2038 void (*insert_func
) P_ ((const unsigned char *, int));
2039 void (*insert_from_string_func
) P_ ((Lisp_Object
, int, int, int, int, int));
2041 register Lisp_Object
*args
;
2043 register int argnum
;
2044 register Lisp_Object val
;
2046 for (argnum
= 0; argnum
< nargs
; argnum
++)
2052 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2055 if (!NILP (current_buffer
->enable_multibyte_characters
))
2056 len
= CHAR_STRING (XFASTINT (val
), str
);
2059 str
[0] = (ASCII_CHAR_P (XINT (val
))
2061 : multibyte_char_to_unibyte (XINT (val
), Qnil
));
2064 (*insert_func
) (str
, len
);
2066 else if (STRINGP (val
))
2068 (*insert_from_string_func
) (val
, 0, 0,
2075 val
= wrong_type_argument (Qchar_or_string_p
, val
);
2089 /* Callers passing one argument to Finsert need not gcpro the
2090 argument "array", since the only element of the array will
2091 not be used after calling insert or insert_from_string, so
2092 we don't care if it gets trashed. */
2094 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
2095 doc
: /* Insert the arguments, either strings or characters, at point.
2096 Point and before-insertion markers move forward to end up
2097 after the inserted text.
2098 Any other markers at the point of insertion remain before the text.
2100 If the current buffer is multibyte, unibyte strings are converted
2101 to multibyte for insertion (see `string-make-multibyte').
2102 If the current buffer is unibyte, multibyte strings are converted
2103 to unibyte for insertion (see `string-make-unibyte').
2105 When operating on binary data, it may be necessary to preserve the
2106 original bytes of a unibyte string when inserting it into a multibyte
2107 buffer; to accomplish this, apply `string-as-multibyte' to the string
2108 and insert the result.
2110 usage: (insert &rest ARGS) */)
2113 register Lisp_Object
*args
;
2115 general_insert_function (insert
, insert_from_string
, 0, nargs
, args
);
2119 DEFUN ("insert-and-inherit", Finsert_and_inherit
, Sinsert_and_inherit
,
2121 doc
: /* Insert the arguments at point, inheriting properties from adjoining text.
2122 Point and before-insertion markers move forward to end up
2123 after the inserted text.
2124 Any other markers at the point of insertion remain before the text.
2126 If the current buffer is multibyte, unibyte strings are converted
2127 to multibyte for insertion (see `unibyte-char-to-multibyte').
2128 If the current buffer is unibyte, multibyte strings are converted
2129 to unibyte for insertion.
2131 usage: (insert-and-inherit &rest ARGS) */)
2134 register Lisp_Object
*args
;
2136 general_insert_function (insert_and_inherit
, insert_from_string
, 1,
2141 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
2142 doc
: /* Insert strings or characters at point, relocating markers after the text.
2143 Point and markers move forward to end up after the inserted text.
2145 If the current buffer is multibyte, unibyte strings are converted
2146 to multibyte for insertion (see `unibyte-char-to-multibyte').
2147 If the current buffer is unibyte, multibyte strings are converted
2148 to unibyte for insertion.
2150 usage: (insert-before-markers &rest ARGS) */)
2153 register Lisp_Object
*args
;
2155 general_insert_function (insert_before_markers
,
2156 insert_from_string_before_markers
, 0,
2161 DEFUN ("insert-before-markers-and-inherit", Finsert_and_inherit_before_markers
,
2162 Sinsert_and_inherit_before_markers
, 0, MANY
, 0,
2163 doc
: /* Insert text at point, relocating markers and inheriting properties.
2164 Point and markers move forward to end up after the inserted text.
2166 If the current buffer is multibyte, unibyte strings are converted
2167 to multibyte for insertion (see `unibyte-char-to-multibyte').
2168 If the current buffer is unibyte, multibyte strings are converted
2169 to unibyte for insertion.
2171 usage: (insert-before-markers-and-inherit &rest ARGS) */)
2174 register Lisp_Object
*args
;
2176 general_insert_function (insert_before_markers_and_inherit
,
2177 insert_from_string_before_markers
, 1,
2182 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 2, 3, 0,
2183 doc
: /* Insert COUNT (second arg) copies of CHARACTER (first arg).
2184 Both arguments are required.
2185 Point, and before-insertion markers, are relocated as in the function `insert'.
2186 The optional third arg INHERIT, if non-nil, says to inherit text properties
2187 from adjoining text, if those properties are sticky. */)
2188 (character
, count
, inherit
)
2189 Lisp_Object character
, count
, inherit
;
2191 register unsigned char *string
;
2192 register int strlen
;
2195 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2197 CHECK_NUMBER (character
);
2198 CHECK_NUMBER (count
);
2200 if (!NILP (current_buffer
->enable_multibyte_characters
))
2201 len
= CHAR_STRING (XFASTINT (character
), str
);
2203 str
[0] = XFASTINT (character
), len
= 1;
2204 n
= XINT (count
) * len
;
2207 strlen
= min (n
, 256 * len
);
2208 string
= (unsigned char *) alloca (strlen
);
2209 for (i
= 0; i
< strlen
; i
++)
2210 string
[i
] = str
[i
% len
];
2214 if (!NILP (inherit
))
2215 insert_and_inherit (string
, strlen
);
2217 insert (string
, strlen
);
2222 if (!NILP (inherit
))
2223 insert_and_inherit (string
, n
);
2230 DEFUN ("insert-byte", Finsert_byte
, Sinsert_byte
, 2, 3, 0,
2231 doc
: /* Insert COUNT (second arg) copies of BYTE (first arg).
2232 Both arguments are required.
2233 BYTE is a number of the range 0..255.
2235 If BYTE is 128..255 and the current buffer is multibyte, the
2236 corresponding eight-bit character is inserted.
2238 Point, and before-insertion markers, are relocated as in the function `insert'.
2239 The optional third arg INHERIT, if non-nil, says to inherit text properties
2240 from adjoining text, if those properties are sticky. */)
2241 (byte
, count
, inherit
)
2242 Lisp_Object byte
, count
, inherit
;
2244 CHECK_NUMBER (byte
);
2245 if (XINT (byte
) < 0 || XINT (byte
) > 255)
2246 args_out_of_range_3 (byte
, make_number (0), make_number (255));
2247 if (XINT (byte
) >= 128
2248 && ! NILP (current_buffer
->enable_multibyte_characters
))
2249 XSETFASTINT (byte
, BYTE8_TO_CHAR (XINT (byte
)));
2250 return Finsert_char (byte
, count
, inherit
);
2254 /* Making strings from buffer contents. */
2256 /* Return a Lisp_String containing the text of the current buffer from
2257 START to END. If text properties are in use and the current buffer
2258 has properties in the range specified, the resulting string will also
2259 have them, if PROPS is nonzero.
2261 We don't want to use plain old make_string here, because it calls
2262 make_uninit_string, which can cause the buffer arena to be
2263 compacted. make_string has no way of knowing that the data has
2264 been moved, and thus copies the wrong data into the string. This
2265 doesn't effect most of the other users of make_string, so it should
2266 be left as is. But we should use this function when conjuring
2267 buffer substrings. */
2270 make_buffer_string (start
, end
, props
)
2274 int start_byte
= CHAR_TO_BYTE (start
);
2275 int end_byte
= CHAR_TO_BYTE (end
);
2277 return make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
);
2280 /* Return a Lisp_String containing the text of the current buffer from
2281 START / START_BYTE to END / END_BYTE.
2283 If text properties are in use and the current buffer
2284 has properties in the range specified, the resulting string will also
2285 have them, if PROPS is nonzero.
2287 We don't want to use plain old make_string here, because it calls
2288 make_uninit_string, which can cause the buffer arena to be
2289 compacted. make_string has no way of knowing that the data has
2290 been moved, and thus copies the wrong data into the string. This
2291 doesn't effect most of the other users of make_string, so it should
2292 be left as is. But we should use this function when conjuring
2293 buffer substrings. */
2296 make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
)
2297 int start
, start_byte
, end
, end_byte
;
2300 Lisp_Object result
, tem
, tem1
;
2302 if (start
< GPT
&& GPT
< end
)
2305 if (! NILP (current_buffer
->enable_multibyte_characters
))
2306 result
= make_uninit_multibyte_string (end
- start
, end_byte
- start_byte
);
2308 result
= make_uninit_string (end
- start
);
2309 bcopy (BYTE_POS_ADDR (start_byte
), SDATA (result
),
2310 end_byte
- start_byte
);
2312 /* If desired, update and copy the text properties. */
2315 update_buffer_properties (start
, end
);
2317 tem
= Fnext_property_change (make_number (start
), Qnil
, make_number (end
));
2318 tem1
= Ftext_properties_at (make_number (start
), Qnil
);
2320 if (XINT (tem
) != end
|| !NILP (tem1
))
2321 copy_intervals_to_string (result
, current_buffer
, start
,
2328 /* Call Vbuffer_access_fontify_functions for the range START ... END
2329 in the current buffer, if necessary. */
2332 update_buffer_properties (start
, end
)
2335 /* If this buffer has some access functions,
2336 call them, specifying the range of the buffer being accessed. */
2337 if (!NILP (Vbuffer_access_fontify_functions
))
2339 Lisp_Object args
[3];
2342 args
[0] = Qbuffer_access_fontify_functions
;
2343 XSETINT (args
[1], start
);
2344 XSETINT (args
[2], end
);
2346 /* But don't call them if we can tell that the work
2347 has already been done. */
2348 if (!NILP (Vbuffer_access_fontified_property
))
2350 tem
= Ftext_property_any (args
[1], args
[2],
2351 Vbuffer_access_fontified_property
,
2354 Frun_hook_with_args (3, args
);
2357 Frun_hook_with_args (3, args
);
2361 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
2362 doc
: /* Return the contents of part of the current buffer as a string.
2363 The two arguments START and END are character positions;
2364 they can be in either order.
2365 The string returned is multibyte if the buffer is multibyte.
2367 This function copies the text properties of that part of the buffer
2368 into the result string; if you don't want the text properties,
2369 use `buffer-substring-no-properties' instead. */)
2371 Lisp_Object start
, end
;
2375 validate_region (&start
, &end
);
2379 return make_buffer_string (b
, e
, 1);
2382 DEFUN ("buffer-substring-no-properties", Fbuffer_substring_no_properties
,
2383 Sbuffer_substring_no_properties
, 2, 2, 0,
2384 doc
: /* Return the characters of part of the buffer, without the text properties.
2385 The two arguments START and END are character positions;
2386 they can be in either order. */)
2388 Lisp_Object start
, end
;
2392 validate_region (&start
, &end
);
2396 return make_buffer_string (b
, e
, 0);
2399 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
2400 doc
: /* Return the contents of the current buffer as a string.
2401 If narrowing is in effect, this function returns only the visible part
2405 return make_buffer_string (BEGV
, ZV
, 1);
2408 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
2410 doc
: /* Insert before point a substring of the contents of BUFFER.
2411 BUFFER may be a buffer or a buffer name.
2412 Arguments START and END are character positions specifying the substring.
2413 They default to the values of (point-min) and (point-max) in BUFFER. */)
2414 (buffer
, start
, end
)
2415 Lisp_Object buffer
, start
, end
;
2417 register int b
, e
, temp
;
2418 register struct buffer
*bp
, *obuf
;
2421 buf
= Fget_buffer (buffer
);
2425 if (NILP (bp
->name
))
2426 error ("Selecting deleted buffer");
2432 CHECK_NUMBER_COERCE_MARKER (start
);
2439 CHECK_NUMBER_COERCE_MARKER (end
);
2444 temp
= b
, b
= e
, e
= temp
;
2446 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
2447 args_out_of_range (start
, end
);
2449 obuf
= current_buffer
;
2450 set_buffer_internal_1 (bp
);
2451 update_buffer_properties (b
, e
);
2452 set_buffer_internal_1 (obuf
);
2454 insert_from_buffer (bp
, b
, e
- b
, 0);
2458 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
2460 doc
: /* Compare two substrings of two buffers; return result as number.
2461 the value is -N if first string is less after N-1 chars,
2462 +N if first string is greater after N-1 chars, or 0 if strings match.
2463 Each substring is represented as three arguments: BUFFER, START and END.
2464 That makes six args in all, three for each substring.
2466 The value of `case-fold-search' in the current buffer
2467 determines whether case is significant or ignored. */)
2468 (buffer1
, start1
, end1
, buffer2
, start2
, end2
)
2469 Lisp_Object buffer1
, start1
, end1
, buffer2
, start2
, end2
;
2471 register int begp1
, endp1
, begp2
, endp2
, temp
;
2472 register struct buffer
*bp1
, *bp2
;
2473 register Lisp_Object
*trt
2474 = (!NILP (current_buffer
->case_fold_search
)
2475 ? XCHAR_TABLE (current_buffer
->case_canon_table
)->contents
: 0);
2477 int i1
, i2
, i1_byte
, i2_byte
;
2479 /* Find the first buffer and its substring. */
2482 bp1
= current_buffer
;
2486 buf1
= Fget_buffer (buffer1
);
2489 bp1
= XBUFFER (buf1
);
2490 if (NILP (bp1
->name
))
2491 error ("Selecting deleted buffer");
2495 begp1
= BUF_BEGV (bp1
);
2498 CHECK_NUMBER_COERCE_MARKER (start1
);
2499 begp1
= XINT (start1
);
2502 endp1
= BUF_ZV (bp1
);
2505 CHECK_NUMBER_COERCE_MARKER (end1
);
2506 endp1
= XINT (end1
);
2510 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
2512 if (!(BUF_BEGV (bp1
) <= begp1
2514 && endp1
<= BUF_ZV (bp1
)))
2515 args_out_of_range (start1
, end1
);
2517 /* Likewise for second substring. */
2520 bp2
= current_buffer
;
2524 buf2
= Fget_buffer (buffer2
);
2527 bp2
= XBUFFER (buf2
);
2528 if (NILP (bp2
->name
))
2529 error ("Selecting deleted buffer");
2533 begp2
= BUF_BEGV (bp2
);
2536 CHECK_NUMBER_COERCE_MARKER (start2
);
2537 begp2
= XINT (start2
);
2540 endp2
= BUF_ZV (bp2
);
2543 CHECK_NUMBER_COERCE_MARKER (end2
);
2544 endp2
= XINT (end2
);
2548 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
2550 if (!(BUF_BEGV (bp2
) <= begp2
2552 && endp2
<= BUF_ZV (bp2
)))
2553 args_out_of_range (start2
, end2
);
2557 i1_byte
= buf_charpos_to_bytepos (bp1
, i1
);
2558 i2_byte
= buf_charpos_to_bytepos (bp2
, i2
);
2560 while (i1
< endp1
&& i2
< endp2
)
2562 /* When we find a mismatch, we must compare the
2563 characters, not just the bytes. */
2568 if (! NILP (bp1
->enable_multibyte_characters
))
2570 c1
= BUF_FETCH_MULTIBYTE_CHAR (bp1
, i1_byte
);
2571 BUF_INC_POS (bp1
, i1_byte
);
2576 c1
= BUF_FETCH_BYTE (bp1
, i1
);
2577 c1
= unibyte_char_to_multibyte (c1
);
2581 if (! NILP (bp2
->enable_multibyte_characters
))
2583 c2
= BUF_FETCH_MULTIBYTE_CHAR (bp2
, i2_byte
);
2584 BUF_INC_POS (bp2
, i2_byte
);
2589 c2
= BUF_FETCH_BYTE (bp2
, i2
);
2590 c2
= unibyte_char_to_multibyte (c2
);
2596 c1
= XINT (trt
[c1
]);
2597 c2
= XINT (trt
[c2
]);
2600 return make_number (- 1 - chars
);
2602 return make_number (chars
+ 1);
2607 /* The strings match as far as they go.
2608 If one is shorter, that one is less. */
2609 if (chars
< endp1
- begp1
)
2610 return make_number (chars
+ 1);
2611 else if (chars
< endp2
- begp2
)
2612 return make_number (- chars
- 1);
2614 /* Same length too => they are equal. */
2615 return make_number (0);
2619 subst_char_in_region_unwind (arg
)
2622 return current_buffer
->undo_list
= arg
;
2626 subst_char_in_region_unwind_1 (arg
)
2629 return current_buffer
->filename
= arg
;
2632 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
2633 Ssubst_char_in_region
, 4, 5, 0,
2634 doc
: /* From START to END, replace FROMCHAR with TOCHAR each time it occurs.
2635 If optional arg NOUNDO is non-nil, don't record this change for undo
2636 and don't mark the buffer as really changed.
2637 Both characters must have the same length of multi-byte form. */)
2638 (start
, end
, fromchar
, tochar
, noundo
)
2639 Lisp_Object start
, end
, fromchar
, tochar
, noundo
;
2641 register int pos
, pos_byte
, stop
, i
, len
, end_byte
;
2643 unsigned char fromstr
[MAX_MULTIBYTE_LENGTH
], tostr
[MAX_MULTIBYTE_LENGTH
];
2645 int count
= SPECPDL_INDEX ();
2646 #define COMBINING_NO 0
2647 #define COMBINING_BEFORE 1
2648 #define COMBINING_AFTER 2
2649 #define COMBINING_BOTH (COMBINING_BEFORE | COMBINING_AFTER)
2650 int maybe_byte_combining
= COMBINING_NO
;
2651 int last_changed
= 0;
2652 int multibyte_p
= !NILP (current_buffer
->enable_multibyte_characters
);
2654 validate_region (&start
, &end
);
2655 CHECK_NUMBER (fromchar
);
2656 CHECK_NUMBER (tochar
);
2660 len
= CHAR_STRING (XFASTINT (fromchar
), fromstr
);
2661 if (CHAR_STRING (XFASTINT (tochar
), tostr
) != len
)
2662 error ("Characters in subst-char-in-region have different byte-lengths");
2663 if (!ASCII_BYTE_P (*tostr
))
2665 /* If *TOSTR is in the range 0x80..0x9F and TOCHAR is not a
2666 complete multibyte character, it may be combined with the
2667 after bytes. If it is in the range 0xA0..0xFF, it may be
2668 combined with the before and after bytes. */
2669 if (!CHAR_HEAD_P (*tostr
))
2670 maybe_byte_combining
= COMBINING_BOTH
;
2671 else if (BYTES_BY_CHAR_HEAD (*tostr
) > len
)
2672 maybe_byte_combining
= COMBINING_AFTER
;
2678 fromstr
[0] = XFASTINT (fromchar
);
2679 tostr
[0] = XFASTINT (tochar
);
2683 pos_byte
= CHAR_TO_BYTE (pos
);
2684 stop
= CHAR_TO_BYTE (XINT (end
));
2687 /* If we don't want undo, turn off putting stuff on the list.
2688 That's faster than getting rid of things,
2689 and it prevents even the entry for a first change.
2690 Also inhibit locking the file. */
2693 record_unwind_protect (subst_char_in_region_unwind
,
2694 current_buffer
->undo_list
);
2695 current_buffer
->undo_list
= Qt
;
2696 /* Don't do file-locking. */
2697 record_unwind_protect (subst_char_in_region_unwind_1
,
2698 current_buffer
->filename
);
2699 current_buffer
->filename
= Qnil
;
2702 if (pos_byte
< GPT_BYTE
)
2703 stop
= min (stop
, GPT_BYTE
);
2706 int pos_byte_next
= pos_byte
;
2708 if (pos_byte
>= stop
)
2710 if (pos_byte
>= end_byte
) break;
2713 p
= BYTE_POS_ADDR (pos_byte
);
2715 INC_POS (pos_byte_next
);
2718 if (pos_byte_next
- pos_byte
== len
2719 && p
[0] == fromstr
[0]
2721 || (p
[1] == fromstr
[1]
2722 && (len
== 2 || (p
[2] == fromstr
[2]
2723 && (len
== 3 || p
[3] == fromstr
[3]))))))
2728 modify_region (current_buffer
, changed
, XINT (end
));
2730 if (! NILP (noundo
))
2732 if (MODIFF
- 1 == SAVE_MODIFF
)
2734 if (MODIFF
- 1 == current_buffer
->auto_save_modified
)
2735 current_buffer
->auto_save_modified
++;
2739 /* Take care of the case where the new character
2740 combines with neighboring bytes. */
2741 if (maybe_byte_combining
2742 && (maybe_byte_combining
== COMBINING_AFTER
2743 ? (pos_byte_next
< Z_BYTE
2744 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2745 : ((pos_byte_next
< Z_BYTE
2746 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2747 || (pos_byte
> BEG_BYTE
2748 && ! ASCII_BYTE_P (FETCH_BYTE (pos_byte
- 1))))))
2750 Lisp_Object tem
, string
;
2752 struct gcpro gcpro1
;
2754 tem
= current_buffer
->undo_list
;
2757 /* Make a multibyte string containing this single character. */
2758 string
= make_multibyte_string (tostr
, 1, len
);
2759 /* replace_range is less efficient, because it moves the gap,
2760 but it handles combining correctly. */
2761 replace_range (pos
, pos
+ 1, string
,
2763 pos_byte_next
= CHAR_TO_BYTE (pos
);
2764 if (pos_byte_next
> pos_byte
)
2765 /* Before combining happened. We should not increment
2766 POS. So, to cancel the later increment of POS,
2770 INC_POS (pos_byte_next
);
2772 if (! NILP (noundo
))
2773 current_buffer
->undo_list
= tem
;
2780 record_change (pos
, 1);
2781 for (i
= 0; i
< len
; i
++) *p
++ = tostr
[i
];
2783 last_changed
= pos
+ 1;
2785 pos_byte
= pos_byte_next
;
2791 signal_after_change (changed
,
2792 last_changed
- changed
, last_changed
- changed
);
2793 update_compositions (changed
, last_changed
, CHECK_ALL
);
2796 unbind_to (count
, Qnil
);
2801 static Lisp_Object check_translation
P_ ((int, int, int, Lisp_Object
));
2803 /* Helper function for Ftranslate_region_internal.
2805 Check if a character sequence at POS (POS_BYTE) matches an element
2806 of VAL. VAL is a list (([FROM-CHAR ...] . TO) ...). If a matching
2807 element is found, return it. Otherwise return Qnil. */
2810 check_translation (pos
, pos_byte
, end
, val
)
2811 int pos
, pos_byte
, end
;
2814 int buf_size
= 16, buf_used
= 0;
2815 int *buf
= alloca (sizeof (int) * buf_size
);
2817 for (; CONSP (val
); val
= XCDR (val
))
2826 if (! VECTORP (elt
))
2829 if (len
<= end
- pos
)
2831 for (i
= 0; i
< len
; i
++)
2835 unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
2838 if (buf_used
== buf_size
)
2843 newbuf
= alloca (sizeof (int) * buf_size
);
2844 memcpy (newbuf
, buf
, sizeof (int) * buf_used
);
2847 buf
[buf_used
++] = STRING_CHAR_AND_LENGTH (p
, 0, len
);
2850 if (XINT (AREF (elt
, i
)) != buf
[i
])
2861 DEFUN ("translate-region-internal", Ftranslate_region_internal
,
2862 Stranslate_region_internal
, 3, 3, 0,
2863 doc
: /* Internal use only.
2864 From START to END, translate characters according to TABLE.
2865 TABLE is a string or a char-table; the Nth character in it is the
2866 mapping for the character with code N.
2867 It returns the number of characters changed. */)
2871 register Lisp_Object table
;
2873 register unsigned char *tt
; /* Trans table. */
2874 register int nc
; /* New character. */
2875 int cnt
; /* Number of changes made. */
2876 int size
; /* Size of translate table. */
2877 int pos
, pos_byte
, end_pos
;
2878 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
2879 int string_multibyte
;
2882 validate_region (&start
, &end
);
2883 if (CHAR_TABLE_P (table
))
2885 if (! EQ (XCHAR_TABLE (table
)->purpose
, Qtranslation_table
))
2886 error ("Not a translation table");
2891 CHECK_STRING (table
);
2893 if (multibyte
!= (SCHARS (table
) < SBYTES (table
)))
2895 ? string_make_multibyte (table
)
2896 : string_make_unibyte (table
));
2897 string_multibyte
= SCHARS (table
) < SBYTES (table
);
2898 size
= SBYTES (table
);
2903 pos_byte
= CHAR_TO_BYTE (pos
);
2904 end_pos
= XINT (end
);
2905 modify_region (current_buffer
, pos
, end_pos
);
2908 for (; pos
< end_pos
; )
2910 register unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
2911 unsigned char *str
, buf
[MAX_MULTIBYTE_LENGTH
];
2917 nc
= oc
= STRING_CHAR_AND_LENGTH (p
, 0, len
);
2919 nc
= oc
= *p
, len
= 1;
2924 if (string_multibyte
)
2926 str
= tt
+ string_char_to_byte (table
, oc
);
2927 nc
= STRING_CHAR_AND_LENGTH (str
, 0, str_len
);
2932 nc
= tt
[oc
], str_len
= 1;
2938 val
= CHAR_TABLE_REF (table
, oc
);
2939 if (CHARACTERP (val
))
2941 nc
= XFASTINT (val
);
2942 str_len
= CHAR_STRING (nc
, buf
);
2945 else if (VECTORP (val
) || (CONSP (val
)))
2947 /* VAL is [TO_CHAR ...] or (([FROM-CHAR ...] . TO) ...)
2948 where TO is TO-CHAR or [TO-CHAR ...]. */
2957 /* Simple one char to one char translation. */
2962 /* This is less efficient, because it moves the gap,
2963 but it should handle multibyte characters correctly. */
2964 string
= make_multibyte_string (str
, 1, str_len
);
2965 replace_range (pos
, pos
+ 1, string
, 1, 0, 1);
2970 record_change (pos
, 1);
2971 while (str_len
-- > 0)
2973 signal_after_change (pos
, 1, 1);
2974 update_compositions (pos
, pos
+ 1, CHECK_BORDER
);
2984 val
= check_translation (pos
, pos_byte
, end_pos
, val
);
2991 /* VAL is ([FROM-CHAR ...] . TO). */
2992 len
= ASIZE (XCAR (val
));
3002 string
= Fmake_string (make_number (ASIZE (val
)),
3004 for (i
= 1; i
< ASIZE (val
); i
++)
3005 Faset (string
, make_number (i
), AREF (val
, i
));
3009 string
= Fmake_string (make_number (1), val
);
3011 replace_range (pos
, pos
+ len
, string
, 1, 0, 1);
3012 pos_byte
+= SBYTES (string
);
3013 pos
+= SCHARS (string
);
3014 cnt
+= SCHARS (string
);
3015 end_pos
+= SCHARS (string
) - len
;
3023 return make_number (cnt
);
3026 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
3027 doc
: /* Delete the text between point and mark.
3029 When called from a program, expects two arguments,
3030 positions (integers or markers) specifying the stretch to be deleted. */)
3032 Lisp_Object start
, end
;
3034 validate_region (&start
, &end
);
3035 del_range (XINT (start
), XINT (end
));
3039 DEFUN ("delete-and-extract-region", Fdelete_and_extract_region
,
3040 Sdelete_and_extract_region
, 2, 2, 0,
3041 doc
: /* Delete the text between START and END and return it. */)
3043 Lisp_Object start
, end
;
3045 validate_region (&start
, &end
);
3046 if (XINT (start
) == XINT (end
))
3047 return build_string ("");
3048 return del_range_1 (XINT (start
), XINT (end
), 1, 1);
3051 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
3052 doc
: /* Remove restrictions (narrowing) from current buffer.
3053 This allows the buffer's full text to be seen and edited. */)
3056 if (BEG
!= BEGV
|| Z
!= ZV
)
3057 current_buffer
->clip_changed
= 1;
3059 BEGV_BYTE
= BEG_BYTE
;
3060 SET_BUF_ZV_BOTH (current_buffer
, Z
, Z_BYTE
);
3061 /* Changing the buffer bounds invalidates any recorded current column. */
3062 invalidate_current_column ();
3066 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
3067 doc
: /* Restrict editing in this buffer to the current region.
3068 The rest of the text becomes temporarily invisible and untouchable
3069 but is not deleted; if you save the buffer in a file, the invisible
3070 text is included in the file. \\[widen] makes all visible again.
3071 See also `save-restriction'.
3073 When calling from a program, pass two arguments; positions (integers
3074 or markers) bounding the text that should remain visible. */)
3076 register Lisp_Object start
, end
;
3078 CHECK_NUMBER_COERCE_MARKER (start
);
3079 CHECK_NUMBER_COERCE_MARKER (end
);
3081 if (XINT (start
) > XINT (end
))
3084 tem
= start
; start
= end
; end
= tem
;
3087 if (!(BEG
<= XINT (start
) && XINT (start
) <= XINT (end
) && XINT (end
) <= Z
))
3088 args_out_of_range (start
, end
);
3090 if (BEGV
!= XFASTINT (start
) || ZV
!= XFASTINT (end
))
3091 current_buffer
->clip_changed
= 1;
3093 SET_BUF_BEGV (current_buffer
, XFASTINT (start
));
3094 SET_BUF_ZV (current_buffer
, XFASTINT (end
));
3095 if (PT
< XFASTINT (start
))
3096 SET_PT (XFASTINT (start
));
3097 if (PT
> XFASTINT (end
))
3098 SET_PT (XFASTINT (end
));
3099 /* Changing the buffer bounds invalidates any recorded current column. */
3100 invalidate_current_column ();
3105 save_restriction_save ()
3107 if (BEGV
== BEG
&& ZV
== Z
)
3108 /* The common case that the buffer isn't narrowed.
3109 We return just the buffer object, which save_restriction_restore
3110 recognizes as meaning `no restriction'. */
3111 return Fcurrent_buffer ();
3113 /* We have to save a restriction, so return a pair of markers, one
3114 for the beginning and one for the end. */
3116 Lisp_Object beg
, end
;
3118 beg
= buildmark (BEGV
, BEGV_BYTE
);
3119 end
= buildmark (ZV
, ZV_BYTE
);
3121 /* END must move forward if text is inserted at its exact location. */
3122 XMARKER(end
)->insertion_type
= 1;
3124 return Fcons (beg
, end
);
3129 save_restriction_restore (data
)
3133 /* A pair of marks bounding a saved restriction. */
3135 struct Lisp_Marker
*beg
= XMARKER (XCAR (data
));
3136 struct Lisp_Marker
*end
= XMARKER (XCDR (data
));
3137 struct buffer
*buf
= beg
->buffer
; /* END should have the same buffer. */
3139 if (buf
/* Verify marker still points to a buffer. */
3140 && (beg
->charpos
!= BUF_BEGV (buf
) || end
->charpos
!= BUF_ZV (buf
)))
3141 /* The restriction has changed from the saved one, so restore
3142 the saved restriction. */
3144 int pt
= BUF_PT (buf
);
3146 SET_BUF_BEGV_BOTH (buf
, beg
->charpos
, beg
->bytepos
);
3147 SET_BUF_ZV_BOTH (buf
, end
->charpos
, end
->bytepos
);
3149 if (pt
< beg
->charpos
|| pt
> end
->charpos
)
3150 /* The point is outside the new visible range, move it inside. */
3151 SET_BUF_PT_BOTH (buf
,
3152 clip_to_bounds (beg
->charpos
, pt
, end
->charpos
),
3153 clip_to_bounds (beg
->bytepos
, BUF_PT_BYTE (buf
),
3156 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3160 /* A buffer, which means that there was no old restriction. */
3162 struct buffer
*buf
= XBUFFER (data
);
3164 if (buf
/* Verify marker still points to a buffer. */
3165 && (BUF_BEGV (buf
) != BUF_BEG (buf
) || BUF_ZV (buf
) != BUF_Z (buf
)))
3166 /* The buffer has been narrowed, get rid of the narrowing. */
3168 SET_BUF_BEGV_BOTH (buf
, BUF_BEG (buf
), BUF_BEG_BYTE (buf
));
3169 SET_BUF_ZV_BOTH (buf
, BUF_Z (buf
), BUF_Z_BYTE (buf
));
3171 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3178 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
3179 doc
: /* Execute BODY, saving and restoring current buffer's restrictions.
3180 The buffer's restrictions make parts of the beginning and end invisible.
3181 (They are set up with `narrow-to-region' and eliminated with `widen'.)
3182 This special form, `save-restriction', saves the current buffer's restrictions
3183 when it is entered, and restores them when it is exited.
3184 So any `narrow-to-region' within BODY lasts only until the end of the form.
3185 The old restrictions settings are restored
3186 even in case of abnormal exit (throw or error).
3188 The value returned is the value of the last form in BODY.
3190 Note: if you are using both `save-excursion' and `save-restriction',
3191 use `save-excursion' outermost:
3192 (save-excursion (save-restriction ...))
3194 usage: (save-restriction &rest BODY) */)
3198 register Lisp_Object val
;
3199 int count
= SPECPDL_INDEX ();
3201 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
3202 val
= Fprogn (body
);
3203 return unbind_to (count
, val
);
3206 /* Buffer for the most recent text displayed by Fmessage_box. */
3207 static char *message_text
;
3209 /* Allocated length of that buffer. */
3210 static int message_length
;
3212 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
3213 doc
: /* Print a one-line message at the bottom of the screen.
3214 The message also goes into the `*Messages*' buffer.
3215 \(In keyboard macros, that's all it does.)
3217 The first argument is a format control string, and the rest are data
3218 to be formatted under control of the string. See `format' for details.
3220 If the first argument is nil, the function clears any existing message;
3221 this lets the minibuffer contents show. See also `current-message'.
3223 usage: (message STRING &rest ARGS) */)
3229 || (STRINGP (args
[0])
3230 && SBYTES (args
[0]) == 0))
3237 register Lisp_Object val
;
3238 val
= Fformat (nargs
, args
);
3239 message3 (val
, SBYTES (val
), STRING_MULTIBYTE (val
));
3244 DEFUN ("message-box", Fmessage_box
, Smessage_box
, 1, MANY
, 0,
3245 doc
: /* Display a message, in a dialog box if possible.
3246 If a dialog box is not available, use the echo area.
3247 The first argument is a format control string, and the rest are data
3248 to be formatted under control of the string. See `format' for details.
3250 If the first argument is nil, clear any existing message; let the
3251 minibuffer contents show.
3253 usage: (message-box STRING &rest ARGS) */)
3265 register Lisp_Object val
;
3266 val
= Fformat (nargs
, args
);
3268 /* The MS-DOS frames support popup menus even though they are
3269 not FRAME_WINDOW_P. */
3270 if (FRAME_WINDOW_P (XFRAME (selected_frame
))
3271 || FRAME_MSDOS_P (XFRAME (selected_frame
)))
3273 Lisp_Object pane
, menu
, obj
;
3274 struct gcpro gcpro1
;
3275 pane
= Fcons (Fcons (build_string ("OK"), Qt
), Qnil
);
3277 menu
= Fcons (val
, pane
);
3278 obj
= Fx_popup_dialog (Qt
, menu
);
3282 #endif /* HAVE_MENUS */
3283 /* Copy the data so that it won't move when we GC. */
3286 message_text
= (char *)xmalloc (80);
3287 message_length
= 80;
3289 if (SBYTES (val
) > message_length
)
3291 message_length
= SBYTES (val
);
3292 message_text
= (char *)xrealloc (message_text
, message_length
);
3294 bcopy (SDATA (val
), message_text
, SBYTES (val
));
3295 message2 (message_text
, SBYTES (val
),
3296 STRING_MULTIBYTE (val
));
3301 extern Lisp_Object last_nonmenu_event
;
3304 DEFUN ("message-or-box", Fmessage_or_box
, Smessage_or_box
, 1, MANY
, 0,
3305 doc
: /* Display a message in a dialog box or in the echo area.
3306 If this command was invoked with the mouse, use a dialog box if
3307 `use-dialog-box' is non-nil.
3308 Otherwise, use the echo area.
3309 The first argument is a format control string, and the rest are data
3310 to be formatted under control of the string. See `format' for details.
3312 If the first argument is nil, clear any existing message; let the
3313 minibuffer contents show.
3315 usage: (message-or-box STRING &rest ARGS) */)
3321 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3323 return Fmessage_box (nargs
, args
);
3325 return Fmessage (nargs
, args
);
3328 DEFUN ("current-message", Fcurrent_message
, Scurrent_message
, 0, 0, 0,
3329 doc
: /* Return the string currently displayed in the echo area, or nil if none. */)
3332 return current_message ();
3336 DEFUN ("propertize", Fpropertize
, Spropertize
, 1, MANY
, 0,
3337 doc
: /* Return a copy of STRING with text properties added.
3338 First argument is the string to copy.
3339 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
3340 properties to add to the result.
3341 usage: (propertize STRING &rest PROPERTIES) */)
3346 Lisp_Object properties
, string
;
3347 struct gcpro gcpro1
, gcpro2
;
3350 /* Number of args must be odd. */
3351 if ((nargs
& 1) == 0 || nargs
< 1)
3352 error ("Wrong number of arguments");
3354 properties
= string
= Qnil
;
3355 GCPRO2 (properties
, string
);
3357 /* First argument must be a string. */
3358 CHECK_STRING (args
[0]);
3359 string
= Fcopy_sequence (args
[0]);
3361 for (i
= 1; i
< nargs
; i
+= 2)
3363 CHECK_SYMBOL (args
[i
]);
3364 properties
= Fcons (args
[i
], Fcons (args
[i
+ 1], properties
));
3367 Fadd_text_properties (make_number (0),
3368 make_number (SCHARS (string
)),
3369 properties
, string
);
3370 RETURN_UNGCPRO (string
);
3374 /* Number of bytes that STRING will occupy when put into the result.
3375 MULTIBYTE is nonzero if the result should be multibyte. */
3377 #define CONVERTED_BYTE_SIZE(MULTIBYTE, STRING) \
3378 (((MULTIBYTE) && ! STRING_MULTIBYTE (STRING)) \
3379 ? count_size_as_multibyte (SDATA (STRING), SBYTES (STRING)) \
3382 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
3383 doc
: /* Format a string out of a control-string and arguments.
3384 The first argument is a control string.
3385 The other arguments are substituted into it to make the result, a string.
3386 It may contain %-sequences meaning to substitute the next argument.
3387 %s means print a string argument. Actually, prints any object, with `princ'.
3388 %d means print as number in decimal (%o octal, %x hex).
3389 %X is like %x, but uses upper case.
3390 %e means print a number in exponential notation.
3391 %f means print a number in decimal-point notation.
3392 %g means print a number in exponential notation
3393 or decimal-point notation, whichever uses fewer characters.
3394 %c means print a number as a single character.
3395 %S means print any object as an s-expression (using `prin1').
3396 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.
3397 Use %% to put a single % into the output.
3399 The basic structure of a %-sequence is
3400 % <flags> <width> <precision> character
3401 where flags is [- #0]+, width is [0-9]+, and precision is .[0-9]+
3403 usage: (format STRING &rest OBJECTS) */)
3406 register Lisp_Object
*args
;
3408 register int n
; /* The number of the next arg to substitute */
3409 register int total
; /* An estimate of the final length */
3411 register unsigned char *format
, *end
, *format_start
;
3413 /* Nonzero if the output should be a multibyte string,
3414 which is true if any of the inputs is one. */
3416 /* When we make a multibyte string, we must pay attention to the
3417 byte combining problem, i.e., a byte may be combined with a
3418 multibyte charcter of the previous string. This flag tells if we
3419 must consider such a situation or not. */
3420 int maybe_combine_byte
;
3421 unsigned char *this_format
;
3422 /* Precision for each spec, or -1, a flag value meaning no precision
3423 was given in that spec. Element 0, corresonding to the format
3424 string itself, will not be used. Element NARGS, corresponding to
3425 no argument, *will* be assigned to in the case that a `%' and `.'
3426 occur after the final format specifier. */
3427 int *precision
= (int *) (alloca((nargs
+ 1) * sizeof (int)));
3430 int arg_intervals
= 0;
3433 /* discarded[I] is 1 if byte I of the format
3434 string was not copied into the output.
3435 It is 2 if byte I was not the first byte of its character. */
3436 char *discarded
= 0;
3438 /* Each element records, for one argument,
3439 the start and end bytepos in the output string,
3440 and whether the argument is a string with intervals.
3441 info[0] is unused. Unused elements have -1 for start. */
3444 int start
, end
, intervals
;
3447 /* It should not be necessary to GCPRO ARGS, because
3448 the caller in the interpreter should take care of that. */
3450 /* Try to determine whether the result should be multibyte.
3451 This is not always right; sometimes the result needs to be multibyte
3452 because of an object that we will pass through prin1,
3453 and in that case, we won't know it here. */
3454 for (n
= 0; n
< nargs
; n
++)
3456 if (STRINGP (args
[n
]) && STRING_MULTIBYTE (args
[n
]))
3458 /* Piggyback on this loop to initialize precision[N]. */
3461 precision
[nargs
] = -1;
3463 CHECK_STRING (args
[0]);
3464 /* We may have to change "%S" to "%s". */
3465 args
[0] = Fcopy_sequence (args
[0]);
3467 /* GC should never happen here, so abort if it does. */
3470 /* If we start out planning a unibyte result,
3471 then discover it has to be multibyte, we jump back to retry.
3472 That can only happen from the first large while loop below. */
3475 format
= SDATA (args
[0]);
3476 format_start
= format
;
3477 end
= format
+ SBYTES (args
[0]);
3480 /* Make room in result for all the non-%-codes in the control string. */
3481 total
= 5 + CONVERTED_BYTE_SIZE (multibyte
, args
[0]) + 1;
3483 /* Allocate the info and discarded tables. */
3485 int nbytes
= (nargs
+1) * sizeof *info
;
3488 info
= (struct info
*) alloca (nbytes
);
3489 bzero (info
, nbytes
);
3490 for (i
= 0; i
<= nargs
; i
++)
3493 SAFE_ALLOCA (discarded
, char *, SBYTES (args
[0]));
3494 bzero (discarded
, SBYTES (args
[0]));
3497 /* Add to TOTAL enough space to hold the converted arguments. */
3500 while (format
!= end
)
3501 if (*format
++ == '%')
3504 int actual_width
= 0;
3505 unsigned char *this_format_start
= format
- 1;
3506 int field_width
= 0;
3508 /* General format specifications look like
3510 '%' [flags] [field-width] [precision] format
3515 field-width ::= [0-9]+
3516 precision ::= '.' [0-9]*
3518 If a field-width is specified, it specifies to which width
3519 the output should be padded with blanks, iff the output
3520 string is shorter than field-width.
3522 If precision is specified, it specifies the number of
3523 digits to print after the '.' for floats, or the max.
3524 number of chars to print from a string. */
3526 while (index ("-0# ", *format
))
3529 if (*format
>= '0' && *format
<= '9')
3531 for (field_width
= 0; *format
>= '0' && *format
<= '9'; ++format
)
3532 field_width
= 10 * field_width
+ *format
- '0';
3535 /* N is not incremented for another few lines below, so refer to
3536 element N+1 (which might be precision[NARGS]). */
3540 for (precision
[n
+1] = 0; *format
>= '0' && *format
<= '9'; ++format
)
3541 precision
[n
+1] = 10 * precision
[n
+1] + *format
- '0';
3544 if (format
- this_format_start
+ 1 > longest_format
)
3545 longest_format
= format
- this_format_start
+ 1;
3548 error ("Format string ends in middle of format specifier");
3551 else if (++n
>= nargs
)
3552 error ("Not enough arguments for format string");
3553 else if (*format
== 'S')
3555 /* For `S', prin1 the argument and then treat like a string. */
3556 register Lisp_Object tem
;
3557 tem
= Fprin1_to_string (args
[n
], Qnil
);
3558 if (STRING_MULTIBYTE (tem
) && ! multibyte
)
3564 /* If we restart the loop, we should not come here again
3565 because args[n] is now a string and calling
3566 Fprin1_to_string on it produces superflous double
3567 quotes. So, change "%S" to "%s" now. */
3571 else if (SYMBOLP (args
[n
]))
3573 args
[n
] = SYMBOL_NAME (args
[n
]);
3574 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
3581 else if (STRINGP (args
[n
]))
3584 if (*format
!= 's' && *format
!= 'S')
3585 error ("Format specifier doesn't match argument type");
3586 /* In the case (PRECISION[N] > 0), THISSIZE may not need
3587 to be as large as is calculated here. Easy check for
3588 the case PRECISION = 0. */
3589 thissize
= precision
[n
] ? CONVERTED_BYTE_SIZE (multibyte
, args
[n
]) : 0;
3590 actual_width
= lisp_string_width (args
[n
], -1, NULL
, NULL
);
3592 /* Would get MPV otherwise, since Lisp_Int's `point' to low memory. */
3593 else if (INTEGERP (args
[n
]) && *format
!= 's')
3595 /* The following loop assumes the Lisp type indicates
3596 the proper way to pass the argument.
3597 So make sure we have a flonum if the argument should
3599 if (*format
== 'e' || *format
== 'f' || *format
== 'g')
3600 args
[n
] = Ffloat (args
[n
]);
3602 if (*format
!= 'd' && *format
!= 'o' && *format
!= 'x'
3603 && *format
!= 'i' && *format
!= 'X' && *format
!= 'c')
3604 error ("Invalid format operation %%%c", *format
);
3609 if (! ASCII_CHAR_P (XINT (args
[n
]))
3610 /* Note: No one can remeber why we have to treat
3611 the character 0 as a multibyte character here.
3612 But, until it causes a real problem, let's
3614 || XINT (args
[n
]) == 0)
3621 args
[n
] = Fchar_to_string (args
[n
]);
3622 thissize
= SBYTES (args
[n
]);
3624 else if (! ASCII_BYTE_P (XINT (args
[n
])) && multibyte
)
3627 = Fchar_to_string (Funibyte_char_to_multibyte (args
[n
]));
3628 thissize
= SBYTES (args
[n
]);
3632 else if (FLOATP (args
[n
]) && *format
!= 's')
3634 if (! (*format
== 'e' || *format
== 'f' || *format
== 'g'))
3636 if (*format
!= 'd' && *format
!= 'o' && *format
!= 'x'
3637 && *format
!= 'i' && *format
!= 'X' && *format
!= 'c')
3638 error ("Invalid format operation %%%c", *format
);
3639 args
[n
] = Ftruncate (args
[n
], Qnil
);
3642 /* Note that we're using sprintf to print floats,
3643 so we have to take into account what that function
3645 /* Filter out flag value of -1. */
3646 thissize
= (MAX_10_EXP
+ 100
3647 + (precision
[n
] > 0 ? precision
[n
] : 0));
3651 /* Anything but a string, convert to a string using princ. */
3652 register Lisp_Object tem
;
3653 tem
= Fprin1_to_string (args
[n
], Qt
);
3654 if (STRING_MULTIBYTE (tem
) && ! multibyte
)
3663 thissize
+= max (0, field_width
- actual_width
);
3664 total
+= thissize
+ 4;
3669 /* Now we can no longer jump to retry.
3670 TOTAL and LONGEST_FORMAT are known for certain. */
3672 this_format
= (unsigned char *) alloca (longest_format
+ 1);
3674 /* Allocate the space for the result.
3675 Note that TOTAL is an overestimate. */
3676 SAFE_ALLOCA (buf
, char *, total
);
3682 /* Scan the format and store result in BUF. */
3683 format
= SDATA (args
[0]);
3684 format_start
= format
;
3685 end
= format
+ SBYTES (args
[0]);
3686 maybe_combine_byte
= 0;
3687 while (format
!= end
)
3693 unsigned char *this_format_start
= format
;
3695 discarded
[format
- format_start
] = 1;
3698 while (index("-0# ", *format
))
3704 discarded
[format
- format_start
] = 1;
3708 minlen
= atoi (format
);
3710 while ((*format
>= '0' && *format
<= '9') || *format
== '.')
3712 discarded
[format
- format_start
] = 1;
3716 if (*format
++ == '%')
3725 discarded
[format
- format_start
- 1] = 1;
3726 info
[n
].start
= nchars
;
3728 if (STRINGP (args
[n
]))
3730 /* handle case (precision[n] >= 0) */
3733 int nbytes
, start
, end
;
3736 /* lisp_string_width ignores a precision of 0, but GNU
3737 libc functions print 0 characters when the precision
3738 is 0. Imitate libc behavior here. Changing
3739 lisp_string_width is the right thing, and will be
3740 done, but meanwhile we work with it. */
3742 if (precision
[n
] == 0)
3743 width
= nchars_string
= nbytes
= 0;
3744 else if (precision
[n
] > 0)
3745 width
= lisp_string_width (args
[n
], precision
[n
], &nchars_string
, &nbytes
);
3747 { /* no precision spec given for this argument */
3748 width
= lisp_string_width (args
[n
], -1, NULL
, NULL
);
3749 nbytes
= SBYTES (args
[n
]);
3750 nchars_string
= SCHARS (args
[n
]);
3753 /* If spec requires it, pad on right with spaces. */
3754 padding
= minlen
- width
;
3756 while (padding
-- > 0)
3763 nchars
+= nchars_string
;
3768 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3769 && STRING_MULTIBYTE (args
[n
])
3770 && !CHAR_HEAD_P (SREF (args
[n
], 0)))
3771 maybe_combine_byte
= 1;
3773 p
+= copy_text (SDATA (args
[n
]), p
,
3775 STRING_MULTIBYTE (args
[n
]), multibyte
);
3778 while (padding
-- > 0)
3784 /* If this argument has text properties, record where
3785 in the result string it appears. */
3786 if (STRING_INTERVALS (args
[n
]))
3787 info
[n
].intervals
= arg_intervals
= 1;
3789 else if (INTEGERP (args
[n
]) || FLOATP (args
[n
]))
3793 bcopy (this_format_start
, this_format
,
3794 format
- this_format_start
);
3795 this_format
[format
- this_format_start
] = 0;
3797 if (INTEGERP (args
[n
]))
3798 sprintf (p
, this_format
, XINT (args
[n
]));
3800 sprintf (p
, this_format
, XFLOAT_DATA (args
[n
]));
3804 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3805 && !CHAR_HEAD_P (*((unsigned char *) p
)))
3806 maybe_combine_byte
= 1;
3807 this_nchars
= strlen (p
);
3809 p
+= str_to_multibyte (p
, buf
+ total
- 1 - p
, this_nchars
);
3812 nchars
+= this_nchars
;
3815 info
[n
].end
= nchars
;
3817 else if (STRING_MULTIBYTE (args
[0]))
3819 /* Copy a whole multibyte character. */
3822 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3823 && !CHAR_HEAD_P (*format
))
3824 maybe_combine_byte
= 1;
3826 while (! CHAR_HEAD_P (*format
))
3828 discarded
[format
- format_start
] = 2;
3835 /* Convert a single-byte character to multibyte. */
3836 int len
= copy_text (format
, p
, 1, 0, 1);
3843 *p
++ = *format
++, nchars
++;
3846 if (p
> buf
+ total
)
3849 if (maybe_combine_byte
)
3850 nchars
= multibyte_chars_in_text (buf
, p
- buf
);
3851 val
= make_specified_string (buf
, nchars
, p
- buf
, multibyte
);
3853 /* If we allocated BUF with malloc, free it too. */
3856 /* If the format string has text properties, or any of the string
3857 arguments has text properties, set up text properties of the
3860 if (STRING_INTERVALS (args
[0]) || arg_intervals
)
3862 Lisp_Object len
, new_len
, props
;
3863 struct gcpro gcpro1
;
3865 /* Add text properties from the format string. */
3866 len
= make_number (SCHARS (args
[0]));
3867 props
= text_property_list (args
[0], make_number (0), len
, Qnil
);
3872 int bytepos
= 0, position
= 0, translated
= 0, argn
= 1;
3875 /* Adjust the bounds of each text property
3876 to the proper start and end in the output string. */
3878 /* Put the positions in PROPS in increasing order, so that
3879 we can do (effectively) one scan through the position
3880 space of the format string. */
3881 props
= Fnreverse (props
);
3883 /* BYTEPOS is the byte position in the format string,
3884 POSITION is the untranslated char position in it,
3885 TRANSLATED is the translated char position in BUF,
3886 and ARGN is the number of the next arg we will come to. */
3887 for (list
= props
; CONSP (list
); list
= XCDR (list
))
3894 /* First adjust the property start position. */
3895 pos
= XINT (XCAR (item
));
3897 /* Advance BYTEPOS, POSITION, TRANSLATED and ARGN
3898 up to this position. */
3899 for (; position
< pos
; bytepos
++)
3901 if (! discarded
[bytepos
])
3902 position
++, translated
++;
3903 else if (discarded
[bytepos
] == 1)
3906 if (translated
== info
[argn
].start
)
3908 translated
+= info
[argn
].end
- info
[argn
].start
;
3914 XSETCAR (item
, make_number (translated
));
3916 /* Likewise adjust the property end position. */
3917 pos
= XINT (XCAR (XCDR (item
)));
3919 for (; bytepos
< pos
; bytepos
++)
3921 if (! discarded
[bytepos
])
3922 position
++, translated
++;
3923 else if (discarded
[bytepos
] == 1)
3926 if (translated
== info
[argn
].start
)
3928 translated
+= info
[argn
].end
- info
[argn
].start
;
3934 XSETCAR (XCDR (item
), make_number (translated
));
3937 add_text_properties_from_list (val
, props
, make_number (0));
3940 /* Add text properties from arguments. */
3942 for (n
= 1; n
< nargs
; ++n
)
3943 if (info
[n
].intervals
)
3945 len
= make_number (SCHARS (args
[n
]));
3946 new_len
= make_number (info
[n
].end
- info
[n
].start
);
3947 props
= text_property_list (args
[n
], make_number (0), len
, Qnil
);
3948 extend_property_ranges (props
, len
, new_len
);
3949 /* If successive arguments have properites, be sure that
3950 the value of `composition' property be the copy. */
3951 if (n
> 1 && info
[n
- 1].end
)
3952 make_composition_value_copy (props
);
3953 add_text_properties_from_list (val
, props
,
3954 make_number (info
[n
].start
));
3964 format2 (string1
, arg0
, arg1
)
3966 Lisp_Object arg0
, arg1
;
3968 Lisp_Object args
[3];
3969 args
[0] = build_string (string1
);
3972 return Fformat (3, args
);
3975 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
3976 doc
: /* Return t if two characters match, optionally ignoring case.
3977 Both arguments must be characters (i.e. integers).
3978 Case is ignored if `case-fold-search' is non-nil in the current buffer. */)
3980 register Lisp_Object c1
, c2
;
3986 if (XINT (c1
) == XINT (c2
))
3988 if (NILP (current_buffer
->case_fold_search
))
3991 /* Do these in separate statements,
3992 then compare the variables.
3993 because of the way DOWNCASE uses temp variables. */
3995 if (NILP (current_buffer
->enable_multibyte_characters
)
3996 && ! ASCII_CHAR_P (i1
))
3998 MAKE_CHAR_MULTIBYTE (i1
);
4001 if (NILP (current_buffer
->enable_multibyte_characters
)
4002 && ! ASCII_CHAR_P (i2
))
4004 MAKE_CHAR_MULTIBYTE (i2
);
4008 return (i1
== i2
? Qt
: Qnil
);
4011 /* Transpose the markers in two regions of the current buffer, and
4012 adjust the ones between them if necessary (i.e.: if the regions
4015 START1, END1 are the character positions of the first region.
4016 START1_BYTE, END1_BYTE are the byte positions.
4017 START2, END2 are the character positions of the second region.
4018 START2_BYTE, END2_BYTE are the byte positions.
4020 Traverses the entire marker list of the buffer to do so, adding an
4021 appropriate amount to some, subtracting from some, and leaving the
4022 rest untouched. Most of this is copied from adjust_markers in insdel.c.
4024 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
4027 transpose_markers (start1
, end1
, start2
, end2
,
4028 start1_byte
, end1_byte
, start2_byte
, end2_byte
)
4029 register int start1
, end1
, start2
, end2
;
4030 register int start1_byte
, end1_byte
, start2_byte
, end2_byte
;
4032 register int amt1
, amt1_byte
, amt2
, amt2_byte
, diff
, diff_byte
, mpos
;
4033 register struct Lisp_Marker
*marker
;
4035 /* Update point as if it were a marker. */
4039 TEMP_SET_PT_BOTH (PT
+ (end2
- end1
),
4040 PT_BYTE
+ (end2_byte
- end1_byte
));
4041 else if (PT
< start2
)
4042 TEMP_SET_PT_BOTH (PT
+ (end2
- start2
) - (end1
- start1
),
4043 (PT_BYTE
+ (end2_byte
- start2_byte
)
4044 - (end1_byte
- start1_byte
)));
4046 TEMP_SET_PT_BOTH (PT
- (start2
- start1
),
4047 PT_BYTE
- (start2_byte
- start1_byte
));
4049 /* We used to adjust the endpoints here to account for the gap, but that
4050 isn't good enough. Even if we assume the caller has tried to move the
4051 gap out of our way, it might still be at start1 exactly, for example;
4052 and that places it `inside' the interval, for our purposes. The amount
4053 of adjustment is nontrivial if there's a `denormalized' marker whose
4054 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
4055 the dirty work to Fmarker_position, below. */
4057 /* The difference between the region's lengths */
4058 diff
= (end2
- start2
) - (end1
- start1
);
4059 diff_byte
= (end2_byte
- start2_byte
) - (end1_byte
- start1_byte
);
4061 /* For shifting each marker in a region by the length of the other
4062 region plus the distance between the regions. */
4063 amt1
= (end2
- start2
) + (start2
- end1
);
4064 amt2
= (end1
- start1
) + (start2
- end1
);
4065 amt1_byte
= (end2_byte
- start2_byte
) + (start2_byte
- end1_byte
);
4066 amt2_byte
= (end1_byte
- start1_byte
) + (start2_byte
- end1_byte
);
4068 for (marker
= BUF_MARKERS (current_buffer
); marker
; marker
= marker
->next
)
4070 mpos
= marker
->bytepos
;
4071 if (mpos
>= start1_byte
&& mpos
< end2_byte
)
4073 if (mpos
< end1_byte
)
4075 else if (mpos
< start2_byte
)
4079 marker
->bytepos
= mpos
;
4081 mpos
= marker
->charpos
;
4082 if (mpos
>= start1
&& mpos
< end2
)
4086 else if (mpos
< start2
)
4091 marker
->charpos
= mpos
;
4095 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
4096 doc
: /* Transpose region STARTR1 to ENDR1 with STARTR2 to ENDR2.
4097 The regions may not be overlapping, because the size of the buffer is
4098 never changed in a transposition.
4100 Optional fifth arg LEAVE-MARKERS, if non-nil, means don't update
4101 any markers that happen to be located in the regions.
4103 Transposing beyond buffer boundaries is an error. */)
4104 (startr1
, endr1
, startr2
, endr2
, leave_markers
)
4105 Lisp_Object startr1
, endr1
, startr2
, endr2
, leave_markers
;
4107 register int start1
, end1
, start2
, end2
;
4108 int start1_byte
, start2_byte
, len1_byte
, len2_byte
;
4109 int gap
, len1
, len_mid
, len2
;
4110 unsigned char *start1_addr
, *start2_addr
, *temp
;
4112 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
;
4113 cur_intv
= BUF_INTERVALS (current_buffer
);
4115 validate_region (&startr1
, &endr1
);
4116 validate_region (&startr2
, &endr2
);
4118 start1
= XFASTINT (startr1
);
4119 end1
= XFASTINT (endr1
);
4120 start2
= XFASTINT (startr2
);
4121 end2
= XFASTINT (endr2
);
4124 /* Swap the regions if they're reversed. */
4127 register int glumph
= start1
;
4135 len1
= end1
- start1
;
4136 len2
= end2
- start2
;
4139 error ("Transposed regions overlap");
4140 else if (start1
== end1
|| start2
== end2
)
4141 error ("Transposed region has length 0");
4143 /* The possibilities are:
4144 1. Adjacent (contiguous) regions, or separate but equal regions
4145 (no, really equal, in this case!), or
4146 2. Separate regions of unequal size.
4148 The worst case is usually No. 2. It means that (aside from
4149 potential need for getting the gap out of the way), there also
4150 needs to be a shifting of the text between the two regions. So
4151 if they are spread far apart, we are that much slower... sigh. */
4153 /* It must be pointed out that the really studly thing to do would
4154 be not to move the gap at all, but to leave it in place and work
4155 around it if necessary. This would be extremely efficient,
4156 especially considering that people are likely to do
4157 transpositions near where they are working interactively, which
4158 is exactly where the gap would be found. However, such code
4159 would be much harder to write and to read. So, if you are
4160 reading this comment and are feeling squirrely, by all means have
4161 a go! I just didn't feel like doing it, so I will simply move
4162 the gap the minimum distance to get it out of the way, and then
4163 deal with an unbroken array. */
4165 /* Make sure the gap won't interfere, by moving it out of the text
4166 we will operate on. */
4167 if (start1
< gap
&& gap
< end2
)
4169 if (gap
- start1
< end2
- gap
)
4175 start1_byte
= CHAR_TO_BYTE (start1
);
4176 start2_byte
= CHAR_TO_BYTE (start2
);
4177 len1_byte
= CHAR_TO_BYTE (end1
) - start1_byte
;
4178 len2_byte
= CHAR_TO_BYTE (end2
) - start2_byte
;
4180 #ifdef BYTE_COMBINING_DEBUG
4183 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4184 len2_byte
, start1
, start1_byte
)
4185 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4186 len1_byte
, end2
, start2_byte
+ len2_byte
)
4187 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4188 len1_byte
, end2
, start2_byte
+ len2_byte
))
4193 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4194 len2_byte
, start1
, start1_byte
)
4195 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4196 len1_byte
, start2
, start2_byte
)
4197 || count_combining_after (BYTE_POS_ADDR (start2_byte
),
4198 len2_byte
, end1
, start1_byte
+ len1_byte
)
4199 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4200 len1_byte
, end2
, start2_byte
+ len2_byte
))
4205 /* Hmmm... how about checking to see if the gap is large
4206 enough to use as the temporary storage? That would avoid an
4207 allocation... interesting. Later, don't fool with it now. */
4209 /* Working without memmove, for portability (sigh), so must be
4210 careful of overlapping subsections of the array... */
4212 if (end1
== start2
) /* adjacent regions */
4214 modify_region (current_buffer
, start1
, end2
);
4215 record_change (start1
, len1
+ len2
);
4217 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4218 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4219 Fset_text_properties (make_number (start1
), make_number (end2
),
4222 /* First region smaller than second. */
4223 if (len1_byte
< len2_byte
)
4227 SAFE_ALLOCA (temp
, unsigned char *, len2_byte
);
4229 /* Don't precompute these addresses. We have to compute them
4230 at the last minute, because the relocating allocator might
4231 have moved the buffer around during the xmalloc. */
4232 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4233 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4235 bcopy (start2_addr
, temp
, len2_byte
);
4236 bcopy (start1_addr
, start1_addr
+ len2_byte
, len1_byte
);
4237 bcopy (temp
, start1_addr
, len2_byte
);
4241 /* First region not smaller than second. */
4245 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4246 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4247 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4248 bcopy (start1_addr
, temp
, len1_byte
);
4249 bcopy (start2_addr
, start1_addr
, len2_byte
);
4250 bcopy (temp
, start1_addr
+ len2_byte
, len1_byte
);
4253 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
4254 len1
, current_buffer
, 0);
4255 graft_intervals_into_buffer (tmp_interval2
, start1
,
4256 len2
, current_buffer
, 0);
4257 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4258 update_compositions (start1
+ len2
, end2
, CHECK_TAIL
);
4260 /* Non-adjacent regions, because end1 != start2, bleagh... */
4263 len_mid
= start2_byte
- (start1_byte
+ len1_byte
);
4265 if (len1_byte
== len2_byte
)
4266 /* Regions are same size, though, how nice. */
4270 modify_region (current_buffer
, start1
, end1
);
4271 modify_region (current_buffer
, start2
, end2
);
4272 record_change (start1
, len1
);
4273 record_change (start2
, len2
);
4274 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4275 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4276 Fset_text_properties (make_number (start1
), make_number (end1
),
4278 Fset_text_properties (make_number (start2
), make_number (end2
),
4281 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4282 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4283 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4284 bcopy (start1_addr
, temp
, len1_byte
);
4285 bcopy (start2_addr
, start1_addr
, len2_byte
);
4286 bcopy (temp
, start2_addr
, len1_byte
);
4289 graft_intervals_into_buffer (tmp_interval1
, start2
,
4290 len1
, current_buffer
, 0);
4291 graft_intervals_into_buffer (tmp_interval2
, start1
,
4292 len2
, current_buffer
, 0);
4295 else if (len1_byte
< len2_byte
) /* Second region larger than first */
4296 /* Non-adjacent & unequal size, area between must also be shifted. */
4300 modify_region (current_buffer
, start1
, end2
);
4301 record_change (start1
, (end2
- start1
));
4302 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4303 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4304 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4305 Fset_text_properties (make_number (start1
), make_number (end2
),
4308 /* holds region 2 */
4309 SAFE_ALLOCA (temp
, unsigned char *, len2_byte
);
4310 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4311 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4312 bcopy (start2_addr
, temp
, len2_byte
);
4313 bcopy (start1_addr
, start1_addr
+ len_mid
+ len2_byte
, len1_byte
);
4314 safe_bcopy (start1_addr
+ len1_byte
, start1_addr
+ len2_byte
, len_mid
);
4315 bcopy (temp
, start1_addr
, len2_byte
);
4318 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4319 len1
, current_buffer
, 0);
4320 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4321 len_mid
, current_buffer
, 0);
4322 graft_intervals_into_buffer (tmp_interval2
, start1
,
4323 len2
, current_buffer
, 0);
4326 /* Second region smaller than first. */
4330 record_change (start1
, (end2
- start1
));
4331 modify_region (current_buffer
, start1
, end2
);
4333 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4334 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4335 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4336 Fset_text_properties (make_number (start1
), make_number (end2
),
4339 /* holds region 1 */
4340 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4341 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4342 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4343 bcopy (start1_addr
, temp
, len1_byte
);
4344 bcopy (start2_addr
, start1_addr
, len2_byte
);
4345 bcopy (start1_addr
+ len1_byte
, start1_addr
+ len2_byte
, len_mid
);
4346 bcopy (temp
, start1_addr
+ len2_byte
+ len_mid
, len1_byte
);
4349 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4350 len1
, current_buffer
, 0);
4351 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4352 len_mid
, current_buffer
, 0);
4353 graft_intervals_into_buffer (tmp_interval2
, start1
,
4354 len2
, current_buffer
, 0);
4357 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4358 update_compositions (end2
- len1
, end2
, CHECK_BORDER
);
4361 /* When doing multiple transpositions, it might be nice
4362 to optimize this. Perhaps the markers in any one buffer
4363 should be organized in some sorted data tree. */
4364 if (NILP (leave_markers
))
4366 transpose_markers (start1
, end1
, start2
, end2
,
4367 start1_byte
, start1_byte
+ len1_byte
,
4368 start2_byte
, start2_byte
+ len2_byte
);
4369 fix_start_end_in_overlays (start1
, end2
);
4381 Qbuffer_access_fontify_functions
4382 = intern ("buffer-access-fontify-functions");
4383 staticpro (&Qbuffer_access_fontify_functions
);
4385 DEFVAR_LISP ("inhibit-field-text-motion", &Vinhibit_field_text_motion
,
4386 doc
: /* Non-nil means text motion commands don't notice fields. */);
4387 Vinhibit_field_text_motion
= Qnil
;
4389 DEFVAR_LISP ("buffer-access-fontify-functions",
4390 &Vbuffer_access_fontify_functions
,
4391 doc
: /* List of functions called by `buffer-substring' to fontify if necessary.
4392 Each function is called with two arguments which specify the range
4393 of the buffer being accessed. */);
4394 Vbuffer_access_fontify_functions
= Qnil
;
4398 extern Lisp_Object Vprin1_to_string_buffer
;
4399 obuf
= Fcurrent_buffer ();
4400 /* Do this here, because init_buffer_once is too early--it won't work. */
4401 Fset_buffer (Vprin1_to_string_buffer
);
4402 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
4403 Fset (Fmake_local_variable (intern ("buffer-access-fontify-functions")),
4408 DEFVAR_LISP ("buffer-access-fontified-property",
4409 &Vbuffer_access_fontified_property
,
4410 doc
: /* Property which (if non-nil) indicates text has been fontified.
4411 `buffer-substring' need not call the `buffer-access-fontify-functions'
4412 functions if all the text being accessed has this property. */);
4413 Vbuffer_access_fontified_property
= Qnil
;
4415 DEFVAR_LISP ("system-name", &Vsystem_name
,
4416 doc
: /* The name of the machine Emacs is running on. */);
4418 DEFVAR_LISP ("user-full-name", &Vuser_full_name
,
4419 doc
: /* The full name of the user logged in. */);
4421 DEFVAR_LISP ("user-login-name", &Vuser_login_name
,
4422 doc
: /* The user's name, taken from environment variables if possible. */);
4424 DEFVAR_LISP ("user-real-login-name", &Vuser_real_login_name
,
4425 doc
: /* The user's name, based upon the real uid only. */);
4427 defsubr (&Spropertize
);
4428 defsubr (&Schar_equal
);
4429 defsubr (&Sgoto_char
);
4430 defsubr (&Sstring_to_char
);
4431 defsubr (&Schar_to_string
);
4432 defsubr (&Sbuffer_substring
);
4433 defsubr (&Sbuffer_substring_no_properties
);
4434 defsubr (&Sbuffer_string
);
4436 defsubr (&Spoint_marker
);
4437 defsubr (&Smark_marker
);
4439 defsubr (&Sregion_beginning
);
4440 defsubr (&Sregion_end
);
4442 staticpro (&Qfield
);
4443 Qfield
= intern ("field");
4444 staticpro (&Qboundary
);
4445 Qboundary
= intern ("boundary");
4446 defsubr (&Sfield_beginning
);
4447 defsubr (&Sfield_end
);
4448 defsubr (&Sfield_string
);
4449 defsubr (&Sfield_string_no_properties
);
4450 defsubr (&Sdelete_field
);
4451 defsubr (&Sconstrain_to_field
);
4453 defsubr (&Sline_beginning_position
);
4454 defsubr (&Sline_end_position
);
4456 /* defsubr (&Smark); */
4457 /* defsubr (&Sset_mark); */
4458 defsubr (&Ssave_excursion
);
4459 defsubr (&Ssave_current_buffer
);
4461 defsubr (&Sbufsize
);
4462 defsubr (&Spoint_max
);
4463 defsubr (&Spoint_min
);
4464 defsubr (&Spoint_min_marker
);
4465 defsubr (&Spoint_max_marker
);
4466 defsubr (&Sgap_position
);
4467 defsubr (&Sgap_size
);
4468 defsubr (&Sposition_bytes
);
4469 defsubr (&Sbyte_to_position
);
4475 defsubr (&Sfollowing_char
);
4476 defsubr (&Sprevious_char
);
4477 defsubr (&Schar_after
);
4478 defsubr (&Schar_before
);
4480 defsubr (&Sinsert_before_markers
);
4481 defsubr (&Sinsert_and_inherit
);
4482 defsubr (&Sinsert_and_inherit_before_markers
);
4483 defsubr (&Sinsert_char
);
4484 defsubr (&Sinsert_byte
);
4486 defsubr (&Suser_login_name
);
4487 defsubr (&Suser_real_login_name
);
4488 defsubr (&Suser_uid
);
4489 defsubr (&Suser_real_uid
);
4490 defsubr (&Suser_full_name
);
4491 defsubr (&Semacs_pid
);
4492 defsubr (&Scurrent_time
);
4493 defsubr (&Sget_internal_run_time
);
4494 defsubr (&Sformat_time_string
);
4495 defsubr (&Sfloat_time
);
4496 defsubr (&Sdecode_time
);
4497 defsubr (&Sencode_time
);
4498 defsubr (&Scurrent_time_string
);
4499 defsubr (&Scurrent_time_zone
);
4500 defsubr (&Sset_time_zone_rule
);
4501 defsubr (&Ssystem_name
);
4502 defsubr (&Smessage
);
4503 defsubr (&Smessage_box
);
4504 defsubr (&Smessage_or_box
);
4505 defsubr (&Scurrent_message
);
4508 defsubr (&Sinsert_buffer_substring
);
4509 defsubr (&Scompare_buffer_substrings
);
4510 defsubr (&Ssubst_char_in_region
);
4511 defsubr (&Stranslate_region_internal
);
4512 defsubr (&Sdelete_region
);
4513 defsubr (&Sdelete_and_extract_region
);
4515 defsubr (&Snarrow_to_region
);
4516 defsubr (&Ssave_restriction
);
4517 defsubr (&Stranspose_regions
);
4520 /* arch-tag: fc3827d8-6f60-4067-b11e-c3218031b018
4521 (do not change this comment) */