1 /* Lisp functions pertaining to editing.
2 Copyright (C) 1985, 1986, 1987, 1989, 1993, 1994, 1995, 1996, 1997, 1998,
3 1999, 2000, 2001, 2002, 2003, 2004, 2005 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>
35 #ifdef HAVE_SYS_UTSNAME_H
36 #include <sys/utsname.h>
39 /* systime.h includes <sys/time.h> which, on some systems, is required
40 for <sys/resource.h>; thus systime.h must be included before
44 #if defined HAVE_SYS_RESOURCE_H
45 #include <sys/resource.h>
51 #include "intervals.h"
53 #include "character.h"
60 #define MAX_10_EXP DBL_MAX_10_EXP
62 #define MAX_10_EXP 310
70 extern char **environ
;
73 extern Lisp_Object make_time
P_ ((time_t));
74 extern size_t emacs_strftimeu
P_ ((char *, size_t, const char *,
75 const struct tm
*, int));
76 static int tm_diff
P_ ((struct tm
*, struct tm
*));
77 static void find_field
P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
, int *, Lisp_Object
, int *));
78 static void update_buffer_properties
P_ ((int, int));
79 static Lisp_Object region_limit
P_ ((int));
80 int lisp_time_argument
P_ ((Lisp_Object
, time_t *, int *));
81 static size_t emacs_memftimeu
P_ ((char *, size_t, const char *,
82 size_t, const struct tm
*, int));
83 static void general_insert_function
P_ ((void (*) (const unsigned char *, int),
84 void (*) (Lisp_Object
, int, int, int,
86 int, int, Lisp_Object
*));
87 static Lisp_Object subst_char_in_region_unwind
P_ ((Lisp_Object
));
88 static Lisp_Object subst_char_in_region_unwind_1
P_ ((Lisp_Object
));
89 static void transpose_markers
P_ ((int, int, int, int, int, int, int, int));
92 extern char *index
P_ ((const char *, int));
95 Lisp_Object Vbuffer_access_fontify_functions
;
96 Lisp_Object Qbuffer_access_fontify_functions
;
97 Lisp_Object Vbuffer_access_fontified_property
;
99 Lisp_Object Fuser_full_name
P_ ((Lisp_Object
));
101 /* Non-nil means don't stop at field boundary in text motion commands. */
103 Lisp_Object Vinhibit_field_text_motion
;
105 /* Some static data, and a function to initialize it for each run */
107 Lisp_Object Vsystem_name
;
108 Lisp_Object Vuser_real_login_name
; /* login name of current user ID */
109 Lisp_Object Vuser_full_name
; /* full name of current user */
110 Lisp_Object Vuser_login_name
; /* user name from LOGNAME or USER */
111 Lisp_Object Voperating_system_release
; /* Operating System Release */
113 /* Symbol for the text property used to mark fields. */
117 /* A special value for Qfield properties. */
119 Lisp_Object Qboundary
;
126 register unsigned char *p
;
127 struct passwd
*pw
; /* password entry for the current user */
130 /* Set up system_name even when dumping. */
134 /* Don't bother with this on initial start when just dumping out */
137 #endif /* not CANNOT_DUMP */
139 pw
= (struct passwd
*) getpwuid (getuid ());
141 /* We let the real user name default to "root" because that's quite
142 accurate on MSDOG and because it lets Emacs find the init file.
143 (The DVX libraries override the Djgpp libraries here.) */
144 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "root");
146 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "unknown");
149 /* Get the effective user name, by consulting environment variables,
150 or the effective uid if those are unset. */
151 user_name
= (char *) getenv ("LOGNAME");
154 user_name
= (char *) getenv ("USERNAME"); /* it's USERNAME on NT */
155 #else /* WINDOWSNT */
156 user_name
= (char *) getenv ("USER");
157 #endif /* WINDOWSNT */
160 pw
= (struct passwd
*) getpwuid (geteuid ());
161 user_name
= (char *) (pw
? pw
->pw_name
: "unknown");
163 Vuser_login_name
= build_string (user_name
);
165 /* If the user name claimed in the environment vars differs from
166 the real uid, use the claimed name to find the full name. */
167 tem
= Fstring_equal (Vuser_login_name
, Vuser_real_login_name
);
168 Vuser_full_name
= Fuser_full_name (NILP (tem
)? make_number (geteuid())
171 p
= (unsigned char *) getenv ("NAME");
173 Vuser_full_name
= build_string (p
);
174 else if (NILP (Vuser_full_name
))
175 Vuser_full_name
= build_string ("unknown");
177 #ifdef HAVE_SYS_UTSNAME_H
181 Voperating_system_release
= build_string (uts
.release
);
184 Voperating_system_release
= Qnil
;
188 DEFUN ("char-to-string", Fchar_to_string
, Schar_to_string
, 1, 1, 0,
189 doc
: /* Convert arg CHAR to a string containing that character.
190 usage: (char-to-string CHAR) */)
192 Lisp_Object character
;
195 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
197 CHECK_NUMBER (character
);
199 len
= CHAR_STRING (XFASTINT (character
), str
);
200 return make_string_from_bytes (str
, 1, len
);
203 DEFUN ("string-to-char", Fstring_to_char
, Sstring_to_char
, 1, 1, 0,
204 doc
: /* Convert arg STRING to a character, the first character of that string.
205 A multibyte character is handled correctly. */)
207 register Lisp_Object string
;
209 register Lisp_Object val
;
210 CHECK_STRING (string
);
213 if (STRING_MULTIBYTE (string
))
214 XSETFASTINT (val
, STRING_CHAR (SDATA (string
), SBYTES (string
)));
216 XSETFASTINT (val
, SREF (string
, 0));
219 XSETFASTINT (val
, 0);
224 buildmark (charpos
, bytepos
)
225 int charpos
, bytepos
;
227 register Lisp_Object mark
;
228 mark
= Fmake_marker ();
229 set_marker_both (mark
, Qnil
, charpos
, bytepos
);
233 DEFUN ("point", Fpoint
, Spoint
, 0, 0, 0,
234 doc
: /* Return value of point, as an integer.
235 Beginning of buffer is position (point-min). */)
239 XSETFASTINT (temp
, PT
);
243 DEFUN ("point-marker", Fpoint_marker
, Spoint_marker
, 0, 0, 0,
244 doc
: /* Return value of point, as a marker object. */)
247 return buildmark (PT
, PT_BYTE
);
251 clip_to_bounds (lower
, num
, upper
)
252 int lower
, num
, upper
;
256 else if (num
> upper
)
262 DEFUN ("goto-char", Fgoto_char
, Sgoto_char
, 1, 1, "NGoto char: ",
263 doc
: /* Set point to POSITION, a number or marker.
264 Beginning of buffer is position (point-min), end is (point-max). */)
266 register Lisp_Object position
;
270 if (MARKERP (position
)
271 && current_buffer
== XMARKER (position
)->buffer
)
273 pos
= marker_position (position
);
275 SET_PT_BOTH (BEGV
, BEGV_BYTE
);
277 SET_PT_BOTH (ZV
, ZV_BYTE
);
279 SET_PT_BOTH (pos
, marker_byte_position (position
));
284 CHECK_NUMBER_COERCE_MARKER (position
);
286 pos
= clip_to_bounds (BEGV
, XINT (position
), ZV
);
292 /* Return the start or end position of the region.
293 BEGINNINGP non-zero means return the start.
294 If there is no region active, signal an error. */
297 region_limit (beginningp
)
300 extern Lisp_Object Vmark_even_if_inactive
; /* Defined in callint.c. */
303 if (!NILP (Vtransient_mark_mode
)
304 && NILP (Vmark_even_if_inactive
)
305 && NILP (current_buffer
->mark_active
))
306 Fsignal (Qmark_inactive
, Qnil
);
308 m
= Fmarker_position (current_buffer
->mark
);
310 error ("The mark is not set now, so there is no region");
312 if ((PT
< XFASTINT (m
)) == (beginningp
!= 0))
313 m
= make_number (PT
);
317 DEFUN ("region-beginning", Fregion_beginning
, Sregion_beginning
, 0, 0, 0,
318 doc
: /* Return position of beginning of region, as an integer. */)
321 return region_limit (1);
324 DEFUN ("region-end", Fregion_end
, Sregion_end
, 0, 0, 0,
325 doc
: /* Return position of end of region, as an integer. */)
328 return region_limit (0);
331 DEFUN ("mark-marker", Fmark_marker
, Smark_marker
, 0, 0, 0,
332 doc
: /* Return this buffer's mark, as a marker object.
333 Watch out! Moving this marker changes the mark position.
334 If you set the marker not to point anywhere, the buffer will have no mark. */)
337 return current_buffer
->mark
;
341 /* Find all the overlays in the current buffer that touch position POS.
342 Return the number found, and store them in a vector in VEC
346 overlays_around (pos
, vec
, len
)
351 Lisp_Object overlay
, start
, end
;
352 struct Lisp_Overlay
*tail
;
353 int startpos
, endpos
;
356 for (tail
= current_buffer
->overlays_before
; tail
; tail
= tail
->next
)
358 XSETMISC (overlay
, tail
);
360 end
= OVERLAY_END (overlay
);
361 endpos
= OVERLAY_POSITION (end
);
364 start
= OVERLAY_START (overlay
);
365 startpos
= OVERLAY_POSITION (start
);
370 /* Keep counting overlays even if we can't return them all. */
375 for (tail
= current_buffer
->overlays_after
; tail
; tail
= tail
->next
)
377 XSETMISC (overlay
, tail
);
379 start
= OVERLAY_START (overlay
);
380 startpos
= OVERLAY_POSITION (start
);
383 end
= OVERLAY_END (overlay
);
384 endpos
= OVERLAY_POSITION (end
);
396 /* Return the value of property PROP, in OBJECT at POSITION.
397 It's the value of PROP that a char inserted at POSITION would get.
398 OBJECT is optional and defaults to the current buffer.
399 If OBJECT is a buffer, then overlay properties are considered as well as
401 If OBJECT is a window, then that window's buffer is used, but
402 window-specific overlays are considered only if they are associated
405 get_pos_property (position
, prop
, object
)
406 Lisp_Object position
, object
;
407 register Lisp_Object prop
;
409 CHECK_NUMBER_COERCE_MARKER (position
);
412 XSETBUFFER (object
, current_buffer
);
413 else if (WINDOWP (object
))
414 object
= XWINDOW (object
)->buffer
;
416 if (!BUFFERP (object
))
417 /* pos-property only makes sense in buffers right now, since strings
418 have no overlays and no notion of insertion for which stickiness
420 return Fget_text_property (position
, prop
, object
);
423 int posn
= XINT (position
);
425 Lisp_Object
*overlay_vec
, tem
;
426 struct buffer
*obuf
= current_buffer
;
428 set_buffer_temp (XBUFFER (object
));
430 /* First try with room for 40 overlays. */
432 overlay_vec
= (Lisp_Object
*) alloca (noverlays
* sizeof (Lisp_Object
));
433 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
435 /* If there are more than 40,
436 make enough space for all, and try again. */
439 overlay_vec
= (Lisp_Object
*) alloca (noverlays
* sizeof (Lisp_Object
));
440 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
442 noverlays
= sort_overlays (overlay_vec
, noverlays
, NULL
);
444 set_buffer_temp (obuf
);
446 /* Now check the overlays in order of decreasing priority. */
447 while (--noverlays
>= 0)
449 Lisp_Object ol
= overlay_vec
[noverlays
];
450 tem
= Foverlay_get (ol
, prop
);
453 /* Check the overlay is indeed active at point. */
454 Lisp_Object start
= OVERLAY_START (ol
), finish
= OVERLAY_END (ol
);
455 if ((OVERLAY_POSITION (start
) == posn
456 && XMARKER (start
)->insertion_type
== 1)
457 || (OVERLAY_POSITION (finish
) == posn
458 && XMARKER (finish
)->insertion_type
== 0))
459 ; /* The overlay will not cover a char inserted at point. */
467 { /* Now check the text-properties. */
468 int stickiness
= text_property_stickiness (prop
, position
, object
);
470 return Fget_text_property (position
, prop
, object
);
471 else if (stickiness
< 0
472 && XINT (position
) > BUF_BEGV (XBUFFER (object
)))
473 return Fget_text_property (make_number (XINT (position
) - 1),
481 /* Find the field surrounding POS in *BEG and *END. If POS is nil,
482 the value of point is used instead. If BEG or END null,
483 means don't store the beginning or end of the field.
485 BEG_LIMIT and END_LIMIT serve to limit the ranged of the returned
486 results; they do not effect boundary behavior.
488 If MERGE_AT_BOUNDARY is nonzero, then if POS is at the very first
489 position of a field, then the beginning of the previous field is
490 returned instead of the beginning of POS's field (since the end of a
491 field is actually also the beginning of the next input field, this
492 behavior is sometimes useful). Additionally in the MERGE_AT_BOUNDARY
493 true case, if two fields are separated by a field with the special
494 value `boundary', and POS lies within it, then the two separated
495 fields are considered to be adjacent, and POS between them, when
496 finding the beginning and ending of the "merged" field.
498 Either BEG or END may be 0, in which case the corresponding value
502 find_field (pos
, merge_at_boundary
, beg_limit
, beg
, end_limit
, end
)
504 Lisp_Object merge_at_boundary
;
505 Lisp_Object beg_limit
, end_limit
;
508 /* Fields right before and after the point. */
509 Lisp_Object before_field
, after_field
;
510 /* 1 if POS counts as the start of a field. */
511 int at_field_start
= 0;
512 /* 1 if POS counts as the end of a field. */
513 int at_field_end
= 0;
516 XSETFASTINT (pos
, PT
);
518 CHECK_NUMBER_COERCE_MARKER (pos
);
521 = get_char_property_and_overlay (pos
, Qfield
, Qnil
, NULL
);
523 = (XFASTINT (pos
) > BEGV
524 ? get_char_property_and_overlay (make_number (XINT (pos
) - 1),
528 /* See if we need to handle the case where MERGE_AT_BOUNDARY is nil
529 and POS is at beginning of a field, which can also be interpreted
530 as the end of the previous field. Note that the case where if
531 MERGE_AT_BOUNDARY is non-nil (see function comment) is actually the
532 more natural one; then we avoid treating the beginning of a field
534 if (NILP (merge_at_boundary
))
536 Lisp_Object field
= get_pos_property (pos
, Qfield
, Qnil
);
537 if (!EQ (field
, after_field
))
539 if (!EQ (field
, before_field
))
541 if (NILP (field
) && at_field_start
&& at_field_end
)
542 /* If an inserted char would have a nil field while the surrounding
543 text is non-nil, we're probably not looking at a
544 zero-length field, but instead at a non-nil field that's
545 not intended for editing (such as comint's prompts). */
546 at_field_end
= at_field_start
= 0;
549 /* Note about special `boundary' fields:
551 Consider the case where the point (`.') is between the fields `x' and `y':
555 In this situation, if merge_at_boundary is true, we consider the
556 `x' and `y' fields as forming one big merged field, and so the end
557 of the field is the end of `y'.
559 However, if `x' and `y' are separated by a special `boundary' field
560 (a field with a `field' char-property of 'boundary), then we ignore
561 this special field when merging adjacent fields. Here's the same
562 situation, but with a `boundary' field between the `x' and `y' fields:
566 Here, if point is at the end of `x', the beginning of `y', or
567 anywhere in-between (within the `boundary' field), we merge all
568 three fields and consider the beginning as being the beginning of
569 the `x' field, and the end as being the end of the `y' field. */
574 /* POS is at the edge of a field, and we should consider it as
575 the beginning of the following field. */
576 *beg
= XFASTINT (pos
);
578 /* Find the previous field boundary. */
581 if (!NILP (merge_at_boundary
) && EQ (before_field
, Qboundary
))
582 /* Skip a `boundary' field. */
583 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
586 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
588 *beg
= NILP (p
) ? BEGV
: XFASTINT (p
);
595 /* POS is at the edge of a field, and we should consider it as
596 the end of the previous field. */
597 *end
= XFASTINT (pos
);
599 /* Find the next field boundary. */
601 if (!NILP (merge_at_boundary
) && EQ (after_field
, Qboundary
))
602 /* Skip a `boundary' field. */
603 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
606 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
608 *end
= NILP (pos
) ? ZV
: XFASTINT (pos
);
614 DEFUN ("delete-field", Fdelete_field
, Sdelete_field
, 0, 1, 0,
615 doc
: /* Delete the field surrounding POS.
616 A field is a region of text with the same `field' property.
617 If POS is nil, the value of point is used for POS. */)
622 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
624 del_range (beg
, end
);
628 DEFUN ("field-string", Ffield_string
, Sfield_string
, 0, 1, 0,
629 doc
: /* Return the contents of the field surrounding POS as a string.
630 A field is a region of text with the same `field' property.
631 If POS is nil, the value of point is used for POS. */)
636 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
637 return make_buffer_string (beg
, end
, 1);
640 DEFUN ("field-string-no-properties", Ffield_string_no_properties
, Sfield_string_no_properties
, 0, 1, 0,
641 doc
: /* Return the contents of the field around POS, without text-properties.
642 A field is a region of text with the same `field' property.
643 If POS is nil, the value of point is used for POS. */)
648 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
649 return make_buffer_string (beg
, end
, 0);
652 DEFUN ("field-beginning", Ffield_beginning
, Sfield_beginning
, 0, 3, 0,
653 doc
: /* Return the beginning of the field surrounding POS.
654 A field is a region of text with the same `field' property.
655 If POS is nil, the value of point is used for POS.
656 If ESCAPE-FROM-EDGE is non-nil and POS is at the beginning of its
657 field, then the beginning of the *previous* field is returned.
658 If LIMIT is non-nil, it is a buffer position; if the beginning of the field
659 is before LIMIT, then LIMIT will be returned instead. */)
660 (pos
, escape_from_edge
, limit
)
661 Lisp_Object pos
, escape_from_edge
, limit
;
664 find_field (pos
, escape_from_edge
, limit
, &beg
, Qnil
, 0);
665 return make_number (beg
);
668 DEFUN ("field-end", Ffield_end
, Sfield_end
, 0, 3, 0,
669 doc
: /* Return the end of the field surrounding POS.
670 A field is a region of text with the same `field' property.
671 If POS is nil, the value of point is used for POS.
672 If ESCAPE-FROM-EDGE is non-nil and POS is at the end of its field,
673 then the end of the *following* field is returned.
674 If LIMIT is non-nil, it is a buffer position; if the end of the field
675 is after LIMIT, then LIMIT will be returned instead. */)
676 (pos
, escape_from_edge
, limit
)
677 Lisp_Object pos
, escape_from_edge
, limit
;
680 find_field (pos
, escape_from_edge
, Qnil
, 0, limit
, &end
);
681 return make_number (end
);
684 DEFUN ("constrain-to-field", Fconstrain_to_field
, Sconstrain_to_field
, 2, 5, 0,
685 doc
: /* Return the position closest to NEW-POS that is in the same field as OLD-POS.
687 A field is a region of text with the same `field' property.
688 If NEW-POS is nil, then the current point is used instead, and set to the
689 constrained position if that is different.
691 If OLD-POS is at the boundary of two fields, then the allowable
692 positions for NEW-POS depends on the value of the optional argument
693 ESCAPE-FROM-EDGE: If ESCAPE-FROM-EDGE is nil, then NEW-POS is
694 constrained to the field that has the same `field' char-property
695 as any new characters inserted at OLD-POS, whereas if ESCAPE-FROM-EDGE
696 is non-nil, NEW-POS is constrained to the union of the two adjacent
697 fields. Additionally, if two fields are separated by another field with
698 the special value `boundary', then any point within this special field is
699 also considered to be `on the boundary'.
701 If the optional argument ONLY-IN-LINE is non-nil and constraining
702 NEW-POS would move it to a different line, NEW-POS is returned
703 unconstrained. This useful for commands that move by line, like
704 \\[next-line] or \\[beginning-of-line], which should generally respect field boundaries
705 only in the case where they can still move to the right line.
707 If the optional argument INHIBIT-CAPTURE-PROPERTY is non-nil, and OLD-POS has
708 a non-nil property of that name, then any field boundaries are ignored.
710 Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */)
711 (new_pos
, old_pos
, escape_from_edge
, only_in_line
, inhibit_capture_property
)
712 Lisp_Object new_pos
, old_pos
;
713 Lisp_Object escape_from_edge
, only_in_line
, inhibit_capture_property
;
715 /* If non-zero, then the original point, before re-positioning. */
719 /* Use the current point, and afterwards, set it. */
722 XSETFASTINT (new_pos
, PT
);
725 if (NILP (Vinhibit_field_text_motion
)
726 && !EQ (new_pos
, old_pos
)
727 && (!NILP (Fget_char_property (new_pos
, Qfield
, Qnil
))
728 || !NILP (Fget_char_property (old_pos
, Qfield
, Qnil
)))
729 && (NILP (inhibit_capture_property
)
730 || NILP (Fget_char_property(old_pos
, inhibit_capture_property
, Qnil
))))
731 /* NEW_POS is not within the same field as OLD_POS; try to
732 move NEW_POS so that it is. */
735 Lisp_Object field_bound
;
737 CHECK_NUMBER_COERCE_MARKER (new_pos
);
738 CHECK_NUMBER_COERCE_MARKER (old_pos
);
740 fwd
= (XFASTINT (new_pos
) > XFASTINT (old_pos
));
743 field_bound
= Ffield_end (old_pos
, escape_from_edge
, new_pos
);
745 field_bound
= Ffield_beginning (old_pos
, escape_from_edge
, new_pos
);
747 if (/* See if ESCAPE_FROM_EDGE caused FIELD_BOUND to jump to the
748 other side of NEW_POS, which would mean that NEW_POS is
749 already acceptable, and it's not necessary to constrain it
751 ((XFASTINT (field_bound
) < XFASTINT (new_pos
)) ? fwd
: !fwd
)
752 /* NEW_POS should be constrained, but only if either
753 ONLY_IN_LINE is nil (in which case any constraint is OK),
754 or NEW_POS and FIELD_BOUND are on the same line (in which
755 case the constraint is OK even if ONLY_IN_LINE is non-nil). */
756 && (NILP (only_in_line
)
757 /* This is the ONLY_IN_LINE case, check that NEW_POS and
758 FIELD_BOUND are on the same line by seeing whether
759 there's an intervening newline or not. */
760 || (scan_buffer ('\n',
761 XFASTINT (new_pos
), XFASTINT (field_bound
),
762 fwd
? -1 : 1, &shortage
, 1),
764 /* Constrain NEW_POS to FIELD_BOUND. */
765 new_pos
= field_bound
;
767 if (orig_point
&& XFASTINT (new_pos
) != orig_point
)
768 /* The NEW_POS argument was originally nil, so automatically set PT. */
769 SET_PT (XFASTINT (new_pos
));
776 DEFUN ("line-beginning-position",
777 Fline_beginning_position
, Sline_beginning_position
, 0, 1, 0,
778 doc
: /* Return the character position of the first character on the current line.
779 With argument N not nil or 1, move forward N - 1 lines first.
780 If scan reaches end of buffer, return that position.
782 The scan does not cross a field boundary unless doing so would move
783 beyond there to a different line; if N is nil or 1, and scan starts at a
784 field boundary, the scan stops as soon as it starts. To ignore field
785 boundaries bind `inhibit-field-text-motion' to t.
787 This function does not move point. */)
791 int orig
, orig_byte
, end
;
800 Fforward_line (make_number (XINT (n
) - 1));
803 SET_PT_BOTH (orig
, orig_byte
);
805 /* Return END constrained to the current input field. */
806 return Fconstrain_to_field (make_number (end
), make_number (orig
),
807 XINT (n
) != 1 ? Qt
: Qnil
,
811 DEFUN ("line-end-position", Fline_end_position
, Sline_end_position
, 0, 1, 0,
812 doc
: /* Return the character position of the last character on the current line.
813 With argument N not nil or 1, move forward N - 1 lines first.
814 If scan reaches end of buffer, return that position.
816 The scan does not cross a field boundary unless doing so would move
817 beyond there to a different line; if N is nil or 1, and scan starts at a
818 field boundary, the scan stops as soon as it starts. To ignore field
819 boundaries bind `inhibit-field-text-motion' to t.
821 This function does not move point. */)
833 end_pos
= find_before_next_newline (orig
, 0, XINT (n
) - (XINT (n
) <= 0));
835 /* Return END_POS constrained to the current input field. */
836 return Fconstrain_to_field (make_number (end_pos
), make_number (orig
),
842 save_excursion_save ()
844 int visible
= (XBUFFER (XWINDOW (selected_window
)->buffer
)
847 return Fcons (Fpoint_marker (),
848 Fcons (Fcopy_marker (current_buffer
->mark
, Qnil
),
849 Fcons (visible
? Qt
: Qnil
,
850 Fcons (current_buffer
->mark_active
,
855 save_excursion_restore (info
)
858 Lisp_Object tem
, tem1
, omark
, nmark
;
859 struct gcpro gcpro1
, gcpro2
, gcpro3
;
862 tem
= Fmarker_buffer (XCAR (info
));
863 /* If buffer being returned to is now deleted, avoid error */
864 /* Otherwise could get error here while unwinding to top level
866 /* In that case, Fmarker_buffer returns nil now. */
870 omark
= nmark
= Qnil
;
871 GCPRO3 (info
, omark
, nmark
);
878 unchain_marker (XMARKER (tem
));
883 omark
= Fmarker_position (current_buffer
->mark
);
884 Fset_marker (current_buffer
->mark
, tem
, Fcurrent_buffer ());
885 nmark
= Fmarker_position (tem
);
886 unchain_marker (XMARKER (tem
));
890 visible_p
= !NILP (XCAR (info
));
892 #if 0 /* We used to make the current buffer visible in the selected window
893 if that was true previously. That avoids some anomalies.
894 But it creates others, and it wasn't documented, and it is simpler
895 and cleaner never to alter the window/buffer connections. */
898 && current_buffer
!= XBUFFER (XWINDOW (selected_window
)->buffer
))
899 Fswitch_to_buffer (Fcurrent_buffer (), Qnil
);
905 tem1
= current_buffer
->mark_active
;
906 current_buffer
->mark_active
= tem
;
908 if (!NILP (Vrun_hooks
))
910 /* If mark is active now, and either was not active
911 or was at a different place, run the activate hook. */
912 if (! NILP (current_buffer
->mark_active
))
914 if (! EQ (omark
, nmark
))
915 call1 (Vrun_hooks
, intern ("activate-mark-hook"));
917 /* If mark has ceased to be active, run deactivate hook. */
918 else if (! NILP (tem1
))
919 call1 (Vrun_hooks
, intern ("deactivate-mark-hook"));
922 /* If buffer was visible in a window, and a different window was
923 selected, and the old selected window is still showing this
924 buffer, restore point in that window. */
927 && !EQ (tem
, selected_window
)
928 && (tem1
= XWINDOW (tem
)->buffer
,
929 (/* Window is live... */
931 /* ...and it shows the current buffer. */
932 && XBUFFER (tem1
) == current_buffer
)))
933 Fset_window_point (tem
, make_number (PT
));
939 DEFUN ("save-excursion", Fsave_excursion
, Ssave_excursion
, 0, UNEVALLED
, 0,
940 doc
: /* Save point, mark, and current buffer; execute BODY; restore those things.
941 Executes BODY just like `progn'.
942 The values of point, mark and the current buffer are restored
943 even in case of abnormal exit (throw or error).
944 The state of activation of the mark is also restored.
946 This construct does not save `deactivate-mark', and therefore
947 functions that change the buffer will still cause deactivation
948 of the mark at the end of the command. To prevent that, bind
949 `deactivate-mark' with `let'.
951 usage: (save-excursion &rest BODY) */)
955 register Lisp_Object val
;
956 int count
= SPECPDL_INDEX ();
958 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
961 return unbind_to (count
, val
);
964 DEFUN ("save-current-buffer", Fsave_current_buffer
, Ssave_current_buffer
, 0, UNEVALLED
, 0,
965 doc
: /* Save the current buffer; execute BODY; restore the current buffer.
966 Executes BODY just like `progn'.
967 usage: (save-current-buffer &rest BODY) */)
972 int count
= SPECPDL_INDEX ();
974 record_unwind_protect (set_buffer_if_live
, Fcurrent_buffer ());
977 return unbind_to (count
, val
);
980 DEFUN ("buffer-size", Fbufsize
, Sbufsize
, 0, 1, 0,
981 doc
: /* Return the number of characters in the current buffer.
982 If BUFFER, return the number of characters in that buffer instead. */)
987 return make_number (Z
- BEG
);
990 CHECK_BUFFER (buffer
);
991 return make_number (BUF_Z (XBUFFER (buffer
))
992 - BUF_BEG (XBUFFER (buffer
)));
996 DEFUN ("point-min", Fpoint_min
, Spoint_min
, 0, 0, 0,
997 doc
: /* Return the minimum permissible value of point in the current buffer.
998 This is 1, unless narrowing (a buffer restriction) is in effect. */)
1002 XSETFASTINT (temp
, BEGV
);
1006 DEFUN ("point-min-marker", Fpoint_min_marker
, Spoint_min_marker
, 0, 0, 0,
1007 doc
: /* Return a marker to the minimum permissible value of point in this buffer.
1008 This is the beginning, unless narrowing (a buffer restriction) is in effect. */)
1011 return buildmark (BEGV
, BEGV_BYTE
);
1014 DEFUN ("point-max", Fpoint_max
, Spoint_max
, 0, 0, 0,
1015 doc
: /* Return the maximum permissible value of point in the current buffer.
1016 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1017 is in effect, in which case it is less. */)
1021 XSETFASTINT (temp
, ZV
);
1025 DEFUN ("point-max-marker", Fpoint_max_marker
, Spoint_max_marker
, 0, 0, 0,
1026 doc
: /* Return a marker to the maximum permissible value of point in this buffer.
1027 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1028 is in effect, in which case it is less. */)
1031 return buildmark (ZV
, ZV_BYTE
);
1034 DEFUN ("gap-position", Fgap_position
, Sgap_position
, 0, 0, 0,
1035 doc
: /* Return the position of the gap, in the current buffer.
1036 See also `gap-size'. */)
1040 XSETFASTINT (temp
, GPT
);
1044 DEFUN ("gap-size", Fgap_size
, Sgap_size
, 0, 0, 0,
1045 doc
: /* Return the size of the current buffer's gap.
1046 See also `gap-position'. */)
1050 XSETFASTINT (temp
, GAP_SIZE
);
1054 DEFUN ("position-bytes", Fposition_bytes
, Sposition_bytes
, 1, 1, 0,
1055 doc
: /* Return the byte position for character position POSITION.
1056 If POSITION is out of range, the value is nil. */)
1058 Lisp_Object position
;
1060 CHECK_NUMBER_COERCE_MARKER (position
);
1061 if (XINT (position
) < BEG
|| XINT (position
) > Z
)
1063 return make_number (CHAR_TO_BYTE (XINT (position
)));
1066 DEFUN ("byte-to-position", Fbyte_to_position
, Sbyte_to_position
, 1, 1, 0,
1067 doc
: /* Return the character position for byte position BYTEPOS.
1068 If BYTEPOS is out of range, the value is nil. */)
1070 Lisp_Object bytepos
;
1072 CHECK_NUMBER (bytepos
);
1073 if (XINT (bytepos
) < BEG_BYTE
|| XINT (bytepos
) > Z_BYTE
)
1075 return make_number (BYTE_TO_CHAR (XINT (bytepos
)));
1078 DEFUN ("following-char", Ffollowing_char
, Sfollowing_char
, 0, 0, 0,
1079 doc
: /* Return the character following point, as a number.
1080 At the end of the buffer or accessible region, return 0. */)
1085 XSETFASTINT (temp
, 0);
1087 XSETFASTINT (temp
, FETCH_CHAR (PT_BYTE
));
1091 DEFUN ("preceding-char", Fprevious_char
, Sprevious_char
, 0, 0, 0,
1092 doc
: /* Return the character preceding point, as a number.
1093 At the beginning of the buffer or accessible region, return 0. */)
1098 XSETFASTINT (temp
, 0);
1099 else if (!NILP (current_buffer
->enable_multibyte_characters
))
1103 XSETFASTINT (temp
, FETCH_CHAR (pos
));
1106 XSETFASTINT (temp
, FETCH_BYTE (PT_BYTE
- 1));
1110 DEFUN ("bobp", Fbobp
, Sbobp
, 0, 0, 0,
1111 doc
: /* Return t if point is at the beginning of the buffer.
1112 If the buffer is narrowed, this means the beginning of the narrowed part. */)
1120 DEFUN ("eobp", Feobp
, Seobp
, 0, 0, 0,
1121 doc
: /* Return t if point is at the end of the buffer.
1122 If the buffer is narrowed, this means the end of the narrowed part. */)
1130 DEFUN ("bolp", Fbolp
, Sbolp
, 0, 0, 0,
1131 doc
: /* Return t if point is at the beginning of a line. */)
1134 if (PT
== BEGV
|| FETCH_BYTE (PT_BYTE
- 1) == '\n')
1139 DEFUN ("eolp", Feolp
, Seolp
, 0, 0, 0,
1140 doc
: /* Return t if point is at the end of a line.
1141 `End of a line' includes point being at the end of the buffer. */)
1144 if (PT
== ZV
|| FETCH_BYTE (PT_BYTE
) == '\n')
1149 DEFUN ("char-after", Fchar_after
, Schar_after
, 0, 1, 0,
1150 doc
: /* Return character in current buffer at position POS.
1151 POS is an integer or a marker and defaults to point.
1152 If POS is out of range, the value is nil. */)
1156 register int pos_byte
;
1161 XSETFASTINT (pos
, PT
);
1166 pos_byte
= marker_byte_position (pos
);
1167 if (pos_byte
< BEGV_BYTE
|| pos_byte
>= ZV_BYTE
)
1172 CHECK_NUMBER_COERCE_MARKER (pos
);
1173 if (XINT (pos
) < BEGV
|| XINT (pos
) >= ZV
)
1176 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1179 return make_number (FETCH_CHAR (pos_byte
));
1182 DEFUN ("char-before", Fchar_before
, Schar_before
, 0, 1, 0,
1183 doc
: /* Return character in current buffer preceding position POS.
1184 POS is an integer or a marker and defaults to point.
1185 If POS is out of range, the value is nil. */)
1189 register Lisp_Object val
;
1190 register int pos_byte
;
1195 XSETFASTINT (pos
, PT
);
1200 pos_byte
= marker_byte_position (pos
);
1202 if (pos_byte
<= BEGV_BYTE
|| pos_byte
> ZV_BYTE
)
1207 CHECK_NUMBER_COERCE_MARKER (pos
);
1209 if (XINT (pos
) <= BEGV
|| XINT (pos
) > ZV
)
1212 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1215 if (!NILP (current_buffer
->enable_multibyte_characters
))
1218 XSETFASTINT (val
, FETCH_CHAR (pos_byte
));
1223 XSETFASTINT (val
, FETCH_BYTE (pos_byte
));
1228 DEFUN ("user-login-name", Fuser_login_name
, Suser_login_name
, 0, 1, 0,
1229 doc
: /* Return the name under which the user logged in, as a string.
1230 This is based on the effective uid, not the real uid.
1231 Also, if the environment variables LOGNAME or USER are set,
1232 that determines the value of this function.
1234 If optional argument UID is an integer, return the login name of the user
1235 with that uid, or nil if there is no such user. */)
1241 /* Set up the user name info if we didn't do it before.
1242 (That can happen if Emacs is dumpable
1243 but you decide to run `temacs -l loadup' and not dump. */
1244 if (INTEGERP (Vuser_login_name
))
1248 return Vuser_login_name
;
1251 pw
= (struct passwd
*) getpwuid (XINT (uid
));
1252 return (pw
? build_string (pw
->pw_name
) : Qnil
);
1255 DEFUN ("user-real-login-name", Fuser_real_login_name
, Suser_real_login_name
,
1257 doc
: /* Return the name of the user's real uid, as a string.
1258 This ignores the environment variables LOGNAME and USER, so it differs from
1259 `user-login-name' when running under `su'. */)
1262 /* Set up the user name info if we didn't do it before.
1263 (That can happen if Emacs is dumpable
1264 but you decide to run `temacs -l loadup' and not dump. */
1265 if (INTEGERP (Vuser_login_name
))
1267 return Vuser_real_login_name
;
1270 DEFUN ("user-uid", Fuser_uid
, Suser_uid
, 0, 0, 0,
1271 doc
: /* Return the effective uid of Emacs.
1272 Value is an integer or float, depending on the value. */)
1275 return make_fixnum_or_float (geteuid ());
1278 DEFUN ("user-real-uid", Fuser_real_uid
, Suser_real_uid
, 0, 0, 0,
1279 doc
: /* Return the real uid of Emacs.
1280 Value is an integer or float, depending on the value. */)
1283 return make_fixnum_or_float (getuid ());
1286 DEFUN ("user-full-name", Fuser_full_name
, Suser_full_name
, 0, 1, 0,
1287 doc
: /* Return the full name of the user logged in, as a string.
1288 If the full name corresponding to Emacs's userid is not known,
1291 If optional argument UID is an integer or float, return the full name
1292 of the user with that uid, or nil if there is no such user.
1293 If UID is a string, return the full name of the user with that login
1294 name, or nil if there is no such user. */)
1299 register unsigned char *p
, *q
;
1303 return Vuser_full_name
;
1304 else if (NUMBERP (uid
))
1305 pw
= (struct passwd
*) getpwuid ((uid_t
) XFLOATINT (uid
));
1306 else if (STRINGP (uid
))
1307 pw
= (struct passwd
*) getpwnam (SDATA (uid
));
1309 error ("Invalid UID specification");
1314 p
= (unsigned char *) USER_FULL_NAME
;
1315 /* Chop off everything after the first comma. */
1316 q
= (unsigned char *) index (p
, ',');
1317 full
= make_string (p
, q
? q
- p
: strlen (p
));
1319 #ifdef AMPERSAND_FULL_NAME
1321 q
= (unsigned char *) index (p
, '&');
1322 /* Substitute the login name for the &, upcasing the first character. */
1325 register unsigned char *r
;
1328 login
= Fuser_login_name (make_number (pw
->pw_uid
));
1329 r
= (unsigned char *) alloca (strlen (p
) + SCHARS (login
) + 1);
1330 bcopy (p
, r
, q
- p
);
1332 strcat (r
, SDATA (login
));
1333 r
[q
- p
] = UPCASE (r
[q
- p
]);
1335 full
= build_string (r
);
1337 #endif /* AMPERSAND_FULL_NAME */
1342 DEFUN ("system-name", Fsystem_name
, Ssystem_name
, 0, 0, 0,
1343 doc
: /* Return the name of the machine you are running on, as a string. */)
1346 return Vsystem_name
;
1349 /* For the benefit of callers who don't want to include lisp.h */
1354 if (STRINGP (Vsystem_name
))
1355 return (char *) SDATA (Vsystem_name
);
1361 get_operating_system_release()
1363 if (STRINGP (Voperating_system_release
))
1364 return (char *) SDATA (Voperating_system_release
);
1369 DEFUN ("emacs-pid", Femacs_pid
, Semacs_pid
, 0, 0, 0,
1370 doc
: /* Return the process ID of Emacs, as an integer. */)
1373 return make_number (getpid ());
1376 DEFUN ("current-time", Fcurrent_time
, Scurrent_time
, 0, 0, 0,
1377 doc
: /* Return the current time, as the number of seconds since 1970-01-01 00:00:00.
1378 The time is returned as a list of three integers. The first has the
1379 most significant 16 bits of the seconds, while the second has the
1380 least significant 16 bits. The third integer gives the microsecond
1383 The microsecond count is zero on systems that do not provide
1384 resolution finer than a second. */)
1388 Lisp_Object result
[3];
1391 XSETINT (result
[0], (EMACS_SECS (t
) >> 16) & 0xffff);
1392 XSETINT (result
[1], (EMACS_SECS (t
) >> 0) & 0xffff);
1393 XSETINT (result
[2], EMACS_USECS (t
));
1395 return Flist (3, result
);
1398 DEFUN ("get-internal-run-time", Fget_internal_run_time
, Sget_internal_run_time
,
1400 doc
: /* Return the current run time used by Emacs.
1401 The time is returned as a list of three integers. The first has the
1402 most significant 16 bits of the seconds, while the second has the
1403 least significant 16 bits. The third integer gives the microsecond
1406 On systems that can't determine the run time, get-internal-run-time
1407 does the same thing as current-time. The microsecond count is zero on
1408 systems that do not provide resolution finer than a second. */)
1411 #ifdef HAVE_GETRUSAGE
1412 struct rusage usage
;
1413 Lisp_Object result
[3];
1416 if (getrusage (RUSAGE_SELF
, &usage
) < 0)
1417 /* This shouldn't happen. What action is appropriate? */
1418 Fsignal (Qerror
, Qnil
);
1420 /* Sum up user time and system time. */
1421 secs
= usage
.ru_utime
.tv_sec
+ usage
.ru_stime
.tv_sec
;
1422 usecs
= usage
.ru_utime
.tv_usec
+ usage
.ru_stime
.tv_usec
;
1423 if (usecs
>= 1000000)
1429 XSETINT (result
[0], (secs
>> 16) & 0xffff);
1430 XSETINT (result
[1], (secs
>> 0) & 0xffff);
1431 XSETINT (result
[2], usecs
);
1433 return Flist (3, result
);
1435 return Fcurrent_time ();
1441 lisp_time_argument (specified_time
, result
, usec
)
1442 Lisp_Object specified_time
;
1446 if (NILP (specified_time
))
1453 *usec
= EMACS_USECS (t
);
1454 *result
= EMACS_SECS (t
);
1458 return time (result
) != -1;
1462 Lisp_Object high
, low
;
1463 high
= Fcar (specified_time
);
1464 CHECK_NUMBER (high
);
1465 low
= Fcdr (specified_time
);
1470 Lisp_Object usec_l
= Fcdr (low
);
1472 usec_l
= Fcar (usec_l
);
1477 CHECK_NUMBER (usec_l
);
1478 *usec
= XINT (usec_l
);
1486 *result
= (XINT (high
) << 16) + (XINT (low
) & 0xffff);
1487 return *result
>> 16 == XINT (high
);
1491 DEFUN ("float-time", Ffloat_time
, Sfloat_time
, 0, 1, 0,
1492 doc
: /* Return the current time, as a float number of seconds since the epoch.
1493 If SPECIFIED-TIME is given, it is the time to convert to float
1494 instead of the current time. The argument should have the form
1495 (HIGH LOW . IGNORED). Thus, you can use times obtained from
1496 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
1497 have the form (HIGH . LOW), but this is considered obsolete.
1499 WARNING: Since the result is floating point, it may not be exact.
1500 Do not use this function if precise time stamps are required. */)
1502 Lisp_Object specified_time
;
1507 if (! lisp_time_argument (specified_time
, &sec
, &usec
))
1508 error ("Invalid time specification");
1510 return make_float ((sec
* 1e6
+ usec
) / 1e6
);
1513 /* Write information into buffer S of size MAXSIZE, according to the
1514 FORMAT of length FORMAT_LEN, using time information taken from *TP.
1515 Default to Universal Time if UT is nonzero, local time otherwise.
1516 Return the number of bytes written, not including the terminating
1517 '\0'. If S is NULL, nothing will be written anywhere; so to
1518 determine how many bytes would be written, use NULL for S and
1519 ((size_t) -1) for MAXSIZE.
1521 This function behaves like emacs_strftimeu, except it allows null
1524 emacs_memftimeu (s
, maxsize
, format
, format_len
, tp
, ut
)
1529 const struct tm
*tp
;
1534 /* Loop through all the null-terminated strings in the format
1535 argument. Normally there's just one null-terminated string, but
1536 there can be arbitrarily many, concatenated together, if the
1537 format contains '\0' bytes. emacs_strftimeu stops at the first
1538 '\0' byte so we must invoke it separately for each such string. */
1547 result
= emacs_strftimeu (s
, maxsize
, format
, tp
, ut
);
1551 if (result
== 0 && s
[0] != '\0')
1556 maxsize
-= result
+ 1;
1558 len
= strlen (format
);
1559 if (len
== format_len
)
1563 format_len
-= len
+ 1;
1567 DEFUN ("format-time-string", Fformat_time_string
, Sformat_time_string
, 1, 3, 0,
1568 doc
: /* Use FORMAT-STRING to format the time TIME, or now if omitted.
1569 TIME is specified as (HIGH LOW . IGNORED), as returned by
1570 `current-time' or `file-attributes'. The obsolete form (HIGH . LOW)
1571 is also still accepted.
1572 The third, optional, argument UNIVERSAL, if non-nil, means describe TIME
1573 as Universal Time; nil means describe TIME in the local time zone.
1574 The value is a copy of FORMAT-STRING, but with certain constructs replaced
1575 by text that describes the specified date and time in TIME:
1577 %Y is the year, %y within the century, %C the century.
1578 %G is the year corresponding to the ISO week, %g within the century.
1579 %m is the numeric month.
1580 %b and %h are the locale's abbreviated month name, %B the full name.
1581 %d is the day of the month, zero-padded, %e is blank-padded.
1582 %u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.
1583 %a is the locale's abbreviated name of the day of week, %A the full name.
1584 %U is the week number starting on Sunday, %W starting on Monday,
1585 %V according to ISO 8601.
1586 %j is the day of the year.
1588 %H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H
1589 only blank-padded, %l is like %I blank-padded.
1590 %p is the locale's equivalent of either AM or PM.
1593 %Z is the time zone name, %z is the numeric form.
1594 %s is the number of seconds since 1970-01-01 00:00:00 +0000.
1596 %c is the locale's date and time format.
1597 %x is the locale's "preferred" date format.
1598 %D is like "%m/%d/%y".
1600 %R is like "%H:%M", %T is like "%H:%M:%S", %r is like "%I:%M:%S %p".
1601 %X is the locale's "preferred" time format.
1603 Finally, %n is a newline, %t is a tab, %% is a literal %.
1605 Certain flags and modifiers are available with some format controls.
1606 The flags are `_', `-', `^' and `#'. For certain characters X,
1607 %_X is like %X, but padded with blanks; %-X is like %X,
1608 but without padding. %^X is like %X, but with all textual
1609 characters up-cased; %#X is like %X, but with letter-case of
1610 all textual characters reversed.
1611 %NX (where N stands for an integer) is like %X,
1612 but takes up at least N (a number) positions.
1613 The modifiers are `E' and `O'. For certain characters X,
1614 %EX is a locale's alternative version of %X;
1615 %OX is like %X, but uses the locale's number symbols.
1617 For example, to produce full ISO 8601 format, use "%Y-%m-%dT%T%z". */)
1618 (format_string
, time
, universal
)
1619 Lisp_Object format_string
, time
, universal
;
1624 int ut
= ! NILP (universal
);
1626 CHECK_STRING (format_string
);
1628 if (! lisp_time_argument (time
, &value
, NULL
))
1629 error ("Invalid time specification");
1631 format_string
= code_convert_string_norecord (format_string
,
1632 Vlocale_coding_system
, 1);
1634 /* This is probably enough. */
1635 size
= SBYTES (format_string
) * 6 + 50;
1637 tm
= ut
? gmtime (&value
) : localtime (&value
);
1639 error ("Specified time is not representable");
1641 synchronize_system_time_locale ();
1645 char *buf
= (char *) alloca (size
+ 1);
1649 result
= emacs_memftimeu (buf
, size
, SDATA (format_string
),
1650 SBYTES (format_string
),
1652 if ((result
> 0 && result
< size
) || (result
== 0 && buf
[0] == '\0'))
1653 return code_convert_string_norecord (make_string (buf
, result
),
1654 Vlocale_coding_system
, 0);
1656 /* If buffer was too small, make it bigger and try again. */
1657 result
= emacs_memftimeu (NULL
, (size_t) -1,
1658 SDATA (format_string
),
1659 SBYTES (format_string
),
1665 DEFUN ("decode-time", Fdecode_time
, Sdecode_time
, 0, 1, 0,
1666 doc
: /* Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST ZONE).
1667 The optional SPECIFIED-TIME should be a list of (HIGH LOW . IGNORED),
1668 as from `current-time' and `file-attributes', or `nil' to use the
1669 current time. The obsolete form (HIGH . LOW) is also still accepted.
1670 The list has the following nine members: SEC is an integer between 0
1671 and 60; SEC is 60 for a leap second, which only some operating systems
1672 support. MINUTE is an integer between 0 and 59. HOUR is an integer
1673 between 0 and 23. DAY is an integer between 1 and 31. MONTH is an
1674 integer between 1 and 12. YEAR is an integer indicating the
1675 four-digit year. DOW is the day of week, an integer between 0 and 6,
1676 where 0 is Sunday. DST is t if daylight savings time is effect,
1677 otherwise nil. ZONE is an integer indicating the number of seconds
1678 east of Greenwich. (Note that Common Lisp has different meanings for
1681 Lisp_Object specified_time
;
1685 struct tm
*decoded_time
;
1686 Lisp_Object list_args
[9];
1688 if (! lisp_time_argument (specified_time
, &time_spec
, NULL
))
1689 error ("Invalid time specification");
1691 decoded_time
= localtime (&time_spec
);
1693 error ("Specified time is not representable");
1694 XSETFASTINT (list_args
[0], decoded_time
->tm_sec
);
1695 XSETFASTINT (list_args
[1], decoded_time
->tm_min
);
1696 XSETFASTINT (list_args
[2], decoded_time
->tm_hour
);
1697 XSETFASTINT (list_args
[3], decoded_time
->tm_mday
);
1698 XSETFASTINT (list_args
[4], decoded_time
->tm_mon
+ 1);
1699 XSETINT (list_args
[5], decoded_time
->tm_year
+ 1900);
1700 XSETFASTINT (list_args
[6], decoded_time
->tm_wday
);
1701 list_args
[7] = (decoded_time
->tm_isdst
)? Qt
: Qnil
;
1703 /* Make a copy, in case gmtime modifies the struct. */
1704 save_tm
= *decoded_time
;
1705 decoded_time
= gmtime (&time_spec
);
1706 if (decoded_time
== 0)
1707 list_args
[8] = Qnil
;
1709 XSETINT (list_args
[8], tm_diff (&save_tm
, decoded_time
));
1710 return Flist (9, list_args
);
1713 DEFUN ("encode-time", Fencode_time
, Sencode_time
, 6, MANY
, 0,
1714 doc
: /* Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.
1715 This is the reverse operation of `decode-time', which see.
1716 ZONE defaults to the current time zone rule. This can
1717 be a string or t (as from `set-time-zone-rule'), or it can be a list
1718 \(as from `current-time-zone') or an integer (as from `decode-time')
1719 applied without consideration for daylight savings time.
1721 You can pass more than 7 arguments; then the first six arguments
1722 are used as SECOND through YEAR, and the *last* argument is used as ZONE.
1723 The intervening arguments are ignored.
1724 This feature lets (apply 'encode-time (decode-time ...)) work.
1726 Out-of-range values for SECOND, MINUTE, HOUR, DAY, or MONTH are allowed;
1727 for example, a DAY of 0 means the day preceding the given month.
1728 Year numbers less than 100 are treated just like other year numbers.
1729 If you want them to stand for years in this century, you must do that yourself.
1731 Years before 1970 are not guaranteed to work. On some systems,
1732 year values as low as 1901 do work.
1734 usage: (encode-time SECOND MINUTE HOUR DAY MONTH YEAR &optional ZONE) */)
1737 register Lisp_Object
*args
;
1741 Lisp_Object zone
= (nargs
> 6 ? args
[nargs
- 1] : Qnil
);
1743 CHECK_NUMBER (args
[0]); /* second */
1744 CHECK_NUMBER (args
[1]); /* minute */
1745 CHECK_NUMBER (args
[2]); /* hour */
1746 CHECK_NUMBER (args
[3]); /* day */
1747 CHECK_NUMBER (args
[4]); /* month */
1748 CHECK_NUMBER (args
[5]); /* year */
1750 tm
.tm_sec
= XINT (args
[0]);
1751 tm
.tm_min
= XINT (args
[1]);
1752 tm
.tm_hour
= XINT (args
[2]);
1753 tm
.tm_mday
= XINT (args
[3]);
1754 tm
.tm_mon
= XINT (args
[4]) - 1;
1755 tm
.tm_year
= XINT (args
[5]) - 1900;
1761 time
= mktime (&tm
);
1766 char **oldenv
= environ
, **newenv
;
1770 else if (STRINGP (zone
))
1771 tzstring
= (char *) SDATA (zone
);
1772 else if (INTEGERP (zone
))
1774 int abszone
= abs (XINT (zone
));
1775 sprintf (tzbuf
, "XXX%s%d:%02d:%02d", "-" + (XINT (zone
) < 0),
1776 abszone
/ (60*60), (abszone
/60) % 60, abszone
% 60);
1780 error ("Invalid time zone specification");
1782 /* Set TZ before calling mktime; merely adjusting mktime's returned
1783 value doesn't suffice, since that would mishandle leap seconds. */
1784 set_time_zone_rule (tzstring
);
1786 time
= mktime (&tm
);
1788 /* Restore TZ to previous value. */
1792 #ifdef LOCALTIME_CACHE
1797 if (time
== (time_t) -1)
1798 error ("Specified time is not representable");
1800 return make_time (time
);
1803 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
, 0, 1, 0,
1804 doc
: /* Return the current time, as a human-readable string.
1805 Programs can use this function to decode a time,
1806 since the number of columns in each field is fixed.
1807 The format is `Sun Sep 16 01:03:52 1973'.
1808 However, see also the functions `decode-time' and `format-time-string'
1809 which provide a much more powerful and general facility.
1811 If SPECIFIED-TIME is given, it is a time to format instead of the
1812 current time. The argument should have the form (HIGH LOW . IGNORED).
1813 Thus, you can use times obtained from `current-time' and from
1814 `file-attributes'. SPECIFIED-TIME can also have the form (HIGH . LOW),
1815 but this is considered obsolete. */)
1817 Lisp_Object specified_time
;
1823 if (! lisp_time_argument (specified_time
, &value
, NULL
))
1825 tem
= (char *) ctime (&value
);
1827 strncpy (buf
, tem
, 24);
1830 return build_string (buf
);
1833 #define TM_YEAR_BASE 1900
1835 /* Yield A - B, measured in seconds.
1836 This function is copied from the GNU C Library. */
1841 /* Compute intervening leap days correctly even if year is negative.
1842 Take care to avoid int overflow in leap day calculations,
1843 but it's OK to assume that A and B are close to each other. */
1844 int a4
= (a
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (a
->tm_year
& 3);
1845 int b4
= (b
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (b
->tm_year
& 3);
1846 int a100
= a4
/ 25 - (a4
% 25 < 0);
1847 int b100
= b4
/ 25 - (b4
% 25 < 0);
1848 int a400
= a100
>> 2;
1849 int b400
= b100
>> 2;
1850 int intervening_leap_days
= (a4
- b4
) - (a100
- b100
) + (a400
- b400
);
1851 int years
= a
->tm_year
- b
->tm_year
;
1852 int days
= (365 * years
+ intervening_leap_days
1853 + (a
->tm_yday
- b
->tm_yday
));
1854 return (60 * (60 * (24 * days
+ (a
->tm_hour
- b
->tm_hour
))
1855 + (a
->tm_min
- b
->tm_min
))
1856 + (a
->tm_sec
- b
->tm_sec
));
1859 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 1, 0,
1860 doc
: /* Return the offset and name for the local time zone.
1861 This returns a list of the form (OFFSET NAME).
1862 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).
1863 A negative value means west of Greenwich.
1864 NAME is a string giving the name of the time zone.
1865 If SPECIFIED-TIME is given, the time zone offset is determined from it
1866 instead of using the current time. The argument should have the form
1867 (HIGH LOW . IGNORED). Thus, you can use times obtained from
1868 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
1869 have the form (HIGH . LOW), but this is considered obsolete.
1871 Some operating systems cannot provide all this information to Emacs;
1872 in this case, `current-time-zone' returns a list containing nil for
1873 the data it can't find. */)
1875 Lisp_Object specified_time
;
1881 if (lisp_time_argument (specified_time
, &value
, NULL
)
1882 && (t
= gmtime (&value
)) != 0
1883 && (gmt
= *t
, t
= localtime (&value
)) != 0)
1885 int offset
= tm_diff (t
, &gmt
);
1890 s
= (char *)t
->tm_zone
;
1891 #else /* not HAVE_TM_ZONE */
1893 if (t
->tm_isdst
== 0 || t
->tm_isdst
== 1)
1894 s
= tzname
[t
->tm_isdst
];
1896 #endif /* not HAVE_TM_ZONE */
1898 #if defined HAVE_TM_ZONE || defined HAVE_TZNAME
1901 /* On Japanese w32, we can get a Japanese string as time
1902 zone name. Don't accept that. */
1904 for (p
= s
; *p
&& (isalnum ((unsigned char)*p
) || *p
== ' '); ++p
)
1913 /* No local time zone name is available; use "+-NNNN" instead. */
1914 int am
= (offset
< 0 ? -offset
: offset
) / 60;
1915 sprintf (buf
, "%c%02d%02d", (offset
< 0 ? '-' : '+'), am
/60, am
%60);
1918 return Fcons (make_number (offset
), Fcons (build_string (s
), Qnil
));
1921 return Fmake_list (make_number (2), Qnil
);
1924 /* This holds the value of `environ' produced by the previous
1925 call to Fset_time_zone_rule, or 0 if Fset_time_zone_rule
1926 has never been called. */
1927 static char **environbuf
;
1929 DEFUN ("set-time-zone-rule", Fset_time_zone_rule
, Sset_time_zone_rule
, 1, 1, 0,
1930 doc
: /* Set the local time zone using TZ, a string specifying a time zone rule.
1931 If TZ is nil, use implementation-defined default time zone information.
1932 If TZ is t, use Universal Time. */)
1940 else if (EQ (tz
, Qt
))
1945 tzstring
= (char *) SDATA (tz
);
1948 set_time_zone_rule (tzstring
);
1951 environbuf
= environ
;
1956 #ifdef LOCALTIME_CACHE
1958 /* These two values are known to load tz files in buggy implementations,
1959 i.e. Solaris 1 executables running under either Solaris 1 or Solaris 2.
1960 Their values shouldn't matter in non-buggy implementations.
1961 We don't use string literals for these strings,
1962 since if a string in the environment is in readonly
1963 storage, it runs afoul of bugs in SVR4 and Solaris 2.3.
1964 See Sun bugs 1113095 and 1114114, ``Timezone routines
1965 improperly modify environment''. */
1967 static char set_time_zone_rule_tz1
[] = "TZ=GMT+0";
1968 static char set_time_zone_rule_tz2
[] = "TZ=GMT+1";
1972 /* Set the local time zone rule to TZSTRING.
1973 This allocates memory into `environ', which it is the caller's
1974 responsibility to free. */
1977 set_time_zone_rule (tzstring
)
1981 char **from
, **to
, **newenv
;
1983 /* Make the ENVIRON vector longer with room for TZSTRING. */
1984 for (from
= environ
; *from
; from
++)
1986 envptrs
= from
- environ
+ 2;
1987 newenv
= to
= (char **) xmalloc (envptrs
* sizeof (char *)
1988 + (tzstring
? strlen (tzstring
) + 4 : 0));
1990 /* Add TZSTRING to the end of environ, as a value for TZ. */
1993 char *t
= (char *) (to
+ envptrs
);
1995 strcat (t
, tzstring
);
1999 /* Copy the old environ vector elements into NEWENV,
2000 but don't copy the TZ variable.
2001 So we have only one definition of TZ, which came from TZSTRING. */
2002 for (from
= environ
; *from
; from
++)
2003 if (strncmp (*from
, "TZ=", 3) != 0)
2009 /* If we do have a TZSTRING, NEWENV points to the vector slot where
2010 the TZ variable is stored. If we do not have a TZSTRING,
2011 TO points to the vector slot which has the terminating null. */
2013 #ifdef LOCALTIME_CACHE
2015 /* In SunOS 4.1.3_U1 and 4.1.4, if TZ has a value like
2016 "US/Pacific" that loads a tz file, then changes to a value like
2017 "XXX0" that does not load a tz file, and then changes back to
2018 its original value, the last change is (incorrectly) ignored.
2019 Also, if TZ changes twice in succession to values that do
2020 not load a tz file, tzset can dump core (see Sun bug#1225179).
2021 The following code works around these bugs. */
2025 /* Temporarily set TZ to a value that loads a tz file
2026 and that differs from tzstring. */
2028 *newenv
= (strcmp (tzstring
, set_time_zone_rule_tz1
+ 3) == 0
2029 ? set_time_zone_rule_tz2
: set_time_zone_rule_tz1
);
2035 /* The implied tzstring is unknown, so temporarily set TZ to
2036 two different values that each load a tz file. */
2037 *to
= set_time_zone_rule_tz1
;
2040 *to
= set_time_zone_rule_tz2
;
2045 /* Now TZ has the desired value, and tzset can be invoked safely. */
2052 /* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC
2053 (if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a
2054 type of object is Lisp_String). INHERIT is passed to
2055 INSERT_FROM_STRING_FUNC as the last argument. */
2058 general_insert_function (insert_func
, insert_from_string_func
,
2059 inherit
, nargs
, args
)
2060 void (*insert_func
) P_ ((const unsigned char *, int));
2061 void (*insert_from_string_func
) P_ ((Lisp_Object
, int, int, int, int, int));
2063 register Lisp_Object
*args
;
2065 register int argnum
;
2066 register Lisp_Object val
;
2068 for (argnum
= 0; argnum
< nargs
; argnum
++)
2074 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2077 if (!NILP (current_buffer
->enable_multibyte_characters
))
2078 len
= CHAR_STRING (XFASTINT (val
), str
);
2081 str
[0] = (ASCII_CHAR_P (XINT (val
))
2083 : multibyte_char_to_unibyte (XINT (val
), Qnil
));
2086 (*insert_func
) (str
, len
);
2088 else if (STRINGP (val
))
2090 (*insert_from_string_func
) (val
, 0, 0,
2097 val
= wrong_type_argument (Qchar_or_string_p
, val
);
2111 /* Callers passing one argument to Finsert need not gcpro the
2112 argument "array", since the only element of the array will
2113 not be used after calling insert or insert_from_string, so
2114 we don't care if it gets trashed. */
2116 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
2117 doc
: /* Insert the arguments, either strings or characters, at point.
2118 Point and before-insertion markers move forward to end up
2119 after the inserted text.
2120 Any other markers at the point of insertion remain before the text.
2122 If the current buffer is multibyte, unibyte strings are converted
2123 to multibyte for insertion (see `string-make-multibyte').
2124 If the current buffer is unibyte, multibyte strings are converted
2125 to unibyte for insertion (see `string-make-unibyte').
2127 When operating on binary data, it may be necessary to preserve the
2128 original bytes of a unibyte string when inserting it into a multibyte
2129 buffer; to accomplish this, apply `string-as-multibyte' to the string
2130 and insert the result.
2132 usage: (insert &rest ARGS) */)
2135 register Lisp_Object
*args
;
2137 general_insert_function (insert
, insert_from_string
, 0, nargs
, args
);
2141 DEFUN ("insert-and-inherit", Finsert_and_inherit
, Sinsert_and_inherit
,
2143 doc
: /* Insert the arguments at point, inheriting properties from adjoining text.
2144 Point and before-insertion markers move forward to end up
2145 after the inserted text.
2146 Any other markers at the point of insertion remain before the text.
2148 If the current buffer is multibyte, unibyte strings are converted
2149 to multibyte for insertion (see `unibyte-char-to-multibyte').
2150 If the current buffer is unibyte, multibyte strings are converted
2151 to unibyte for insertion.
2153 usage: (insert-and-inherit &rest ARGS) */)
2156 register Lisp_Object
*args
;
2158 general_insert_function (insert_and_inherit
, insert_from_string
, 1,
2163 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
2164 doc
: /* Insert strings or characters at point, relocating markers after the text.
2165 Point and markers move forward to end up after the inserted text.
2167 If the current buffer is multibyte, unibyte strings are converted
2168 to multibyte for insertion (see `unibyte-char-to-multibyte').
2169 If the current buffer is unibyte, multibyte strings are converted
2170 to unibyte for insertion.
2172 usage: (insert-before-markers &rest ARGS) */)
2175 register Lisp_Object
*args
;
2177 general_insert_function (insert_before_markers
,
2178 insert_from_string_before_markers
, 0,
2183 DEFUN ("insert-before-markers-and-inherit", Finsert_and_inherit_before_markers
,
2184 Sinsert_and_inherit_before_markers
, 0, MANY
, 0,
2185 doc
: /* Insert text at point, relocating markers and inheriting properties.
2186 Point and markers move forward to end up after the inserted text.
2188 If the current buffer is multibyte, unibyte strings are converted
2189 to multibyte for insertion (see `unibyte-char-to-multibyte').
2190 If the current buffer is unibyte, multibyte strings are converted
2191 to unibyte for insertion.
2193 usage: (insert-before-markers-and-inherit &rest ARGS) */)
2196 register Lisp_Object
*args
;
2198 general_insert_function (insert_before_markers_and_inherit
,
2199 insert_from_string_before_markers
, 1,
2204 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 2, 3, 0,
2205 doc
: /* Insert COUNT (second arg) copies of CHARACTER (first arg).
2206 Both arguments are required.
2207 Point, and before-insertion markers, are relocated as in the function `insert'.
2208 The optional third arg INHERIT, if non-nil, says to inherit text properties
2209 from adjoining text, if those properties are sticky. */)
2210 (character
, count
, inherit
)
2211 Lisp_Object character
, count
, inherit
;
2213 register unsigned char *string
;
2214 register int strlen
;
2217 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2219 CHECK_NUMBER (character
);
2220 CHECK_NUMBER (count
);
2222 if (!NILP (current_buffer
->enable_multibyte_characters
))
2223 len
= CHAR_STRING (XFASTINT (character
), str
);
2225 str
[0] = XFASTINT (character
), len
= 1;
2226 n
= XINT (count
) * len
;
2229 strlen
= min (n
, 256 * len
);
2230 string
= (unsigned char *) alloca (strlen
);
2231 for (i
= 0; i
< strlen
; i
++)
2232 string
[i
] = str
[i
% len
];
2236 if (!NILP (inherit
))
2237 insert_and_inherit (string
, strlen
);
2239 insert (string
, strlen
);
2244 if (!NILP (inherit
))
2245 insert_and_inherit (string
, n
);
2252 DEFUN ("insert-byte", Finsert_byte
, Sinsert_byte
, 2, 3, 0,
2253 doc
: /* Insert COUNT (second arg) copies of BYTE (first arg).
2254 Both arguments are required.
2255 BYTE is a number of the range 0..255.
2257 If BYTE is 128..255 and the current buffer is multibyte, the
2258 corresponding eight-bit character is inserted.
2260 Point, and before-insertion markers, are relocated as in the function `insert'.
2261 The optional third arg INHERIT, if non-nil, says to inherit text properties
2262 from adjoining text, if those properties are sticky. */)
2263 (byte
, count
, inherit
)
2264 Lisp_Object byte
, count
, inherit
;
2266 CHECK_NUMBER (byte
);
2267 if (XINT (byte
) < 0 || XINT (byte
) > 255)
2268 args_out_of_range_3 (byte
, make_number (0), make_number (255));
2269 if (XINT (byte
) >= 128
2270 && ! NILP (current_buffer
->enable_multibyte_characters
))
2271 XSETFASTINT (byte
, BYTE8_TO_CHAR (XINT (byte
)));
2272 return Finsert_char (byte
, count
, inherit
);
2276 /* Making strings from buffer contents. */
2278 /* Return a Lisp_String containing the text of the current buffer from
2279 START to END. If text properties are in use and the current buffer
2280 has properties in the range specified, the resulting string will also
2281 have them, if PROPS is nonzero.
2283 We don't want to use plain old make_string here, because it calls
2284 make_uninit_string, which can cause the buffer arena to be
2285 compacted. make_string has no way of knowing that the data has
2286 been moved, and thus copies the wrong data into the string. This
2287 doesn't effect most of the other users of make_string, so it should
2288 be left as is. But we should use this function when conjuring
2289 buffer substrings. */
2292 make_buffer_string (start
, end
, props
)
2296 int start_byte
= CHAR_TO_BYTE (start
);
2297 int end_byte
= CHAR_TO_BYTE (end
);
2299 return make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
);
2302 /* Return a Lisp_String containing the text of the current buffer from
2303 START / START_BYTE to END / END_BYTE.
2305 If text properties are in use and the current buffer
2306 has properties in the range specified, the resulting string will also
2307 have them, if PROPS is nonzero.
2309 We don't want to use plain old make_string here, because it calls
2310 make_uninit_string, which can cause the buffer arena to be
2311 compacted. make_string has no way of knowing that the data has
2312 been moved, and thus copies the wrong data into the string. This
2313 doesn't effect most of the other users of make_string, so it should
2314 be left as is. But we should use this function when conjuring
2315 buffer substrings. */
2318 make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
)
2319 int start
, start_byte
, end
, end_byte
;
2322 Lisp_Object result
, tem
, tem1
;
2324 if (start
< GPT
&& GPT
< end
)
2327 if (! NILP (current_buffer
->enable_multibyte_characters
))
2328 result
= make_uninit_multibyte_string (end
- start
, end_byte
- start_byte
);
2330 result
= make_uninit_string (end
- start
);
2331 bcopy (BYTE_POS_ADDR (start_byte
), SDATA (result
),
2332 end_byte
- start_byte
);
2334 /* If desired, update and copy the text properties. */
2337 update_buffer_properties (start
, end
);
2339 tem
= Fnext_property_change (make_number (start
), Qnil
, make_number (end
));
2340 tem1
= Ftext_properties_at (make_number (start
), Qnil
);
2342 if (XINT (tem
) != end
|| !NILP (tem1
))
2343 copy_intervals_to_string (result
, current_buffer
, start
,
2350 /* Call Vbuffer_access_fontify_functions for the range START ... END
2351 in the current buffer, if necessary. */
2354 update_buffer_properties (start
, end
)
2357 /* If this buffer has some access functions,
2358 call them, specifying the range of the buffer being accessed. */
2359 if (!NILP (Vbuffer_access_fontify_functions
))
2361 Lisp_Object args
[3];
2364 args
[0] = Qbuffer_access_fontify_functions
;
2365 XSETINT (args
[1], start
);
2366 XSETINT (args
[2], end
);
2368 /* But don't call them if we can tell that the work
2369 has already been done. */
2370 if (!NILP (Vbuffer_access_fontified_property
))
2372 tem
= Ftext_property_any (args
[1], args
[2],
2373 Vbuffer_access_fontified_property
,
2376 Frun_hook_with_args (3, args
);
2379 Frun_hook_with_args (3, args
);
2383 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
2384 doc
: /* Return the contents of part of the current buffer as a string.
2385 The two arguments START and END are character positions;
2386 they can be in either order.
2387 The string returned is multibyte if the buffer is multibyte.
2389 This function copies the text properties of that part of the buffer
2390 into the result string; if you don't want the text properties,
2391 use `buffer-substring-no-properties' instead. */)
2393 Lisp_Object start
, end
;
2397 validate_region (&start
, &end
);
2401 return make_buffer_string (b
, e
, 1);
2404 DEFUN ("buffer-substring-no-properties", Fbuffer_substring_no_properties
,
2405 Sbuffer_substring_no_properties
, 2, 2, 0,
2406 doc
: /* Return the characters of part of the buffer, without the text properties.
2407 The two arguments START and END are character positions;
2408 they can be in either order. */)
2410 Lisp_Object start
, end
;
2414 validate_region (&start
, &end
);
2418 return make_buffer_string (b
, e
, 0);
2421 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
2422 doc
: /* Return the contents of the current buffer as a string.
2423 If narrowing is in effect, this function returns only the visible part
2427 return make_buffer_string (BEGV
, ZV
, 1);
2430 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
2432 doc
: /* Insert before point a substring of the contents of BUFFER.
2433 BUFFER may be a buffer or a buffer name.
2434 Arguments START and END are character positions specifying the substring.
2435 They default to the values of (point-min) and (point-max) in BUFFER. */)
2436 (buffer
, start
, end
)
2437 Lisp_Object buffer
, start
, end
;
2439 register int b
, e
, temp
;
2440 register struct buffer
*bp
, *obuf
;
2443 buf
= Fget_buffer (buffer
);
2447 if (NILP (bp
->name
))
2448 error ("Selecting deleted buffer");
2454 CHECK_NUMBER_COERCE_MARKER (start
);
2461 CHECK_NUMBER_COERCE_MARKER (end
);
2466 temp
= b
, b
= e
, e
= temp
;
2468 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
2469 args_out_of_range (start
, end
);
2471 obuf
= current_buffer
;
2472 set_buffer_internal_1 (bp
);
2473 update_buffer_properties (b
, e
);
2474 set_buffer_internal_1 (obuf
);
2476 insert_from_buffer (bp
, b
, e
- b
, 0);
2480 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
2482 doc
: /* Compare two substrings of two buffers; return result as number.
2483 the value is -N if first string is less after N-1 chars,
2484 +N if first string is greater after N-1 chars, or 0 if strings match.
2485 Each substring is represented as three arguments: BUFFER, START and END.
2486 That makes six args in all, three for each substring.
2488 The value of `case-fold-search' in the current buffer
2489 determines whether case is significant or ignored. */)
2490 (buffer1
, start1
, end1
, buffer2
, start2
, end2
)
2491 Lisp_Object buffer1
, start1
, end1
, buffer2
, start2
, end2
;
2493 register int begp1
, endp1
, begp2
, endp2
, temp
;
2494 register struct buffer
*bp1
, *bp2
;
2495 register Lisp_Object
*trt
2496 = (!NILP (current_buffer
->case_fold_search
)
2497 ? XCHAR_TABLE (current_buffer
->case_canon_table
)->contents
: 0);
2499 int i1
, i2
, i1_byte
, i2_byte
;
2501 /* Find the first buffer and its substring. */
2504 bp1
= current_buffer
;
2508 buf1
= Fget_buffer (buffer1
);
2511 bp1
= XBUFFER (buf1
);
2512 if (NILP (bp1
->name
))
2513 error ("Selecting deleted buffer");
2517 begp1
= BUF_BEGV (bp1
);
2520 CHECK_NUMBER_COERCE_MARKER (start1
);
2521 begp1
= XINT (start1
);
2524 endp1
= BUF_ZV (bp1
);
2527 CHECK_NUMBER_COERCE_MARKER (end1
);
2528 endp1
= XINT (end1
);
2532 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
2534 if (!(BUF_BEGV (bp1
) <= begp1
2536 && endp1
<= BUF_ZV (bp1
)))
2537 args_out_of_range (start1
, end1
);
2539 /* Likewise for second substring. */
2542 bp2
= current_buffer
;
2546 buf2
= Fget_buffer (buffer2
);
2549 bp2
= XBUFFER (buf2
);
2550 if (NILP (bp2
->name
))
2551 error ("Selecting deleted buffer");
2555 begp2
= BUF_BEGV (bp2
);
2558 CHECK_NUMBER_COERCE_MARKER (start2
);
2559 begp2
= XINT (start2
);
2562 endp2
= BUF_ZV (bp2
);
2565 CHECK_NUMBER_COERCE_MARKER (end2
);
2566 endp2
= XINT (end2
);
2570 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
2572 if (!(BUF_BEGV (bp2
) <= begp2
2574 && endp2
<= BUF_ZV (bp2
)))
2575 args_out_of_range (start2
, end2
);
2579 i1_byte
= buf_charpos_to_bytepos (bp1
, i1
);
2580 i2_byte
= buf_charpos_to_bytepos (bp2
, i2
);
2582 while (i1
< endp1
&& i2
< endp2
)
2584 /* When we find a mismatch, we must compare the
2585 characters, not just the bytes. */
2590 if (! NILP (bp1
->enable_multibyte_characters
))
2592 c1
= BUF_FETCH_MULTIBYTE_CHAR (bp1
, i1_byte
);
2593 BUF_INC_POS (bp1
, i1_byte
);
2598 c1
= BUF_FETCH_BYTE (bp1
, i1
);
2599 c1
= unibyte_char_to_multibyte (c1
);
2603 if (! NILP (bp2
->enable_multibyte_characters
))
2605 c2
= BUF_FETCH_MULTIBYTE_CHAR (bp2
, i2_byte
);
2606 BUF_INC_POS (bp2
, i2_byte
);
2611 c2
= BUF_FETCH_BYTE (bp2
, i2
);
2612 c2
= unibyte_char_to_multibyte (c2
);
2618 c1
= XINT (trt
[c1
]);
2619 c2
= XINT (trt
[c2
]);
2622 return make_number (- 1 - chars
);
2624 return make_number (chars
+ 1);
2629 /* The strings match as far as they go.
2630 If one is shorter, that one is less. */
2631 if (chars
< endp1
- begp1
)
2632 return make_number (chars
+ 1);
2633 else if (chars
< endp2
- begp2
)
2634 return make_number (- chars
- 1);
2636 /* Same length too => they are equal. */
2637 return make_number (0);
2641 subst_char_in_region_unwind (arg
)
2644 return current_buffer
->undo_list
= arg
;
2648 subst_char_in_region_unwind_1 (arg
)
2651 return current_buffer
->filename
= arg
;
2654 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
2655 Ssubst_char_in_region
, 4, 5, 0,
2656 doc
: /* From START to END, replace FROMCHAR with TOCHAR each time it occurs.
2657 If optional arg NOUNDO is non-nil, don't record this change for undo
2658 and don't mark the buffer as really changed.
2659 Both characters must have the same length of multi-byte form. */)
2660 (start
, end
, fromchar
, tochar
, noundo
)
2661 Lisp_Object start
, end
, fromchar
, tochar
, noundo
;
2663 register int pos
, pos_byte
, stop
, i
, len
, end_byte
;
2665 unsigned char fromstr
[MAX_MULTIBYTE_LENGTH
], tostr
[MAX_MULTIBYTE_LENGTH
];
2667 int count
= SPECPDL_INDEX ();
2668 #define COMBINING_NO 0
2669 #define COMBINING_BEFORE 1
2670 #define COMBINING_AFTER 2
2671 #define COMBINING_BOTH (COMBINING_BEFORE | COMBINING_AFTER)
2672 int maybe_byte_combining
= COMBINING_NO
;
2673 int last_changed
= 0;
2674 int multibyte_p
= !NILP (current_buffer
->enable_multibyte_characters
);
2676 validate_region (&start
, &end
);
2677 CHECK_NUMBER (fromchar
);
2678 CHECK_NUMBER (tochar
);
2682 len
= CHAR_STRING (XFASTINT (fromchar
), fromstr
);
2683 if (CHAR_STRING (XFASTINT (tochar
), tostr
) != len
)
2684 error ("Characters in `subst-char-in-region' have different byte-lengths");
2685 if (!ASCII_BYTE_P (*tostr
))
2687 /* If *TOSTR is in the range 0x80..0x9F and TOCHAR is not a
2688 complete multibyte character, it may be combined with the
2689 after bytes. If it is in the range 0xA0..0xFF, it may be
2690 combined with the before and after bytes. */
2691 if (!CHAR_HEAD_P (*tostr
))
2692 maybe_byte_combining
= COMBINING_BOTH
;
2693 else if (BYTES_BY_CHAR_HEAD (*tostr
) > len
)
2694 maybe_byte_combining
= COMBINING_AFTER
;
2700 fromstr
[0] = XFASTINT (fromchar
);
2701 tostr
[0] = XFASTINT (tochar
);
2705 pos_byte
= CHAR_TO_BYTE (pos
);
2706 stop
= CHAR_TO_BYTE (XINT (end
));
2709 /* If we don't want undo, turn off putting stuff on the list.
2710 That's faster than getting rid of things,
2711 and it prevents even the entry for a first change.
2712 Also inhibit locking the file. */
2715 record_unwind_protect (subst_char_in_region_unwind
,
2716 current_buffer
->undo_list
);
2717 current_buffer
->undo_list
= Qt
;
2718 /* Don't do file-locking. */
2719 record_unwind_protect (subst_char_in_region_unwind_1
,
2720 current_buffer
->filename
);
2721 current_buffer
->filename
= Qnil
;
2724 if (pos_byte
< GPT_BYTE
)
2725 stop
= min (stop
, GPT_BYTE
);
2728 int pos_byte_next
= pos_byte
;
2730 if (pos_byte
>= stop
)
2732 if (pos_byte
>= end_byte
) break;
2735 p
= BYTE_POS_ADDR (pos_byte
);
2737 INC_POS (pos_byte_next
);
2740 if (pos_byte_next
- pos_byte
== len
2741 && p
[0] == fromstr
[0]
2743 || (p
[1] == fromstr
[1]
2744 && (len
== 2 || (p
[2] == fromstr
[2]
2745 && (len
== 3 || p
[3] == fromstr
[3]))))))
2750 modify_region (current_buffer
, changed
, XINT (end
));
2752 if (! NILP (noundo
))
2754 if (MODIFF
- 1 == SAVE_MODIFF
)
2756 if (MODIFF
- 1 == current_buffer
->auto_save_modified
)
2757 current_buffer
->auto_save_modified
++;
2761 /* Take care of the case where the new character
2762 combines with neighboring bytes. */
2763 if (maybe_byte_combining
2764 && (maybe_byte_combining
== COMBINING_AFTER
2765 ? (pos_byte_next
< Z_BYTE
2766 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2767 : ((pos_byte_next
< Z_BYTE
2768 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2769 || (pos_byte
> BEG_BYTE
2770 && ! ASCII_BYTE_P (FETCH_BYTE (pos_byte
- 1))))))
2772 Lisp_Object tem
, string
;
2774 struct gcpro gcpro1
;
2776 tem
= current_buffer
->undo_list
;
2779 /* Make a multibyte string containing this single character. */
2780 string
= make_multibyte_string (tostr
, 1, len
);
2781 /* replace_range is less efficient, because it moves the gap,
2782 but it handles combining correctly. */
2783 replace_range (pos
, pos
+ 1, string
,
2785 pos_byte_next
= CHAR_TO_BYTE (pos
);
2786 if (pos_byte_next
> pos_byte
)
2787 /* Before combining happened. We should not increment
2788 POS. So, to cancel the later increment of POS,
2792 INC_POS (pos_byte_next
);
2794 if (! NILP (noundo
))
2795 current_buffer
->undo_list
= tem
;
2802 record_change (pos
, 1);
2803 for (i
= 0; i
< len
; i
++) *p
++ = tostr
[i
];
2805 last_changed
= pos
+ 1;
2807 pos_byte
= pos_byte_next
;
2813 signal_after_change (changed
,
2814 last_changed
- changed
, last_changed
- changed
);
2815 update_compositions (changed
, last_changed
, CHECK_ALL
);
2818 unbind_to (count
, Qnil
);
2823 static Lisp_Object check_translation
P_ ((int, int, int, Lisp_Object
));
2825 /* Helper function for Ftranslate_region_internal.
2827 Check if a character sequence at POS (POS_BYTE) matches an element
2828 of VAL. VAL is a list (([FROM-CHAR ...] . TO) ...). If a matching
2829 element is found, return it. Otherwise return Qnil. */
2832 check_translation (pos
, pos_byte
, end
, val
)
2833 int pos
, pos_byte
, end
;
2836 int buf_size
= 16, buf_used
= 0;
2837 int *buf
= alloca (sizeof (int) * buf_size
);
2839 for (; CONSP (val
); val
= XCDR (val
))
2848 if (! VECTORP (elt
))
2851 if (len
<= end
- pos
)
2853 for (i
= 0; i
< len
; i
++)
2857 unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
2860 if (buf_used
== buf_size
)
2865 newbuf
= alloca (sizeof (int) * buf_size
);
2866 memcpy (newbuf
, buf
, sizeof (int) * buf_used
);
2869 buf
[buf_used
++] = STRING_CHAR_AND_LENGTH (p
, 0, len
);
2872 if (XINT (AREF (elt
, i
)) != buf
[i
])
2883 DEFUN ("translate-region-internal", Ftranslate_region_internal
,
2884 Stranslate_region_internal
, 3, 3, 0,
2885 doc
: /* Internal use only.
2886 From START to END, translate characters according to TABLE.
2887 TABLE is a string or a char-table; the Nth character in it is the
2888 mapping for the character with code N.
2889 It returns the number of characters changed. */)
2893 register Lisp_Object table
;
2895 register unsigned char *tt
; /* Trans table. */
2896 register int nc
; /* New character. */
2897 int cnt
; /* Number of changes made. */
2898 int size
; /* Size of translate table. */
2899 int pos
, pos_byte
, end_pos
;
2900 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
2901 int string_multibyte
;
2904 validate_region (&start
, &end
);
2905 if (CHAR_TABLE_P (table
))
2907 if (! EQ (XCHAR_TABLE (table
)->purpose
, Qtranslation_table
))
2908 error ("Not a translation table");
2914 CHECK_STRING (table
);
2916 if (! multibyte
&& (SCHARS (table
) < SBYTES (table
)))
2917 table
= string_make_unibyte (table
);
2918 string_multibyte
= SCHARS (table
) < SBYTES (table
);
2919 size
= SBYTES (table
);
2924 pos_byte
= CHAR_TO_BYTE (pos
);
2925 end_pos
= XINT (end
);
2926 modify_region (current_buffer
, pos
, end_pos
);
2929 for (; pos
< end_pos
; )
2931 register unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
2932 unsigned char *str
, buf
[MAX_MULTIBYTE_LENGTH
];
2938 oc
= STRING_CHAR_AND_LENGTH (p
, MAX_MULTIBYTE_LENGTH
, len
);
2945 if (string_multibyte
)
2947 str
= tt
+ string_char_to_byte (table
, oc
);
2948 nc
= STRING_CHAR_AND_LENGTH (str
, MAX_MULTIBYTE_LENGTH
,
2954 if (! ASCII_BYTE_P (nc
) && multibyte
)
2956 str_len
= BYTE8_STRING (nc
, buf
);
2971 val
= CHAR_TABLE_REF (table
, oc
);
2972 if (CHARACTERP (val
)
2973 && (c
= XINT (val
), CHAR_VALID_P (c
, 0)))
2976 str_len
= CHAR_STRING (nc
, buf
);
2979 else if (VECTORP (val
) || (CONSP (val
)))
2981 /* VAL is [TO_CHAR ...] or (([FROM-CHAR ...] . TO) ...)
2982 where TO is TO-CHAR or [TO-CHAR ...]. */
2987 if (nc
!= oc
&& nc
>= 0)
2989 /* Simple one char to one char translation. */
2994 /* This is less efficient, because it moves the gap,
2995 but it should handle multibyte characters correctly. */
2996 string
= make_multibyte_string (str
, 1, str_len
);
2997 replace_range (pos
, pos
+ 1, string
, 1, 0, 1);
3002 record_change (pos
, 1);
3003 while (str_len
-- > 0)
3005 signal_after_change (pos
, 1, 1);
3006 update_compositions (pos
, pos
+ 1, CHECK_BORDER
);
3016 val
= check_translation (pos
, pos_byte
, end_pos
, val
);
3023 /* VAL is ([FROM-CHAR ...] . TO). */
3024 len
= ASIZE (XCAR (val
));
3034 string
= Fmake_string (make_number (ASIZE (val
)),
3036 for (i
= 1; i
< ASIZE (val
); i
++)
3037 Faset (string
, make_number (i
), AREF (val
, i
));
3041 string
= Fmake_string (make_number (1), val
);
3043 replace_range (pos
, pos
+ len
, string
, 1, 0, 1);
3044 pos_byte
+= SBYTES (string
);
3045 pos
+= SCHARS (string
);
3046 cnt
+= SCHARS (string
);
3047 end_pos
+= SCHARS (string
) - len
;
3055 return make_number (cnt
);
3058 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
3059 doc
: /* Delete the text between point and mark.
3061 When called from a program, expects two arguments,
3062 positions (integers or markers) specifying the stretch to be deleted. */)
3064 Lisp_Object start
, end
;
3066 validate_region (&start
, &end
);
3067 del_range (XINT (start
), XINT (end
));
3071 DEFUN ("delete-and-extract-region", Fdelete_and_extract_region
,
3072 Sdelete_and_extract_region
, 2, 2, 0,
3073 doc
: /* Delete the text between START and END and return it. */)
3075 Lisp_Object start
, end
;
3077 validate_region (&start
, &end
);
3078 if (XINT (start
) == XINT (end
))
3079 return build_string ("");
3080 return del_range_1 (XINT (start
), XINT (end
), 1, 1);
3083 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
3084 doc
: /* Remove restrictions (narrowing) from current buffer.
3085 This allows the buffer's full text to be seen and edited. */)
3088 if (BEG
!= BEGV
|| Z
!= ZV
)
3089 current_buffer
->clip_changed
= 1;
3091 BEGV_BYTE
= BEG_BYTE
;
3092 SET_BUF_ZV_BOTH (current_buffer
, Z
, Z_BYTE
);
3093 /* Changing the buffer bounds invalidates any recorded current column. */
3094 invalidate_current_column ();
3098 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
3099 doc
: /* Restrict editing in this buffer to the current region.
3100 The rest of the text becomes temporarily invisible and untouchable
3101 but is not deleted; if you save the buffer in a file, the invisible
3102 text is included in the file. \\[widen] makes all visible again.
3103 See also `save-restriction'.
3105 When calling from a program, pass two arguments; positions (integers
3106 or markers) bounding the text that should remain visible. */)
3108 register Lisp_Object start
, end
;
3110 CHECK_NUMBER_COERCE_MARKER (start
);
3111 CHECK_NUMBER_COERCE_MARKER (end
);
3113 if (XINT (start
) > XINT (end
))
3116 tem
= start
; start
= end
; end
= tem
;
3119 if (!(BEG
<= XINT (start
) && XINT (start
) <= XINT (end
) && XINT (end
) <= Z
))
3120 args_out_of_range (start
, end
);
3122 if (BEGV
!= XFASTINT (start
) || ZV
!= XFASTINT (end
))
3123 current_buffer
->clip_changed
= 1;
3125 SET_BUF_BEGV (current_buffer
, XFASTINT (start
));
3126 SET_BUF_ZV (current_buffer
, XFASTINT (end
));
3127 if (PT
< XFASTINT (start
))
3128 SET_PT (XFASTINT (start
));
3129 if (PT
> XFASTINT (end
))
3130 SET_PT (XFASTINT (end
));
3131 /* Changing the buffer bounds invalidates any recorded current column. */
3132 invalidate_current_column ();
3137 save_restriction_save ()
3139 if (BEGV
== BEG
&& ZV
== Z
)
3140 /* The common case that the buffer isn't narrowed.
3141 We return just the buffer object, which save_restriction_restore
3142 recognizes as meaning `no restriction'. */
3143 return Fcurrent_buffer ();
3145 /* We have to save a restriction, so return a pair of markers, one
3146 for the beginning and one for the end. */
3148 Lisp_Object beg
, end
;
3150 beg
= buildmark (BEGV
, BEGV_BYTE
);
3151 end
= buildmark (ZV
, ZV_BYTE
);
3153 /* END must move forward if text is inserted at its exact location. */
3154 XMARKER(end
)->insertion_type
= 1;
3156 return Fcons (beg
, end
);
3161 save_restriction_restore (data
)
3165 /* A pair of marks bounding a saved restriction. */
3167 struct Lisp_Marker
*beg
= XMARKER (XCAR (data
));
3168 struct Lisp_Marker
*end
= XMARKER (XCDR (data
));
3169 struct buffer
*buf
= beg
->buffer
; /* END should have the same buffer. */
3171 if (buf
/* Verify marker still points to a buffer. */
3172 && (beg
->charpos
!= BUF_BEGV (buf
) || end
->charpos
!= BUF_ZV (buf
)))
3173 /* The restriction has changed from the saved one, so restore
3174 the saved restriction. */
3176 int pt
= BUF_PT (buf
);
3178 SET_BUF_BEGV_BOTH (buf
, beg
->charpos
, beg
->bytepos
);
3179 SET_BUF_ZV_BOTH (buf
, end
->charpos
, end
->bytepos
);
3181 if (pt
< beg
->charpos
|| pt
> end
->charpos
)
3182 /* The point is outside the new visible range, move it inside. */
3183 SET_BUF_PT_BOTH (buf
,
3184 clip_to_bounds (beg
->charpos
, pt
, end
->charpos
),
3185 clip_to_bounds (beg
->bytepos
, BUF_PT_BYTE (buf
),
3188 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3192 /* A buffer, which means that there was no old restriction. */
3194 struct buffer
*buf
= XBUFFER (data
);
3196 if (buf
/* Verify marker still points to a buffer. */
3197 && (BUF_BEGV (buf
) != BUF_BEG (buf
) || BUF_ZV (buf
) != BUF_Z (buf
)))
3198 /* The buffer has been narrowed, get rid of the narrowing. */
3200 SET_BUF_BEGV_BOTH (buf
, BUF_BEG (buf
), BUF_BEG_BYTE (buf
));
3201 SET_BUF_ZV_BOTH (buf
, BUF_Z (buf
), BUF_Z_BYTE (buf
));
3203 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3210 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
3211 doc
: /* Execute BODY, saving and restoring current buffer's restrictions.
3212 The buffer's restrictions make parts of the beginning and end invisible.
3213 (They are set up with `narrow-to-region' and eliminated with `widen'.)
3214 This special form, `save-restriction', saves the current buffer's restrictions
3215 when it is entered, and restores them when it is exited.
3216 So any `narrow-to-region' within BODY lasts only until the end of the form.
3217 The old restrictions settings are restored
3218 even in case of abnormal exit (throw or error).
3220 The value returned is the value of the last form in BODY.
3222 Note: if you are using both `save-excursion' and `save-restriction',
3223 use `save-excursion' outermost:
3224 (save-excursion (save-restriction ...))
3226 usage: (save-restriction &rest BODY) */)
3230 register Lisp_Object val
;
3231 int count
= SPECPDL_INDEX ();
3233 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
3234 val
= Fprogn (body
);
3235 return unbind_to (count
, val
);
3238 /* Buffer for the most recent text displayed by Fmessage_box. */
3239 static char *message_text
;
3241 /* Allocated length of that buffer. */
3242 static int message_length
;
3244 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
3245 doc
: /* Print a one-line message at the bottom of the screen.
3246 The message also goes into the `*Messages*' buffer.
3247 \(In keyboard macros, that's all it does.)
3249 The first argument is a format control string, and the rest are data
3250 to be formatted under control of the string. See `format' for details.
3252 If the first argument is nil, the function clears any existing message;
3253 this lets the minibuffer contents show. See also `current-message'.
3255 usage: (message STRING &rest ARGS) */)
3261 || (STRINGP (args
[0])
3262 && SBYTES (args
[0]) == 0))
3269 register Lisp_Object val
;
3270 val
= Fformat (nargs
, args
);
3271 message3 (val
, SBYTES (val
), STRING_MULTIBYTE (val
));
3276 DEFUN ("message-box", Fmessage_box
, Smessage_box
, 1, MANY
, 0,
3277 doc
: /* Display a message, in a dialog box if possible.
3278 If a dialog box is not available, use the echo area.
3279 The first argument is a format control string, and the rest are data
3280 to be formatted under control of the string. See `format' for details.
3282 If the first argument is nil, clear any existing message; let the
3283 minibuffer contents show.
3285 usage: (message-box STRING &rest ARGS) */)
3297 register Lisp_Object val
;
3298 val
= Fformat (nargs
, args
);
3300 /* The MS-DOS frames support popup menus even though they are
3301 not FRAME_WINDOW_P. */
3302 if (FRAME_WINDOW_P (XFRAME (selected_frame
))
3303 || FRAME_MSDOS_P (XFRAME (selected_frame
)))
3305 Lisp_Object pane
, menu
, obj
;
3306 struct gcpro gcpro1
;
3307 pane
= Fcons (Fcons (build_string ("OK"), Qt
), Qnil
);
3309 menu
= Fcons (val
, pane
);
3310 obj
= Fx_popup_dialog (Qt
, menu
, Qt
);
3314 #endif /* HAVE_MENUS */
3315 /* Copy the data so that it won't move when we GC. */
3318 message_text
= (char *)xmalloc (80);
3319 message_length
= 80;
3321 if (SBYTES (val
) > message_length
)
3323 message_length
= SBYTES (val
);
3324 message_text
= (char *)xrealloc (message_text
, message_length
);
3326 bcopy (SDATA (val
), message_text
, SBYTES (val
));
3327 message2 (message_text
, SBYTES (val
),
3328 STRING_MULTIBYTE (val
));
3333 extern Lisp_Object last_nonmenu_event
;
3336 DEFUN ("message-or-box", Fmessage_or_box
, Smessage_or_box
, 1, MANY
, 0,
3337 doc
: /* Display a message in a dialog box or in the echo area.
3338 If this command was invoked with the mouse, use a dialog box if
3339 `use-dialog-box' is non-nil.
3340 Otherwise, use the echo area.
3341 The first argument is a format control string, and the rest are data
3342 to be formatted under control of the string. See `format' for details.
3344 If the first argument is nil, clear any existing message; let the
3345 minibuffer contents show.
3347 usage: (message-or-box STRING &rest ARGS) */)
3353 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3355 return Fmessage_box (nargs
, args
);
3357 return Fmessage (nargs
, args
);
3360 DEFUN ("current-message", Fcurrent_message
, Scurrent_message
, 0, 0, 0,
3361 doc
: /* Return the string currently displayed in the echo area, or nil if none. */)
3364 return current_message ();
3368 DEFUN ("propertize", Fpropertize
, Spropertize
, 1, MANY
, 0,
3369 doc
: /* Return a copy of STRING with text properties added.
3370 First argument is the string to copy.
3371 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
3372 properties to add to the result.
3373 usage: (propertize STRING &rest PROPERTIES) */)
3378 Lisp_Object properties
, string
;
3379 struct gcpro gcpro1
, gcpro2
;
3382 /* Number of args must be odd. */
3383 if ((nargs
& 1) == 0 || nargs
< 1)
3384 error ("Wrong number of arguments");
3386 properties
= string
= Qnil
;
3387 GCPRO2 (properties
, string
);
3389 /* First argument must be a string. */
3390 CHECK_STRING (args
[0]);
3391 string
= Fcopy_sequence (args
[0]);
3393 for (i
= 1; i
< nargs
; i
+= 2)
3395 CHECK_SYMBOL (args
[i
]);
3396 properties
= Fcons (args
[i
], Fcons (args
[i
+ 1], properties
));
3399 Fadd_text_properties (make_number (0),
3400 make_number (SCHARS (string
)),
3401 properties
, string
);
3402 RETURN_UNGCPRO (string
);
3406 /* Number of bytes that STRING will occupy when put into the result.
3407 MULTIBYTE is nonzero if the result should be multibyte. */
3409 #define CONVERTED_BYTE_SIZE(MULTIBYTE, STRING) \
3410 (((MULTIBYTE) && ! STRING_MULTIBYTE (STRING)) \
3411 ? count_size_as_multibyte (SDATA (STRING), SBYTES (STRING)) \
3414 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
3415 doc
: /* Format a string out of a control-string and arguments.
3416 The first argument is a control string.
3417 The other arguments are substituted into it to make the result, a string.
3418 It may contain %-sequences meaning to substitute the next argument.
3419 %s means print a string argument. Actually, prints any object, with `princ'.
3420 %d means print as number in decimal (%o octal, %x hex).
3421 %X is like %x, but uses upper case.
3422 %e means print a number in exponential notation.
3423 %f means print a number in decimal-point notation.
3424 %g means print a number in exponential notation
3425 or decimal-point notation, whichever uses fewer characters.
3426 %c means print a number as a single character.
3427 %S means print any object as an s-expression (using `prin1').
3428 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.
3429 Use %% to put a single % into the output.
3431 The basic structure of a %-sequence is
3432 % <flags> <width> <precision> character
3433 where flags is [- #0]+, width is [0-9]+, and precision is .[0-9]+
3435 usage: (format STRING &rest OBJECTS) */)
3438 register Lisp_Object
*args
;
3440 register int n
; /* The number of the next arg to substitute */
3441 register int total
; /* An estimate of the final length */
3443 register unsigned char *format
, *end
, *format_start
;
3445 /* Nonzero if the output should be a multibyte string,
3446 which is true if any of the inputs is one. */
3448 /* When we make a multibyte string, we must pay attention to the
3449 byte combining problem, i.e., a byte may be combined with a
3450 multibyte charcter of the previous string. This flag tells if we
3451 must consider such a situation or not. */
3452 int maybe_combine_byte
;
3453 unsigned char *this_format
;
3454 /* Precision for each spec, or -1, a flag value meaning no precision
3455 was given in that spec. Element 0, corresonding to the format
3456 string itself, will not be used. Element NARGS, corresponding to
3457 no argument, *will* be assigned to in the case that a `%' and `.'
3458 occur after the final format specifier. */
3459 int *precision
= (int *) (alloca((nargs
+ 1) * sizeof (int)));
3462 int arg_intervals
= 0;
3465 /* discarded[I] is 1 if byte I of the format
3466 string was not copied into the output.
3467 It is 2 if byte I was not the first byte of its character. */
3468 char *discarded
= 0;
3470 /* Each element records, for one argument,
3471 the start and end bytepos in the output string,
3472 and whether the argument is a string with intervals.
3473 info[0] is unused. Unused elements have -1 for start. */
3476 int start
, end
, intervals
;
3479 /* It should not be necessary to GCPRO ARGS, because
3480 the caller in the interpreter should take care of that. */
3482 /* Try to determine whether the result should be multibyte.
3483 This is not always right; sometimes the result needs to be multibyte
3484 because of an object that we will pass through prin1,
3485 and in that case, we won't know it here. */
3486 for (n
= 0; n
< nargs
; n
++)
3488 if (STRINGP (args
[n
]) && STRING_MULTIBYTE (args
[n
]))
3490 /* Piggyback on this loop to initialize precision[N]. */
3493 precision
[nargs
] = -1;
3495 CHECK_STRING (args
[0]);
3496 /* We may have to change "%S" to "%s". */
3497 args
[0] = Fcopy_sequence (args
[0]);
3499 /* GC should never happen here, so abort if it does. */
3502 /* If we start out planning a unibyte result,
3503 then discover it has to be multibyte, we jump back to retry.
3504 That can only happen from the first large while loop below. */
3507 format
= SDATA (args
[0]);
3508 format_start
= format
;
3509 end
= format
+ SBYTES (args
[0]);
3512 /* Make room in result for all the non-%-codes in the control string. */
3513 total
= 5 + CONVERTED_BYTE_SIZE (multibyte
, args
[0]) + 1;
3515 /* Allocate the info and discarded tables. */
3517 int nbytes
= (nargs
+1) * sizeof *info
;
3520 info
= (struct info
*) alloca (nbytes
);
3521 bzero (info
, nbytes
);
3522 for (i
= 0; i
<= nargs
; i
++)
3525 SAFE_ALLOCA (discarded
, char *, SBYTES (args
[0]));
3526 bzero (discarded
, SBYTES (args
[0]));
3529 /* Add to TOTAL enough space to hold the converted arguments. */
3532 while (format
!= end
)
3533 if (*format
++ == '%')
3536 int actual_width
= 0;
3537 unsigned char *this_format_start
= format
- 1;
3538 int field_width
= 0;
3540 /* General format specifications look like
3542 '%' [flags] [field-width] [precision] format
3547 field-width ::= [0-9]+
3548 precision ::= '.' [0-9]*
3550 If a field-width is specified, it specifies to which width
3551 the output should be padded with blanks, iff the output
3552 string is shorter than field-width.
3554 If precision is specified, it specifies the number of
3555 digits to print after the '.' for floats, or the max.
3556 number of chars to print from a string. */
3558 while (index ("-0# ", *format
))
3561 if (*format
>= '0' && *format
<= '9')
3563 for (field_width
= 0; *format
>= '0' && *format
<= '9'; ++format
)
3564 field_width
= 10 * field_width
+ *format
- '0';
3567 /* N is not incremented for another few lines below, so refer to
3568 element N+1 (which might be precision[NARGS]). */
3572 for (precision
[n
+1] = 0; *format
>= '0' && *format
<= '9'; ++format
)
3573 precision
[n
+1] = 10 * precision
[n
+1] + *format
- '0';
3576 if (format
- this_format_start
+ 1 > longest_format
)
3577 longest_format
= format
- this_format_start
+ 1;
3580 error ("Format string ends in middle of format specifier");
3583 else if (++n
>= nargs
)
3584 error ("Not enough arguments for format string");
3585 else if (*format
== 'S')
3587 /* For `S', prin1 the argument and then treat like a string. */
3588 register Lisp_Object tem
;
3589 tem
= Fprin1_to_string (args
[n
], Qnil
);
3590 if (STRING_MULTIBYTE (tem
) && ! multibyte
)
3596 /* If we restart the loop, we should not come here again
3597 because args[n] is now a string and calling
3598 Fprin1_to_string on it produces superflous double
3599 quotes. So, change "%S" to "%s" now. */
3603 else if (SYMBOLP (args
[n
]))
3605 args
[n
] = SYMBOL_NAME (args
[n
]);
3606 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
3613 else if (STRINGP (args
[n
]))
3616 if (*format
!= 's' && *format
!= 'S')
3617 error ("Format specifier doesn't match argument type");
3618 /* In the case (PRECISION[N] > 0), THISSIZE may not need
3619 to be as large as is calculated here. Easy check for
3620 the case PRECISION = 0. */
3621 thissize
= precision
[n
] ? CONVERTED_BYTE_SIZE (multibyte
, args
[n
]) : 0;
3622 actual_width
= lisp_string_width (args
[n
], -1, NULL
, NULL
);
3624 /* Would get MPV otherwise, since Lisp_Int's `point' to low memory. */
3625 else if (INTEGERP (args
[n
]) && *format
!= 's')
3627 /* The following loop assumes the Lisp type indicates
3628 the proper way to pass the argument.
3629 So make sure we have a flonum if the argument should
3631 if (*format
== 'e' || *format
== 'f' || *format
== 'g')
3632 args
[n
] = Ffloat (args
[n
]);
3634 if (*format
!= 'd' && *format
!= 'o' && *format
!= 'x'
3635 && *format
!= 'i' && *format
!= 'X' && *format
!= 'c')
3636 error ("Invalid format operation %%%c", *format
);
3641 if (! ASCII_CHAR_P (XINT (args
[n
]))
3642 /* Note: No one can remeber why we have to treat
3643 the character 0 as a multibyte character here.
3644 But, until it causes a real problem, let's
3646 || XINT (args
[n
]) == 0)
3653 args
[n
] = Fchar_to_string (args
[n
]);
3654 thissize
= SBYTES (args
[n
]);
3656 else if (! ASCII_BYTE_P (XINT (args
[n
])) && multibyte
)
3659 = Fchar_to_string (Funibyte_char_to_multibyte (args
[n
]));
3660 thissize
= SBYTES (args
[n
]);
3664 else if (FLOATP (args
[n
]) && *format
!= 's')
3666 if (! (*format
== 'e' || *format
== 'f' || *format
== 'g'))
3668 if (*format
!= 'd' && *format
!= 'o' && *format
!= 'x'
3669 && *format
!= 'i' && *format
!= 'X' && *format
!= 'c')
3670 error ("Invalid format operation %%%c", *format
);
3671 args
[n
] = Ftruncate (args
[n
], Qnil
);
3674 /* Note that we're using sprintf to print floats,
3675 so we have to take into account what that function
3677 /* Filter out flag value of -1. */
3678 thissize
= (MAX_10_EXP
+ 100
3679 + (precision
[n
] > 0 ? precision
[n
] : 0));
3683 /* Anything but a string, convert to a string using princ. */
3684 register Lisp_Object tem
;
3685 tem
= Fprin1_to_string (args
[n
], Qt
);
3686 if (STRING_MULTIBYTE (tem
) && ! multibyte
)
3695 thissize
+= max (0, field_width
- actual_width
);
3696 total
+= thissize
+ 4;
3701 /* Now we can no longer jump to retry.
3702 TOTAL and LONGEST_FORMAT are known for certain. */
3704 this_format
= (unsigned char *) alloca (longest_format
+ 1);
3706 /* Allocate the space for the result.
3707 Note that TOTAL is an overestimate. */
3708 SAFE_ALLOCA (buf
, char *, total
);
3714 /* Scan the format and store result in BUF. */
3715 format
= SDATA (args
[0]);
3716 format_start
= format
;
3717 end
= format
+ SBYTES (args
[0]);
3718 maybe_combine_byte
= 0;
3719 while (format
!= end
)
3725 unsigned char *this_format_start
= format
;
3727 discarded
[format
- format_start
] = 1;
3730 while (index("-0# ", *format
))
3736 discarded
[format
- format_start
] = 1;
3740 minlen
= atoi (format
);
3742 while ((*format
>= '0' && *format
<= '9') || *format
== '.')
3744 discarded
[format
- format_start
] = 1;
3748 if (*format
++ == '%')
3757 discarded
[format
- format_start
- 1] = 1;
3758 info
[n
].start
= nchars
;
3760 if (STRINGP (args
[n
]))
3762 /* handle case (precision[n] >= 0) */
3765 int nbytes
, start
, end
;
3768 /* lisp_string_width ignores a precision of 0, but GNU
3769 libc functions print 0 characters when the precision
3770 is 0. Imitate libc behavior here. Changing
3771 lisp_string_width is the right thing, and will be
3772 done, but meanwhile we work with it. */
3774 if (precision
[n
] == 0)
3775 width
= nchars_string
= nbytes
= 0;
3776 else if (precision
[n
] > 0)
3777 width
= lisp_string_width (args
[n
], precision
[n
], &nchars_string
, &nbytes
);
3779 { /* no precision spec given for this argument */
3780 width
= lisp_string_width (args
[n
], -1, NULL
, NULL
);
3781 nbytes
= SBYTES (args
[n
]);
3782 nchars_string
= SCHARS (args
[n
]);
3785 /* If spec requires it, pad on right with spaces. */
3786 padding
= minlen
- width
;
3788 while (padding
-- > 0)
3795 nchars
+= nchars_string
;
3800 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3801 && STRING_MULTIBYTE (args
[n
])
3802 && !CHAR_HEAD_P (SREF (args
[n
], 0)))
3803 maybe_combine_byte
= 1;
3805 p
+= copy_text (SDATA (args
[n
]), p
,
3807 STRING_MULTIBYTE (args
[n
]), multibyte
);
3810 while (padding
-- > 0)
3816 /* If this argument has text properties, record where
3817 in the result string it appears. */
3818 if (STRING_INTERVALS (args
[n
]))
3819 info
[n
].intervals
= arg_intervals
= 1;
3821 else if (INTEGERP (args
[n
]) || FLOATP (args
[n
]))
3825 bcopy (this_format_start
, this_format
,
3826 format
- this_format_start
);
3827 this_format
[format
- this_format_start
] = 0;
3829 if (INTEGERP (args
[n
]))
3830 sprintf (p
, this_format
, XINT (args
[n
]));
3832 sprintf (p
, this_format
, XFLOAT_DATA (args
[n
]));
3836 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3837 && !CHAR_HEAD_P (*((unsigned char *) p
)))
3838 maybe_combine_byte
= 1;
3839 this_nchars
= strlen (p
);
3841 p
+= str_to_multibyte (p
, buf
+ total
- 1 - p
, this_nchars
);
3844 nchars
+= this_nchars
;
3847 info
[n
].end
= nchars
;
3849 else if (STRING_MULTIBYTE (args
[0]))
3851 /* Copy a whole multibyte character. */
3854 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3855 && !CHAR_HEAD_P (*format
))
3856 maybe_combine_byte
= 1;
3858 while (! CHAR_HEAD_P (*format
))
3860 discarded
[format
- format_start
] = 2;
3867 /* Convert a single-byte character to multibyte. */
3868 int len
= copy_text (format
, p
, 1, 0, 1);
3875 *p
++ = *format
++, nchars
++;
3878 if (p
> buf
+ total
)
3881 if (maybe_combine_byte
)
3882 nchars
= multibyte_chars_in_text (buf
, p
- buf
);
3883 val
= make_specified_string (buf
, nchars
, p
- buf
, multibyte
);
3885 /* If we allocated BUF with malloc, free it too. */
3888 /* If the format string has text properties, or any of the string
3889 arguments has text properties, set up text properties of the
3892 if (STRING_INTERVALS (args
[0]) || arg_intervals
)
3894 Lisp_Object len
, new_len
, props
;
3895 struct gcpro gcpro1
;
3897 /* Add text properties from the format string. */
3898 len
= make_number (SCHARS (args
[0]));
3899 props
= text_property_list (args
[0], make_number (0), len
, Qnil
);
3904 int bytepos
= 0, position
= 0, translated
= 0, argn
= 1;
3907 /* Adjust the bounds of each text property
3908 to the proper start and end in the output string. */
3910 /* Put the positions in PROPS in increasing order, so that
3911 we can do (effectively) one scan through the position
3912 space of the format string. */
3913 props
= Fnreverse (props
);
3915 /* BYTEPOS is the byte position in the format string,
3916 POSITION is the untranslated char position in it,
3917 TRANSLATED is the translated char position in BUF,
3918 and ARGN is the number of the next arg we will come to. */
3919 for (list
= props
; CONSP (list
); list
= XCDR (list
))
3926 /* First adjust the property start position. */
3927 pos
= XINT (XCAR (item
));
3929 /* Advance BYTEPOS, POSITION, TRANSLATED and ARGN
3930 up to this position. */
3931 for (; position
< pos
; bytepos
++)
3933 if (! discarded
[bytepos
])
3934 position
++, translated
++;
3935 else if (discarded
[bytepos
] == 1)
3938 if (translated
== info
[argn
].start
)
3940 translated
+= info
[argn
].end
- info
[argn
].start
;
3946 XSETCAR (item
, make_number (translated
));
3948 /* Likewise adjust the property end position. */
3949 pos
= XINT (XCAR (XCDR (item
)));
3951 for (; bytepos
< pos
; bytepos
++)
3953 if (! discarded
[bytepos
])
3954 position
++, translated
++;
3955 else if (discarded
[bytepos
] == 1)
3958 if (translated
== info
[argn
].start
)
3960 translated
+= info
[argn
].end
- info
[argn
].start
;
3966 XSETCAR (XCDR (item
), make_number (translated
));
3969 add_text_properties_from_list (val
, props
, make_number (0));
3972 /* Add text properties from arguments. */
3974 for (n
= 1; n
< nargs
; ++n
)
3975 if (info
[n
].intervals
)
3977 len
= make_number (SCHARS (args
[n
]));
3978 new_len
= make_number (info
[n
].end
- info
[n
].start
);
3979 props
= text_property_list (args
[n
], make_number (0), len
, Qnil
);
3980 extend_property_ranges (props
, len
, new_len
);
3981 /* If successive arguments have properites, be sure that
3982 the value of `composition' property be the copy. */
3983 if (n
> 1 && info
[n
- 1].end
)
3984 make_composition_value_copy (props
);
3985 add_text_properties_from_list (val
, props
,
3986 make_number (info
[n
].start
));
3996 format2 (string1
, arg0
, arg1
)
3998 Lisp_Object arg0
, arg1
;
4000 Lisp_Object args
[3];
4001 args
[0] = build_string (string1
);
4004 return Fformat (3, args
);
4007 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
4008 doc
: /* Return t if two characters match, optionally ignoring case.
4009 Both arguments must be characters (i.e. integers).
4010 Case is ignored if `case-fold-search' is non-nil in the current buffer. */)
4012 register Lisp_Object c1
, c2
;
4018 if (XINT (c1
) == XINT (c2
))
4020 if (NILP (current_buffer
->case_fold_search
))
4023 /* Do these in separate statements,
4024 then compare the variables.
4025 because of the way DOWNCASE uses temp variables. */
4027 if (NILP (current_buffer
->enable_multibyte_characters
)
4028 && ! ASCII_CHAR_P (i1
))
4030 MAKE_CHAR_MULTIBYTE (i1
);
4033 if (NILP (current_buffer
->enable_multibyte_characters
)
4034 && ! ASCII_CHAR_P (i2
))
4036 MAKE_CHAR_MULTIBYTE (i2
);
4040 return (i1
== i2
? Qt
: Qnil
);
4043 /* Transpose the markers in two regions of the current buffer, and
4044 adjust the ones between them if necessary (i.e.: if the regions
4047 START1, END1 are the character positions of the first region.
4048 START1_BYTE, END1_BYTE are the byte positions.
4049 START2, END2 are the character positions of the second region.
4050 START2_BYTE, END2_BYTE are the byte positions.
4052 Traverses the entire marker list of the buffer to do so, adding an
4053 appropriate amount to some, subtracting from some, and leaving the
4054 rest untouched. Most of this is copied from adjust_markers in insdel.c.
4056 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
4059 transpose_markers (start1
, end1
, start2
, end2
,
4060 start1_byte
, end1_byte
, start2_byte
, end2_byte
)
4061 register int start1
, end1
, start2
, end2
;
4062 register int start1_byte
, end1_byte
, start2_byte
, end2_byte
;
4064 register int amt1
, amt1_byte
, amt2
, amt2_byte
, diff
, diff_byte
, mpos
;
4065 register struct Lisp_Marker
*marker
;
4067 /* Update point as if it were a marker. */
4071 TEMP_SET_PT_BOTH (PT
+ (end2
- end1
),
4072 PT_BYTE
+ (end2_byte
- end1_byte
));
4073 else if (PT
< start2
)
4074 TEMP_SET_PT_BOTH (PT
+ (end2
- start2
) - (end1
- start1
),
4075 (PT_BYTE
+ (end2_byte
- start2_byte
)
4076 - (end1_byte
- start1_byte
)));
4078 TEMP_SET_PT_BOTH (PT
- (start2
- start1
),
4079 PT_BYTE
- (start2_byte
- start1_byte
));
4081 /* We used to adjust the endpoints here to account for the gap, but that
4082 isn't good enough. Even if we assume the caller has tried to move the
4083 gap out of our way, it might still be at start1 exactly, for example;
4084 and that places it `inside' the interval, for our purposes. The amount
4085 of adjustment is nontrivial if there's a `denormalized' marker whose
4086 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
4087 the dirty work to Fmarker_position, below. */
4089 /* The difference between the region's lengths */
4090 diff
= (end2
- start2
) - (end1
- start1
);
4091 diff_byte
= (end2_byte
- start2_byte
) - (end1_byte
- start1_byte
);
4093 /* For shifting each marker in a region by the length of the other
4094 region plus the distance between the regions. */
4095 amt1
= (end2
- start2
) + (start2
- end1
);
4096 amt2
= (end1
- start1
) + (start2
- end1
);
4097 amt1_byte
= (end2_byte
- start2_byte
) + (start2_byte
- end1_byte
);
4098 amt2_byte
= (end1_byte
- start1_byte
) + (start2_byte
- end1_byte
);
4100 for (marker
= BUF_MARKERS (current_buffer
); marker
; marker
= marker
->next
)
4102 mpos
= marker
->bytepos
;
4103 if (mpos
>= start1_byte
&& mpos
< end2_byte
)
4105 if (mpos
< end1_byte
)
4107 else if (mpos
< start2_byte
)
4111 marker
->bytepos
= mpos
;
4113 mpos
= marker
->charpos
;
4114 if (mpos
>= start1
&& mpos
< end2
)
4118 else if (mpos
< start2
)
4123 marker
->charpos
= mpos
;
4127 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
4128 doc
: /* Transpose region STARTR1 to ENDR1 with STARTR2 to ENDR2.
4129 The regions may not be overlapping, because the size of the buffer is
4130 never changed in a transposition.
4132 Optional fifth arg LEAVE-MARKERS, if non-nil, means don't update
4133 any markers that happen to be located in the regions.
4135 Transposing beyond buffer boundaries is an error. */)
4136 (startr1
, endr1
, startr2
, endr2
, leave_markers
)
4137 Lisp_Object startr1
, endr1
, startr2
, endr2
, leave_markers
;
4139 register int start1
, end1
, start2
, end2
;
4140 int start1_byte
, start2_byte
, len1_byte
, len2_byte
;
4141 int gap
, len1
, len_mid
, len2
;
4142 unsigned char *start1_addr
, *start2_addr
, *temp
;
4144 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
;
4145 cur_intv
= BUF_INTERVALS (current_buffer
);
4147 validate_region (&startr1
, &endr1
);
4148 validate_region (&startr2
, &endr2
);
4150 start1
= XFASTINT (startr1
);
4151 end1
= XFASTINT (endr1
);
4152 start2
= XFASTINT (startr2
);
4153 end2
= XFASTINT (endr2
);
4156 /* Swap the regions if they're reversed. */
4159 register int glumph
= start1
;
4167 len1
= end1
- start1
;
4168 len2
= end2
- start2
;
4171 error ("Transposed regions overlap");
4172 else if (start1
== end1
|| start2
== end2
)
4173 error ("Transposed region has length 0");
4175 /* The possibilities are:
4176 1. Adjacent (contiguous) regions, or separate but equal regions
4177 (no, really equal, in this case!), or
4178 2. Separate regions of unequal size.
4180 The worst case is usually No. 2. It means that (aside from
4181 potential need for getting the gap out of the way), there also
4182 needs to be a shifting of the text between the two regions. So
4183 if they are spread far apart, we are that much slower... sigh. */
4185 /* It must be pointed out that the really studly thing to do would
4186 be not to move the gap at all, but to leave it in place and work
4187 around it if necessary. This would be extremely efficient,
4188 especially considering that people are likely to do
4189 transpositions near where they are working interactively, which
4190 is exactly where the gap would be found. However, such code
4191 would be much harder to write and to read. So, if you are
4192 reading this comment and are feeling squirrely, by all means have
4193 a go! I just didn't feel like doing it, so I will simply move
4194 the gap the minimum distance to get it out of the way, and then
4195 deal with an unbroken array. */
4197 /* Make sure the gap won't interfere, by moving it out of the text
4198 we will operate on. */
4199 if (start1
< gap
&& gap
< end2
)
4201 if (gap
- start1
< end2
- gap
)
4207 start1_byte
= CHAR_TO_BYTE (start1
);
4208 start2_byte
= CHAR_TO_BYTE (start2
);
4209 len1_byte
= CHAR_TO_BYTE (end1
) - start1_byte
;
4210 len2_byte
= CHAR_TO_BYTE (end2
) - start2_byte
;
4212 #ifdef BYTE_COMBINING_DEBUG
4215 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4216 len2_byte
, start1
, start1_byte
)
4217 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4218 len1_byte
, end2
, start2_byte
+ len2_byte
)
4219 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4220 len1_byte
, end2
, start2_byte
+ len2_byte
))
4225 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4226 len2_byte
, start1
, start1_byte
)
4227 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4228 len1_byte
, start2
, start2_byte
)
4229 || count_combining_after (BYTE_POS_ADDR (start2_byte
),
4230 len2_byte
, end1
, start1_byte
+ len1_byte
)
4231 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4232 len1_byte
, end2
, start2_byte
+ len2_byte
))
4237 /* Hmmm... how about checking to see if the gap is large
4238 enough to use as the temporary storage? That would avoid an
4239 allocation... interesting. Later, don't fool with it now. */
4241 /* Working without memmove, for portability (sigh), so must be
4242 careful of overlapping subsections of the array... */
4244 if (end1
== start2
) /* adjacent regions */
4246 modify_region (current_buffer
, start1
, end2
);
4247 record_change (start1
, len1
+ len2
);
4249 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4250 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4251 Fset_text_properties (make_number (start1
), make_number (end2
),
4254 /* First region smaller than second. */
4255 if (len1_byte
< len2_byte
)
4259 SAFE_ALLOCA (temp
, unsigned char *, len2_byte
);
4261 /* Don't precompute these addresses. We have to compute them
4262 at the last minute, because the relocating allocator might
4263 have moved the buffer around during the xmalloc. */
4264 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4265 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4267 bcopy (start2_addr
, temp
, len2_byte
);
4268 bcopy (start1_addr
, start1_addr
+ len2_byte
, len1_byte
);
4269 bcopy (temp
, start1_addr
, len2_byte
);
4273 /* First region not smaller than second. */
4277 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4278 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4279 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4280 bcopy (start1_addr
, temp
, len1_byte
);
4281 bcopy (start2_addr
, start1_addr
, len2_byte
);
4282 bcopy (temp
, start1_addr
+ len2_byte
, len1_byte
);
4285 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
4286 len1
, current_buffer
, 0);
4287 graft_intervals_into_buffer (tmp_interval2
, start1
,
4288 len2
, current_buffer
, 0);
4289 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4290 update_compositions (start1
+ len2
, end2
, CHECK_TAIL
);
4292 /* Non-adjacent regions, because end1 != start2, bleagh... */
4295 len_mid
= start2_byte
- (start1_byte
+ len1_byte
);
4297 if (len1_byte
== len2_byte
)
4298 /* Regions are same size, though, how nice. */
4302 modify_region (current_buffer
, start1
, end1
);
4303 modify_region (current_buffer
, start2
, end2
);
4304 record_change (start1
, len1
);
4305 record_change (start2
, len2
);
4306 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4307 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4308 Fset_text_properties (make_number (start1
), make_number (end1
),
4310 Fset_text_properties (make_number (start2
), make_number (end2
),
4313 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4314 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4315 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4316 bcopy (start1_addr
, temp
, len1_byte
);
4317 bcopy (start2_addr
, start1_addr
, len2_byte
);
4318 bcopy (temp
, start2_addr
, len1_byte
);
4321 graft_intervals_into_buffer (tmp_interval1
, start2
,
4322 len1
, current_buffer
, 0);
4323 graft_intervals_into_buffer (tmp_interval2
, start1
,
4324 len2
, current_buffer
, 0);
4327 else if (len1_byte
< len2_byte
) /* Second region larger than first */
4328 /* Non-adjacent & unequal size, area between must also be shifted. */
4332 modify_region (current_buffer
, start1
, end2
);
4333 record_change (start1
, (end2
- start1
));
4334 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4335 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4336 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4337 Fset_text_properties (make_number (start1
), make_number (end2
),
4340 /* holds region 2 */
4341 SAFE_ALLOCA (temp
, unsigned char *, len2_byte
);
4342 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4343 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4344 bcopy (start2_addr
, temp
, len2_byte
);
4345 bcopy (start1_addr
, start1_addr
+ len_mid
+ len2_byte
, len1_byte
);
4346 safe_bcopy (start1_addr
+ len1_byte
, start1_addr
+ len2_byte
, len_mid
);
4347 bcopy (temp
, start1_addr
, len2_byte
);
4350 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4351 len1
, current_buffer
, 0);
4352 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4353 len_mid
, current_buffer
, 0);
4354 graft_intervals_into_buffer (tmp_interval2
, start1
,
4355 len2
, current_buffer
, 0);
4358 /* Second region smaller than first. */
4362 record_change (start1
, (end2
- start1
));
4363 modify_region (current_buffer
, start1
, end2
);
4365 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4366 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4367 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4368 Fset_text_properties (make_number (start1
), make_number (end2
),
4371 /* holds region 1 */
4372 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4373 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4374 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4375 bcopy (start1_addr
, temp
, len1_byte
);
4376 bcopy (start2_addr
, start1_addr
, len2_byte
);
4377 bcopy (start1_addr
+ len1_byte
, start1_addr
+ len2_byte
, len_mid
);
4378 bcopy (temp
, start1_addr
+ len2_byte
+ len_mid
, len1_byte
);
4381 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4382 len1
, current_buffer
, 0);
4383 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4384 len_mid
, current_buffer
, 0);
4385 graft_intervals_into_buffer (tmp_interval2
, start1
,
4386 len2
, current_buffer
, 0);
4389 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4390 update_compositions (end2
- len1
, end2
, CHECK_BORDER
);
4393 /* When doing multiple transpositions, it might be nice
4394 to optimize this. Perhaps the markers in any one buffer
4395 should be organized in some sorted data tree. */
4396 if (NILP (leave_markers
))
4398 transpose_markers (start1
, end1
, start2
, end2
,
4399 start1_byte
, start1_byte
+ len1_byte
,
4400 start2_byte
, start2_byte
+ len2_byte
);
4401 fix_start_end_in_overlays (start1
, end2
);
4413 Qbuffer_access_fontify_functions
4414 = intern ("buffer-access-fontify-functions");
4415 staticpro (&Qbuffer_access_fontify_functions
);
4417 DEFVAR_LISP ("inhibit-field-text-motion", &Vinhibit_field_text_motion
,
4418 doc
: /* Non-nil means text motion commands don't notice fields. */);
4419 Vinhibit_field_text_motion
= Qnil
;
4421 DEFVAR_LISP ("buffer-access-fontify-functions",
4422 &Vbuffer_access_fontify_functions
,
4423 doc
: /* List of functions called by `buffer-substring' to fontify if necessary.
4424 Each function is called with two arguments which specify the range
4425 of the buffer being accessed. */);
4426 Vbuffer_access_fontify_functions
= Qnil
;
4430 extern Lisp_Object Vprin1_to_string_buffer
;
4431 obuf
= Fcurrent_buffer ();
4432 /* Do this here, because init_buffer_once is too early--it won't work. */
4433 Fset_buffer (Vprin1_to_string_buffer
);
4434 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
4435 Fset (Fmake_local_variable (intern ("buffer-access-fontify-functions")),
4440 DEFVAR_LISP ("buffer-access-fontified-property",
4441 &Vbuffer_access_fontified_property
,
4442 doc
: /* Property which (if non-nil) indicates text has been fontified.
4443 `buffer-substring' need not call the `buffer-access-fontify-functions'
4444 functions if all the text being accessed has this property. */);
4445 Vbuffer_access_fontified_property
= Qnil
;
4447 DEFVAR_LISP ("system-name", &Vsystem_name
,
4448 doc
: /* The name of the machine Emacs is running on. */);
4450 DEFVAR_LISP ("user-full-name", &Vuser_full_name
,
4451 doc
: /* The full name of the user logged in. */);
4453 DEFVAR_LISP ("user-login-name", &Vuser_login_name
,
4454 doc
: /* The user's name, taken from environment variables if possible. */);
4456 DEFVAR_LISP ("user-real-login-name", &Vuser_real_login_name
,
4457 doc
: /* The user's name, based upon the real uid only. */);
4459 DEFVAR_LISP ("operating-system-release", &Voperating_system_release
,
4460 doc
: /* The release of the operating system Emacs is running on. */);
4462 defsubr (&Spropertize
);
4463 defsubr (&Schar_equal
);
4464 defsubr (&Sgoto_char
);
4465 defsubr (&Sstring_to_char
);
4466 defsubr (&Schar_to_string
);
4467 defsubr (&Sbuffer_substring
);
4468 defsubr (&Sbuffer_substring_no_properties
);
4469 defsubr (&Sbuffer_string
);
4471 defsubr (&Spoint_marker
);
4472 defsubr (&Smark_marker
);
4474 defsubr (&Sregion_beginning
);
4475 defsubr (&Sregion_end
);
4477 staticpro (&Qfield
);
4478 Qfield
= intern ("field");
4479 staticpro (&Qboundary
);
4480 Qboundary
= intern ("boundary");
4481 defsubr (&Sfield_beginning
);
4482 defsubr (&Sfield_end
);
4483 defsubr (&Sfield_string
);
4484 defsubr (&Sfield_string_no_properties
);
4485 defsubr (&Sdelete_field
);
4486 defsubr (&Sconstrain_to_field
);
4488 defsubr (&Sline_beginning_position
);
4489 defsubr (&Sline_end_position
);
4491 /* defsubr (&Smark); */
4492 /* defsubr (&Sset_mark); */
4493 defsubr (&Ssave_excursion
);
4494 defsubr (&Ssave_current_buffer
);
4496 defsubr (&Sbufsize
);
4497 defsubr (&Spoint_max
);
4498 defsubr (&Spoint_min
);
4499 defsubr (&Spoint_min_marker
);
4500 defsubr (&Spoint_max_marker
);
4501 defsubr (&Sgap_position
);
4502 defsubr (&Sgap_size
);
4503 defsubr (&Sposition_bytes
);
4504 defsubr (&Sbyte_to_position
);
4510 defsubr (&Sfollowing_char
);
4511 defsubr (&Sprevious_char
);
4512 defsubr (&Schar_after
);
4513 defsubr (&Schar_before
);
4515 defsubr (&Sinsert_before_markers
);
4516 defsubr (&Sinsert_and_inherit
);
4517 defsubr (&Sinsert_and_inherit_before_markers
);
4518 defsubr (&Sinsert_char
);
4519 defsubr (&Sinsert_byte
);
4521 defsubr (&Suser_login_name
);
4522 defsubr (&Suser_real_login_name
);
4523 defsubr (&Suser_uid
);
4524 defsubr (&Suser_real_uid
);
4525 defsubr (&Suser_full_name
);
4526 defsubr (&Semacs_pid
);
4527 defsubr (&Scurrent_time
);
4528 defsubr (&Sget_internal_run_time
);
4529 defsubr (&Sformat_time_string
);
4530 defsubr (&Sfloat_time
);
4531 defsubr (&Sdecode_time
);
4532 defsubr (&Sencode_time
);
4533 defsubr (&Scurrent_time_string
);
4534 defsubr (&Scurrent_time_zone
);
4535 defsubr (&Sset_time_zone_rule
);
4536 defsubr (&Ssystem_name
);
4537 defsubr (&Smessage
);
4538 defsubr (&Smessage_box
);
4539 defsubr (&Smessage_or_box
);
4540 defsubr (&Scurrent_message
);
4543 defsubr (&Sinsert_buffer_substring
);
4544 defsubr (&Scompare_buffer_substrings
);
4545 defsubr (&Ssubst_char_in_region
);
4546 defsubr (&Stranslate_region_internal
);
4547 defsubr (&Sdelete_region
);
4548 defsubr (&Sdelete_and_extract_region
);
4550 defsubr (&Snarrow_to_region
);
4551 defsubr (&Ssave_restriction
);
4552 defsubr (&Stranspose_regions
);
4555 /* arch-tag: fc3827d8-6f60-4067-b11e-c3218031b018
4556 (do not change this comment) */