1 /* Lisp functions pertaining to editing.
2 Copyright (C) 1985,86,87,89,93,94,95,96,97,98, 1999, 2000, 2001
3 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
24 #include <sys/types.h>
39 #include "intervals.h"
41 #include "character.h"
50 #define MAX_10_EXP DBL_MAX_10_EXP
52 #define MAX_10_EXP 310
60 extern char **environ
;
63 extern Lisp_Object make_time
P_ ((time_t));
64 extern size_t emacs_strftimeu
P_ ((char *, size_t, const char *,
65 const struct tm
*, int));
66 static int tm_diff
P_ ((struct tm
*, struct tm
*));
67 static void find_field
P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
, int *, Lisp_Object
, int *));
68 static void update_buffer_properties
P_ ((int, int));
69 static Lisp_Object region_limit
P_ ((int));
70 static int lisp_time_argument
P_ ((Lisp_Object
, time_t *, int *));
71 static size_t emacs_memftimeu
P_ ((char *, size_t, const char *,
72 size_t, const struct tm
*, int));
73 static void general_insert_function
P_ ((void (*) (unsigned char *, int),
74 void (*) (Lisp_Object
, int, int, int,
76 int, int, Lisp_Object
*));
77 static Lisp_Object subst_char_in_region_unwind
P_ ((Lisp_Object
));
78 static Lisp_Object subst_char_in_region_unwind_1
P_ ((Lisp_Object
));
79 static void transpose_markers
P_ ((int, int, int, int, int, int, int, int));
82 extern char *index
P_ ((const char *, int));
85 Lisp_Object Vbuffer_access_fontify_functions
;
86 Lisp_Object Qbuffer_access_fontify_functions
;
87 Lisp_Object Vbuffer_access_fontified_property
;
89 Lisp_Object Fuser_full_name
P_ ((Lisp_Object
));
91 /* Non-nil means don't stop at field boundary in text motion commands. */
93 Lisp_Object Vinhibit_field_text_motion
;
95 /* Some static data, and a function to initialize it for each run */
97 Lisp_Object Vsystem_name
;
98 Lisp_Object Vuser_real_login_name
; /* login name of current user ID */
99 Lisp_Object Vuser_full_name
; /* full name of current user */
100 Lisp_Object Vuser_login_name
; /* user name from LOGNAME or USER */
102 /* Symbol for the text property used to mark fields. */
106 /* A special value for Qfield properties. */
108 Lisp_Object Qboundary
;
115 register unsigned char *p
;
116 struct passwd
*pw
; /* password entry for the current user */
119 /* Set up system_name even when dumping. */
123 /* Don't bother with this on initial start when just dumping out */
126 #endif /* not CANNOT_DUMP */
128 pw
= (struct passwd
*) getpwuid (getuid ());
130 /* We let the real user name default to "root" because that's quite
131 accurate on MSDOG and because it lets Emacs find the init file.
132 (The DVX libraries override the Djgpp libraries here.) */
133 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "root");
135 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "unknown");
138 /* Get the effective user name, by consulting environment variables,
139 or the effective uid if those are unset. */
140 user_name
= (char *) getenv ("LOGNAME");
143 user_name
= (char *) getenv ("USERNAME"); /* it's USERNAME on NT */
144 #else /* WINDOWSNT */
145 user_name
= (char *) getenv ("USER");
146 #endif /* WINDOWSNT */
149 pw
= (struct passwd
*) getpwuid (geteuid ());
150 user_name
= (char *) (pw
? pw
->pw_name
: "unknown");
152 Vuser_login_name
= build_string (user_name
);
154 /* If the user name claimed in the environment vars differs from
155 the real uid, use the claimed name to find the full name. */
156 tem
= Fstring_equal (Vuser_login_name
, Vuser_real_login_name
);
157 Vuser_full_name
= Fuser_full_name (NILP (tem
)? make_number (geteuid())
160 p
= (unsigned char *) getenv ("NAME");
162 Vuser_full_name
= build_string (p
);
163 else if (NILP (Vuser_full_name
))
164 Vuser_full_name
= build_string ("unknown");
167 DEFUN ("char-to-string", Fchar_to_string
, Schar_to_string
, 1, 1, 0,
168 doc
: /* Convert arg CHAR to a string containing that character.
169 usage: (char-to-string CHAR) */)
171 Lisp_Object character
;
174 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
176 CHECK_NUMBER (character
);
178 len
= CHAR_STRING (XFASTINT (character
), str
);
179 return make_string_from_bytes (str
, 1, len
);
182 DEFUN ("string-to-char", Fstring_to_char
, Sstring_to_char
, 1, 1, 0,
183 doc
: /* Convert arg STRING to a character, the first character of that string.
184 A multibyte character is handled correctly. */)
186 register Lisp_Object string
;
188 register Lisp_Object val
;
189 register struct Lisp_String
*p
;
190 CHECK_STRING (string
);
191 p
= XSTRING (string
);
194 if (STRING_MULTIBYTE (string
))
195 XSETFASTINT (val
, STRING_CHAR (p
->data
, STRING_BYTES (p
)));
197 XSETFASTINT (val
, p
->data
[0]);
200 XSETFASTINT (val
, 0);
205 buildmark (charpos
, bytepos
)
206 int charpos
, bytepos
;
208 register Lisp_Object mark
;
209 mark
= Fmake_marker ();
210 set_marker_both (mark
, Qnil
, charpos
, bytepos
);
214 DEFUN ("point", Fpoint
, Spoint
, 0, 0, 0,
215 doc
: /* Return value of point, as an integer.
216 Beginning of buffer is position (point-min). */)
220 XSETFASTINT (temp
, PT
);
224 DEFUN ("point-marker", Fpoint_marker
, Spoint_marker
, 0, 0, 0,
225 doc
: /* Return value of point, as a marker object. */)
228 return buildmark (PT
, PT_BYTE
);
232 clip_to_bounds (lower
, num
, upper
)
233 int lower
, num
, upper
;
237 else if (num
> upper
)
243 DEFUN ("goto-char", Fgoto_char
, Sgoto_char
, 1, 1, "NGoto char: ",
244 doc
: /* Set point to POSITION, a number or marker.
245 Beginning of buffer is position (point-min), end is (point-max).
246 If the position is in the middle of a multibyte form,
247 the actual point is set at the head of the multibyte form
248 except in the case that `enable-multibyte-characters' is nil. */)
250 register Lisp_Object position
;
254 if (MARKERP (position
)
255 && current_buffer
== XMARKER (position
)->buffer
)
257 pos
= marker_position (position
);
259 SET_PT_BOTH (BEGV
, BEGV_BYTE
);
261 SET_PT_BOTH (ZV
, ZV_BYTE
);
263 SET_PT_BOTH (pos
, marker_byte_position (position
));
268 CHECK_NUMBER_COERCE_MARKER (position
);
270 pos
= clip_to_bounds (BEGV
, XINT (position
), ZV
);
276 /* Return the start or end position of the region.
277 BEGINNINGP non-zero means return the start.
278 If there is no region active, signal an error. */
281 region_limit (beginningp
)
284 extern Lisp_Object Vmark_even_if_inactive
; /* Defined in callint.c. */
287 if (!NILP (Vtransient_mark_mode
)
288 && NILP (Vmark_even_if_inactive
)
289 && NILP (current_buffer
->mark_active
))
290 Fsignal (Qmark_inactive
, Qnil
);
292 m
= Fmarker_position (current_buffer
->mark
);
294 error ("The mark is not set now, so there is no region");
296 if ((PT
< XFASTINT (m
)) == beginningp
)
297 m
= make_number (PT
);
301 DEFUN ("region-beginning", Fregion_beginning
, Sregion_beginning
, 0, 0, 0,
302 doc
: /* Return position of beginning of region, as an integer. */)
305 return region_limit (1);
308 DEFUN ("region-end", Fregion_end
, Sregion_end
, 0, 0, 0,
309 doc
: /* Return position of end of region, as an integer. */)
312 return region_limit (0);
315 DEFUN ("mark-marker", Fmark_marker
, Smark_marker
, 0, 0, 0,
316 doc
: /* Return this buffer's mark, as a marker object.
317 Watch out! Moving this marker changes the mark position.
318 If you set the marker not to point anywhere, the buffer will have no mark. */)
321 return current_buffer
->mark
;
325 #if 0 /* Not used. */
327 /* Return nonzero if POS1 and POS2 have the same value
328 for the text property PROP. */
331 char_property_eq (prop
, pos1
, pos2
)
333 Lisp_Object pos1
, pos2
;
335 Lisp_Object pval1
, pval2
;
337 pval1
= Fget_char_property (pos1
, prop
, Qnil
);
338 pval2
= Fget_char_property (pos2
, prop
, Qnil
);
340 return EQ (pval1
, pval2
);
345 /* Return the direction from which the text-property PROP would be
346 inherited by any new text inserted at POS: 1 if it would be
347 inherited from the char after POS, -1 if it would be inherited from
348 the char before POS, and 0 if from neither. */
351 text_property_stickiness (prop
, pos
)
355 Lisp_Object prev_pos
, front_sticky
;
356 int is_rear_sticky
= 1, is_front_sticky
= 0; /* defaults */
358 if (XINT (pos
) > BEGV
)
359 /* Consider previous character. */
361 Lisp_Object rear_non_sticky
;
363 prev_pos
= make_number (XINT (pos
) - 1);
364 rear_non_sticky
= Fget_text_property (prev_pos
, Qrear_nonsticky
, Qnil
);
366 if (!NILP (CONSP (rear_non_sticky
)
367 ? Fmemq (prop
, rear_non_sticky
)
369 /* PROP is rear-non-sticky. */
373 /* Consider following character. */
374 front_sticky
= Fget_text_property (pos
, Qfront_sticky
, Qnil
);
376 if (EQ (front_sticky
, Qt
)
377 || (CONSP (front_sticky
)
378 && !NILP (Fmemq (prop
, front_sticky
))))
379 /* PROP is inherited from after. */
382 /* Simple cases, where the properties are consistent. */
383 if (is_rear_sticky
&& !is_front_sticky
)
385 else if (!is_rear_sticky
&& is_front_sticky
)
387 else if (!is_rear_sticky
&& !is_front_sticky
)
390 /* The stickiness properties are inconsistent, so we have to
391 disambiguate. Basically, rear-sticky wins, _except_ if the
392 property that would be inherited has a value of nil, in which case
393 front-sticky wins. */
394 if (XINT (pos
) == BEGV
|| NILP (Fget_text_property (prev_pos
, prop
, Qnil
)))
401 /* Find the field surrounding POS in *BEG and *END. If POS is nil,
402 the value of point is used instead. If BEG or END null,
403 means don't store the beginning or end of the field.
405 BEG_LIMIT and END_LIMIT serve to limit the ranged of the returned
406 results; they do not effect boundary behavior.
408 If MERGE_AT_BOUNDARY is nonzero, then if POS is at the very first
409 position of a field, then the beginning of the previous field is
410 returned instead of the beginning of POS's field (since the end of a
411 field is actually also the beginning of the next input field, this
412 behavior is sometimes useful). Additionally in the MERGE_AT_BOUNDARY
413 true case, if two fields are separated by a field with the special
414 value `boundary', and POS lies within it, then the two separated
415 fields are considered to be adjacent, and POS between them, when
416 finding the beginning and ending of the "merged" field.
418 Either BEG or END may be 0, in which case the corresponding value
422 find_field (pos
, merge_at_boundary
, beg_limit
, beg
, end_limit
, end
)
424 Lisp_Object merge_at_boundary
;
425 Lisp_Object beg_limit
, end_limit
;
428 /* Fields right before and after the point. */
429 Lisp_Object before_field
, after_field
;
430 /* If the fields came from overlays, the associated overlays.
431 Qnil means they came from text-properties. */
432 Lisp_Object before_overlay
= Qnil
, after_overlay
= Qnil
;
433 /* 1 if POS counts as the start of a field. */
434 int at_field_start
= 0;
435 /* 1 if POS counts as the end of a field. */
436 int at_field_end
= 0;
439 XSETFASTINT (pos
, PT
);
441 CHECK_NUMBER_COERCE_MARKER (pos
);
444 = get_char_property_and_overlay (pos
, Qfield
, Qnil
, &after_overlay
);
446 = (XFASTINT (pos
) > BEGV
447 ? get_char_property_and_overlay (make_number (XINT (pos
) - 1),
452 /* See if we need to handle the case where MERGE_AT_BOUNDARY is nil
453 and POS is at beginning of a field, which can also be interpreted
454 as the end of the previous field. Note that the case where if
455 MERGE_AT_BOUNDARY is non-nil (see function comment) is actually the
456 more natural one; then we avoid treating the beginning of a field
458 if (NILP (merge_at_boundary
) && !EQ (after_field
, before_field
))
459 /* We are at a boundary, see which direction is inclusive. We
460 decide by seeing which field the `field' property sticks to. */
462 /* -1 means insertions go into before_field, 1 means they go
463 into after_field, 0 means neither. */
465 /* Whether the before/after_field come from overlays. */
466 int bop
= !NILP (before_overlay
);
467 int aop
= !NILP (after_overlay
);
469 if (bop
&& XMARKER (OVERLAY_END (before_overlay
))->insertion_type
== 1)
470 /* before_field is from an overlay, which expands upon
471 end-insertions. Note that it's possible for after_overlay to
472 also eat insertions here, but then they will overlap, and
473 there's not much we can do. */
476 && XMARKER (OVERLAY_START (after_overlay
))->insertion_type
== 0)
477 /* after_field is from an overlay, which expand to contain
481 /* Both fields come from overlays, but neither will contain any
485 /* before_field is an overlay that won't eat any insertion, but
486 after_field is from a text-property. Assume that the
487 text-property continues underneath the overlay, and so will
488 be inherited by any insertion, regardless of any stickiness
492 /* Similarly, when after_field is the overlay. */
495 /* Both fields come from text-properties. Look for explicit
496 stickiness properties. */
497 stickiness
= text_property_stickiness (Qfield
, pos
);
501 else if (stickiness
< 0)
504 /* STICKINESS == 0 means that any inserted text will get a
505 `field' char-property of nil, so check to see if that
506 matches either of the adjacent characters (this being a
507 kind of "stickiness by default"). */
509 if (NILP (before_field
))
510 at_field_end
= 1; /* Sticks to the left. */
511 else if (NILP (after_field
))
512 at_field_start
= 1; /* Sticks to the right. */
516 /* Note about special `boundary' fields:
518 Consider the case where the point (`.') is between the fields `x' and `y':
522 In this situation, if merge_at_boundary is true, we consider the
523 `x' and `y' fields as forming one big merged field, and so the end
524 of the field is the end of `y'.
526 However, if `x' and `y' are separated by a special `boundary' field
527 (a field with a `field' char-property of 'boundary), then we ignore
528 this special field when merging adjacent fields. Here's the same
529 situation, but with a `boundary' field between the `x' and `y' fields:
533 Here, if point is at the end of `x', the beginning of `y', or
534 anywhere in-between (within the `boundary' field), we merge all
535 three fields and consider the beginning as being the beginning of
536 the `x' field, and the end as being the end of the `y' field. */
541 /* POS is at the edge of a field, and we should consider it as
542 the beginning of the following field. */
543 *beg
= XFASTINT (pos
);
545 /* Find the previous field boundary. */
547 if (!NILP (merge_at_boundary
) && EQ (before_field
, Qboundary
))
548 /* Skip a `boundary' field. */
549 pos
= Fprevious_single_char_property_change (pos
, Qfield
, Qnil
,
552 pos
= Fprevious_single_char_property_change (pos
, Qfield
, Qnil
,
554 *beg
= NILP (pos
) ? BEGV
: XFASTINT (pos
);
561 /* POS is at the edge of a field, and we should consider it as
562 the end of the previous field. */
563 *end
= XFASTINT (pos
);
565 /* Find the next field boundary. */
567 if (!NILP (merge_at_boundary
) && EQ (after_field
, Qboundary
))
568 /* Skip a `boundary' field. */
569 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
572 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
574 *end
= NILP (pos
) ? ZV
: XFASTINT (pos
);
580 DEFUN ("delete-field", Fdelete_field
, Sdelete_field
, 0, 1, 0,
581 doc
: /* Delete the field surrounding POS.
582 A field is a region of text with the same `field' property.
583 If POS is nil, the value of point is used for POS. */)
588 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
590 del_range (beg
, end
);
594 DEFUN ("field-string", Ffield_string
, Sfield_string
, 0, 1, 0,
595 doc
: /* Return the contents of the field surrounding POS as a string.
596 A field is a region of text with the same `field' property.
597 If POS is nil, the value of point is used for POS. */)
602 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
603 return make_buffer_string (beg
, end
, 1);
606 DEFUN ("field-string-no-properties", Ffield_string_no_properties
, Sfield_string_no_properties
, 0, 1, 0,
607 doc
: /* Return the contents of the field around POS, without text-properties.
608 A field is a region of text with the same `field' property.
609 If POS is nil, the value of point is used for POS. */)
614 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
615 return make_buffer_string (beg
, end
, 0);
618 DEFUN ("field-beginning", Ffield_beginning
, Sfield_beginning
, 0, 3, 0,
619 doc
: /* Return the beginning of the field surrounding POS.
620 A field is a region of text with the same `field' property.
621 If POS is nil, the value of point is used for POS.
622 If ESCAPE-FROM-EDGE is non-nil and POS is at the beginning of its
623 field, then the beginning of the *previous* field is returned.
624 If LIMIT is non-nil, it is a buffer position; if the beginning of the field
625 is before LIMIT, then LIMIT will be returned instead. */)
626 (pos
, escape_from_edge
, limit
)
627 Lisp_Object pos
, escape_from_edge
, limit
;
630 find_field (pos
, escape_from_edge
, limit
, &beg
, Qnil
, 0);
631 return make_number (beg
);
634 DEFUN ("field-end", Ffield_end
, Sfield_end
, 0, 3, 0,
635 doc
: /* Return the end of the field surrounding POS.
636 A field is a region of text with the same `field' property.
637 If POS is nil, the value of point is used for POS.
638 If ESCAPE-FROM-EDGE is non-nil and POS is at the end of its field,
639 then the end of the *following* field is returned.
640 If LIMIT is non-nil, it is a buffer position; if the end of the field
641 is after LIMIT, then LIMIT will be returned instead. */)
642 (pos
, escape_from_edge
, limit
)
643 Lisp_Object pos
, escape_from_edge
, limit
;
646 find_field (pos
, escape_from_edge
, Qnil
, 0, limit
, &end
);
647 return make_number (end
);
650 DEFUN ("constrain-to-field", Fconstrain_to_field
, Sconstrain_to_field
, 2, 5, 0,
651 doc
: /* Return the position closest to NEW-POS that is in the same field as OLD-POS.
653 A field is a region of text with the same `field' property.
654 If NEW-POS is nil, then the current point is used instead, and set to the
655 constrained position if that is different.
657 If OLD-POS is at the boundary of two fields, then the allowable
658 positions for NEW-POS depends on the value of the optional argument
659 ESCAPE-FROM-EDGE: If ESCAPE-FROM-EDGE is nil, then NEW-POS is
660 constrained to the field that has the same `field' char-property
661 as any new characters inserted at OLD-POS, whereas if ESCAPE-FROM-EDGE
662 is non-nil, NEW-POS is constrained to the union of the two adjacent
663 fields. Additionally, if two fields are separated by another field with
664 the special value `boundary', then any point within this special field is
665 also considered to be `on the boundary'.
667 If the optional argument ONLY-IN-LINE is non-nil and constraining
668 NEW-POS would move it to a different line, NEW-POS is returned
669 unconstrained. This useful for commands that move by line, like
670 \\[next-line] or \\[beginning-of-line], which should generally respect field boundaries
671 only in the case where they can still move to the right line.
673 If the optional argument INHIBIT-CAPTURE-PROPERTY is non-nil, and OLD-POS has
674 a non-nil property of that name, then any field boundaries are ignored.
676 Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */)
677 (new_pos
, old_pos
, escape_from_edge
, only_in_line
, inhibit_capture_property
)
678 Lisp_Object new_pos
, old_pos
;
679 Lisp_Object escape_from_edge
, only_in_line
, inhibit_capture_property
;
681 /* If non-zero, then the original point, before re-positioning. */
685 /* Use the current point, and afterwards, set it. */
688 XSETFASTINT (new_pos
, PT
);
691 if (NILP (Vinhibit_field_text_motion
)
692 && !EQ (new_pos
, old_pos
)
693 && (!NILP (Fget_char_property (new_pos
, Qfield
, Qnil
))
694 || !NILP (Fget_char_property (old_pos
, Qfield
, Qnil
)))
695 && (NILP (inhibit_capture_property
)
696 || NILP (Fget_char_property(old_pos
, inhibit_capture_property
, Qnil
))))
697 /* NEW_POS is not within the same field as OLD_POS; try to
698 move NEW_POS so that it is. */
701 Lisp_Object field_bound
;
703 CHECK_NUMBER_COERCE_MARKER (new_pos
);
704 CHECK_NUMBER_COERCE_MARKER (old_pos
);
706 fwd
= (XFASTINT (new_pos
) > XFASTINT (old_pos
));
709 field_bound
= Ffield_end (old_pos
, escape_from_edge
, new_pos
);
711 field_bound
= Ffield_beginning (old_pos
, escape_from_edge
, new_pos
);
713 if (/* See if ESCAPE_FROM_EDGE caused FIELD_BOUND to jump to the
714 other side of NEW_POS, which would mean that NEW_POS is
715 already acceptable, and it's not necessary to constrain it
717 ((XFASTINT (field_bound
) < XFASTINT (new_pos
)) ? fwd
: !fwd
)
718 /* NEW_POS should be constrained, but only if either
719 ONLY_IN_LINE is nil (in which case any constraint is OK),
720 or NEW_POS and FIELD_BOUND are on the same line (in which
721 case the constraint is OK even if ONLY_IN_LINE is non-nil). */
722 && (NILP (only_in_line
)
723 /* This is the ONLY_IN_LINE case, check that NEW_POS and
724 FIELD_BOUND are on the same line by seeing whether
725 there's an intervening newline or not. */
726 || (scan_buffer ('\n',
727 XFASTINT (new_pos
), XFASTINT (field_bound
),
728 fwd
? -1 : 1, &shortage
, 1),
730 /* Constrain NEW_POS to FIELD_BOUND. */
731 new_pos
= field_bound
;
733 if (orig_point
&& XFASTINT (new_pos
) != orig_point
)
734 /* The NEW_POS argument was originally nil, so automatically set PT. */
735 SET_PT (XFASTINT (new_pos
));
742 DEFUN ("line-beginning-position",
743 Fline_beginning_position
, Sline_beginning_position
, 0, 1, 0,
744 doc
: /* Return the character position of the first character on the current line.
745 With argument N not nil or 1, move forward N - 1 lines first.
746 If scan reaches end of buffer, return that position.
748 The scan does not cross a field boundary unless doing so would move
749 beyond there to a different line; if N is nil or 1, and scan starts at a
750 field boundary, the scan stops as soon as it starts. To ignore field
751 boundaries bind `inhibit-field-text-motion' to t.
753 This function does not move point. */)
757 int orig
, orig_byte
, end
;
766 Fforward_line (make_number (XINT (n
) - 1));
769 SET_PT_BOTH (orig
, orig_byte
);
771 /* Return END constrained to the current input field. */
772 return Fconstrain_to_field (make_number (end
), make_number (orig
),
773 XINT (n
) != 1 ? Qt
: Qnil
,
777 DEFUN ("line-end-position", Fline_end_position
, Sline_end_position
, 0, 1, 0,
778 doc
: /* Return the character position of the last 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. */)
799 end_pos
= find_before_next_newline (orig
, 0, XINT (n
) - (XINT (n
) <= 0));
801 /* Return END_POS constrained to the current input field. */
802 return Fconstrain_to_field (make_number (end_pos
), make_number (orig
),
808 save_excursion_save ()
810 int visible
= (XBUFFER (XWINDOW (selected_window
)->buffer
)
813 return Fcons (Fpoint_marker (),
814 Fcons (Fcopy_marker (current_buffer
->mark
, Qnil
),
815 Fcons (visible
? Qt
: Qnil
,
816 Fcons (current_buffer
->mark_active
,
821 save_excursion_restore (info
)
824 Lisp_Object tem
, tem1
, omark
, nmark
;
825 struct gcpro gcpro1
, gcpro2
, gcpro3
;
828 tem
= Fmarker_buffer (XCAR (info
));
829 /* If buffer being returned to is now deleted, avoid error */
830 /* Otherwise could get error here while unwinding to top level
832 /* In that case, Fmarker_buffer returns nil now. */
836 omark
= nmark
= Qnil
;
837 GCPRO3 (info
, omark
, nmark
);
844 unchain_marker (tem
);
849 omark
= Fmarker_position (current_buffer
->mark
);
850 Fset_marker (current_buffer
->mark
, tem
, Fcurrent_buffer ());
851 nmark
= Fmarker_position (tem
);
852 unchain_marker (tem
);
856 visible_p
= !NILP (XCAR (info
));
858 #if 0 /* We used to make the current buffer visible in the selected window
859 if that was true previously. That avoids some anomalies.
860 But it creates others, and it wasn't documented, and it is simpler
861 and cleaner never to alter the window/buffer connections. */
864 && current_buffer
!= XBUFFER (XWINDOW (selected_window
)->buffer
))
865 Fswitch_to_buffer (Fcurrent_buffer (), Qnil
);
871 tem1
= current_buffer
->mark_active
;
872 current_buffer
->mark_active
= tem
;
874 if (!NILP (Vrun_hooks
))
876 /* If mark is active now, and either was not active
877 or was at a different place, run the activate hook. */
878 if (! NILP (current_buffer
->mark_active
))
880 if (! EQ (omark
, nmark
))
881 call1 (Vrun_hooks
, intern ("activate-mark-hook"));
883 /* If mark has ceased to be active, run deactivate hook. */
884 else if (! NILP (tem1
))
885 call1 (Vrun_hooks
, intern ("deactivate-mark-hook"));
888 /* If buffer was visible in a window, and a different window was
889 selected, and the old selected window is still showing this
890 buffer, restore point in that window. */
893 && !EQ (tem
, selected_window
)
894 && (tem1
= XWINDOW (tem
)->buffer
,
895 (/* Window is live... */
897 /* ...and it shows the current buffer. */
898 && XBUFFER (tem1
) == current_buffer
)))
899 Fset_window_point (tem
, make_number (PT
));
905 DEFUN ("save-excursion", Fsave_excursion
, Ssave_excursion
, 0, UNEVALLED
, 0,
906 doc
: /* Save point, mark, and current buffer; execute BODY; restore those things.
907 Executes BODY just like `progn'.
908 The values of point, mark and the current buffer are restored
909 even in case of abnormal exit (throw or error).
910 The state of activation of the mark is also restored.
912 This construct does not save `deactivate-mark', and therefore
913 functions that change the buffer will still cause deactivation
914 of the mark at the end of the command. To prevent that, bind
915 `deactivate-mark' with `let'.
917 usage: (save-excursion &rest BODY) */)
921 register Lisp_Object val
;
922 int count
= specpdl_ptr
- specpdl
;
924 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
927 return unbind_to (count
, val
);
930 DEFUN ("save-current-buffer", Fsave_current_buffer
, Ssave_current_buffer
, 0, UNEVALLED
, 0,
931 doc
: /* Save the current buffer; execute BODY; restore the current buffer.
932 Executes BODY just like `progn'.
933 usage: (save-current-buffer &rest BODY) */)
938 int count
= specpdl_ptr
- specpdl
;
940 record_unwind_protect (set_buffer_if_live
, Fcurrent_buffer ());
943 return unbind_to (count
, val
);
946 DEFUN ("buffer-size", Fbufsize
, Sbufsize
, 0, 1, 0,
947 doc
: /* Return the number of characters in the current buffer.
948 If BUFFER, return the number of characters in that buffer instead. */)
953 return make_number (Z
- BEG
);
956 CHECK_BUFFER (buffer
);
957 return make_number (BUF_Z (XBUFFER (buffer
))
958 - BUF_BEG (XBUFFER (buffer
)));
962 DEFUN ("point-min", Fpoint_min
, Spoint_min
, 0, 0, 0,
963 doc
: /* Return the minimum permissible value of point in the current buffer.
964 This is 1, unless narrowing (a buffer restriction) is in effect. */)
968 XSETFASTINT (temp
, BEGV
);
972 DEFUN ("point-min-marker", Fpoint_min_marker
, Spoint_min_marker
, 0, 0, 0,
973 doc
: /* Return a marker to the minimum permissible value of point in this buffer.
974 This is the beginning, unless narrowing (a buffer restriction) is in effect. */)
977 return buildmark (BEGV
, BEGV_BYTE
);
980 DEFUN ("point-max", Fpoint_max
, Spoint_max
, 0, 0, 0,
981 doc
: /* Return the maximum permissible value of point in the current buffer.
982 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
983 is in effect, in which case it is less. */)
987 XSETFASTINT (temp
, ZV
);
991 DEFUN ("point-max-marker", Fpoint_max_marker
, Spoint_max_marker
, 0, 0, 0,
992 doc
: /* Return a marker to the maximum permissible value of point in this buffer.
993 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
994 is in effect, in which case it is less. */)
997 return buildmark (ZV
, ZV_BYTE
);
1000 DEFUN ("gap-position", Fgap_position
, Sgap_position
, 0, 0, 0,
1001 doc
: /* Return the position of the gap, in the current buffer.
1002 See also `gap-size'. */)
1006 XSETFASTINT (temp
, GPT
);
1010 DEFUN ("gap-size", Fgap_size
, Sgap_size
, 0, 0, 0,
1011 doc
: /* Return the size of the current buffer's gap.
1012 See also `gap-position'. */)
1016 XSETFASTINT (temp
, GAP_SIZE
);
1020 DEFUN ("position-bytes", Fposition_bytes
, Sposition_bytes
, 1, 1, 0,
1021 doc
: /* Return the byte position for character position POSITION.
1022 If POSITION is out of range, the value is nil. */)
1024 Lisp_Object position
;
1026 CHECK_NUMBER_COERCE_MARKER (position
);
1027 if (XINT (position
) < BEG
|| XINT (position
) > Z
)
1029 return make_number (CHAR_TO_BYTE (XINT (position
)));
1032 DEFUN ("byte-to-position", Fbyte_to_position
, Sbyte_to_position
, 1, 1, 0,
1033 doc
: /* Return the character position for byte position BYTEPOS.
1034 If BYTEPOS is out of range, the value is nil. */)
1036 Lisp_Object bytepos
;
1038 CHECK_NUMBER (bytepos
);
1039 if (XINT (bytepos
) < BEG_BYTE
|| XINT (bytepos
) > Z_BYTE
)
1041 return make_number (BYTE_TO_CHAR (XINT (bytepos
)));
1044 DEFUN ("following-char", Ffollowing_char
, Sfollowing_char
, 0, 0, 0,
1045 doc
: /* Return the character following point, as a number.
1046 At the end of the buffer or accessible region, return 0. */)
1051 XSETFASTINT (temp
, 0);
1053 XSETFASTINT (temp
, FETCH_CHAR (PT_BYTE
));
1057 DEFUN ("preceding-char", Fprevious_char
, Sprevious_char
, 0, 0, 0,
1058 doc
: /* Return the character preceding point, as a number.
1059 At the beginning of the buffer or accessible region, return 0. */)
1064 XSETFASTINT (temp
, 0);
1065 else if (!NILP (current_buffer
->enable_multibyte_characters
))
1069 XSETFASTINT (temp
, FETCH_CHAR (pos
));
1072 XSETFASTINT (temp
, FETCH_BYTE (PT_BYTE
- 1));
1076 DEFUN ("bobp", Fbobp
, Sbobp
, 0, 0, 0,
1077 doc
: /* Return t if point is at the beginning of the buffer.
1078 If the buffer is narrowed, this means the beginning of the narrowed part. */)
1086 DEFUN ("eobp", Feobp
, Seobp
, 0, 0, 0,
1087 doc
: /* Return t if point is at the end of the buffer.
1088 If the buffer is narrowed, this means the end of the narrowed part. */)
1096 DEFUN ("bolp", Fbolp
, Sbolp
, 0, 0, 0,
1097 doc
: /* Return t if point is at the beginning of a line. */)
1100 if (PT
== BEGV
|| FETCH_BYTE (PT_BYTE
- 1) == '\n')
1105 DEFUN ("eolp", Feolp
, Seolp
, 0, 0, 0,
1106 doc
: /* Return t if point is at the end of a line.
1107 `End of a line' includes point being at the end of the buffer. */)
1110 if (PT
== ZV
|| FETCH_BYTE (PT_BYTE
) == '\n')
1115 DEFUN ("char-after", Fchar_after
, Schar_after
, 0, 1, 0,
1116 doc
: /* Return character in current buffer at position POS.
1117 POS is an integer or a marker.
1118 If POS is out of range, the value is nil. */)
1122 register int pos_byte
;
1127 XSETFASTINT (pos
, PT
);
1132 pos_byte
= marker_byte_position (pos
);
1133 if (pos_byte
< BEGV_BYTE
|| pos_byte
>= ZV_BYTE
)
1138 CHECK_NUMBER_COERCE_MARKER (pos
);
1139 if (XINT (pos
) < BEGV
|| XINT (pos
) >= ZV
)
1142 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1145 return make_number (FETCH_CHAR (pos_byte
));
1148 DEFUN ("char-before", Fchar_before
, Schar_before
, 0, 1, 0,
1149 doc
: /* Return character in current buffer preceding position POS.
1150 POS is an integer or a marker.
1151 If POS is out of range, the value is nil. */)
1155 register Lisp_Object val
;
1156 register int pos_byte
;
1161 XSETFASTINT (pos
, PT
);
1166 pos_byte
= marker_byte_position (pos
);
1168 if (pos_byte
<= BEGV_BYTE
|| pos_byte
> ZV_BYTE
)
1173 CHECK_NUMBER_COERCE_MARKER (pos
);
1175 if (XINT (pos
) <= BEGV
|| XINT (pos
) > ZV
)
1178 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1181 if (!NILP (current_buffer
->enable_multibyte_characters
))
1184 XSETFASTINT (val
, FETCH_CHAR (pos_byte
));
1189 XSETFASTINT (val
, FETCH_BYTE (pos_byte
));
1194 DEFUN ("user-login-name", Fuser_login_name
, Suser_login_name
, 0, 1, 0,
1195 doc
: /* Return the name under which the user logged in, as a string.
1196 This is based on the effective uid, not the real uid.
1197 Also, if the environment variable LOGNAME or USER is set,
1198 that determines the value of this function.
1200 If optional argument UID is an integer, return the login name of the user
1201 with that uid, or nil if there is no such user. */)
1207 /* Set up the user name info if we didn't do it before.
1208 (That can happen if Emacs is dumpable
1209 but you decide to run `temacs -l loadup' and not dump. */
1210 if (INTEGERP (Vuser_login_name
))
1214 return Vuser_login_name
;
1217 pw
= (struct passwd
*) getpwuid (XINT (uid
));
1218 return (pw
? build_string (pw
->pw_name
) : Qnil
);
1221 DEFUN ("user-real-login-name", Fuser_real_login_name
, Suser_real_login_name
,
1223 doc
: /* Return the name of the user's real uid, as a string.
1224 This ignores the environment variables LOGNAME and USER, so it differs from
1225 `user-login-name' when running under `su'. */)
1228 /* Set up the user name info if we didn't do it before.
1229 (That can happen if Emacs is dumpable
1230 but you decide to run `temacs -l loadup' and not dump. */
1231 if (INTEGERP (Vuser_login_name
))
1233 return Vuser_real_login_name
;
1236 DEFUN ("user-uid", Fuser_uid
, Suser_uid
, 0, 0, 0,
1237 doc
: /* Return the effective uid of Emacs.
1238 Value is an integer or float, depending on the value. */)
1241 return make_fixnum_or_float (geteuid ());
1244 DEFUN ("user-real-uid", Fuser_real_uid
, Suser_real_uid
, 0, 0, 0,
1245 doc
: /* Return the real uid of Emacs.
1246 Value is an integer or float, depending on the value. */)
1249 return make_fixnum_or_float (getuid ());
1252 DEFUN ("user-full-name", Fuser_full_name
, Suser_full_name
, 0, 1, 0,
1253 doc
: /* Return the full name of the user logged in, as a string.
1254 If the full name corresponding to Emacs's userid is not known,
1257 If optional argument UID is an integer or float, return the full name
1258 of the user with that uid, or nil if there is no such user.
1259 If UID is a string, return the full name of the user with that login
1260 name, or nil if there is no such user. */)
1265 register unsigned char *p
, *q
;
1269 return Vuser_full_name
;
1270 else if (NUMBERP (uid
))
1271 pw
= (struct passwd
*) getpwuid ((uid_t
) XFLOATINT (uid
));
1272 else if (STRINGP (uid
))
1273 pw
= (struct passwd
*) getpwnam (XSTRING (uid
)->data
);
1275 error ("Invalid UID specification");
1280 p
= (unsigned char *) USER_FULL_NAME
;
1281 /* Chop off everything after the first comma. */
1282 q
= (unsigned char *) index (p
, ',');
1283 full
= make_string (p
, q
? q
- p
: strlen (p
));
1285 #ifdef AMPERSAND_FULL_NAME
1286 p
= XSTRING (full
)->data
;
1287 q
= (unsigned char *) index (p
, '&');
1288 /* Substitute the login name for the &, upcasing the first character. */
1291 register unsigned char *r
;
1294 login
= Fuser_login_name (make_number (pw
->pw_uid
));
1295 r
= (unsigned char *) alloca (strlen (p
) + XSTRING (login
)->size
+ 1);
1296 bcopy (p
, r
, q
- p
);
1298 strcat (r
, XSTRING (login
)->data
);
1299 r
[q
- p
] = UPCASE (r
[q
- p
]);
1301 full
= build_string (r
);
1303 #endif /* AMPERSAND_FULL_NAME */
1308 DEFUN ("system-name", Fsystem_name
, Ssystem_name
, 0, 0, 0,
1309 doc
: /* Return the name of the machine you are running on, as a string. */)
1312 return Vsystem_name
;
1315 /* For the benefit of callers who don't want to include lisp.h */
1320 if (STRINGP (Vsystem_name
))
1321 return (char *) XSTRING (Vsystem_name
)->data
;
1326 DEFUN ("emacs-pid", Femacs_pid
, Semacs_pid
, 0, 0, 0,
1327 doc
: /* Return the process ID of Emacs, as an integer. */)
1330 return make_number (getpid ());
1333 DEFUN ("current-time", Fcurrent_time
, Scurrent_time
, 0, 0, 0,
1334 doc
: /* Return the current time, as the number of seconds since 1970-01-01 00:00:00.
1335 The time is returned as a list of three integers. The first has the
1336 most significant 16 bits of the seconds, while the second has the
1337 least significant 16 bits. The third integer gives the microsecond
1340 The microsecond count is zero on systems that do not provide
1341 resolution finer than a second. */)
1345 Lisp_Object result
[3];
1348 XSETINT (result
[0], (EMACS_SECS (t
) >> 16) & 0xffff);
1349 XSETINT (result
[1], (EMACS_SECS (t
) >> 0) & 0xffff);
1350 XSETINT (result
[2], EMACS_USECS (t
));
1352 return Flist (3, result
);
1357 lisp_time_argument (specified_time
, result
, usec
)
1358 Lisp_Object specified_time
;
1362 if (NILP (specified_time
))
1369 *usec
= EMACS_USECS (t
);
1370 *result
= EMACS_SECS (t
);
1374 return time (result
) != -1;
1378 Lisp_Object high
, low
;
1379 high
= Fcar (specified_time
);
1380 CHECK_NUMBER (high
);
1381 low
= Fcdr (specified_time
);
1386 Lisp_Object usec_l
= Fcdr (low
);
1388 usec_l
= Fcar (usec_l
);
1393 CHECK_NUMBER (usec_l
);
1394 *usec
= XINT (usec_l
);
1402 *result
= (XINT (high
) << 16) + (XINT (low
) & 0xffff);
1403 return *result
>> 16 == XINT (high
);
1407 DEFUN ("float-time", Ffloat_time
, Sfloat_time
, 0, 1, 0,
1408 doc
: /* Return the current time, as a float number of seconds since the epoch.
1409 If an argument is given, it specifies a time to convert to float
1410 instead of the current time. The argument should have the forms:
1411 (HIGH . LOW) or (HIGH LOW USEC) or (HIGH LOW . USEC).
1412 Thus, you can use times obtained from `current-time'
1413 and from `file-attributes'.
1415 WARNING: Since the result is floating point, it may not be exact.
1416 Do not use this function if precise time stamps are required. */)
1418 Lisp_Object specified_time
;
1423 if (! lisp_time_argument (specified_time
, &sec
, &usec
))
1424 error ("Invalid time specification");
1426 return make_float ((sec
* 1e6
+ usec
) / 1e6
);
1429 /* Write information into buffer S of size MAXSIZE, according to the
1430 FORMAT of length FORMAT_LEN, using time information taken from *TP.
1431 Default to Universal Time if UT is nonzero, local time otherwise.
1432 Return the number of bytes written, not including the terminating
1433 '\0'. If S is NULL, nothing will be written anywhere; so to
1434 determine how many bytes would be written, use NULL for S and
1435 ((size_t) -1) for MAXSIZE.
1437 This function behaves like emacs_strftimeu, except it allows null
1440 emacs_memftimeu (s
, maxsize
, format
, format_len
, tp
, ut
)
1445 const struct tm
*tp
;
1450 /* Loop through all the null-terminated strings in the format
1451 argument. Normally there's just one null-terminated string, but
1452 there can be arbitrarily many, concatenated together, if the
1453 format contains '\0' bytes. emacs_strftimeu stops at the first
1454 '\0' byte so we must invoke it separately for each such string. */
1463 result
= emacs_strftimeu (s
, maxsize
, format
, tp
, ut
);
1467 if (result
== 0 && s
[0] != '\0')
1472 maxsize
-= result
+ 1;
1474 len
= strlen (format
);
1475 if (len
== format_len
)
1479 format_len
-= len
+ 1;
1483 DEFUN ("format-time-string", Fformat_time_string
, Sformat_time_string
, 1, 3, 0,
1484 doc
: /* Use FORMAT-STRING to format the time TIME, or now if omitted.
1485 TIME is specified as (HIGH LOW . IGNORED) or (HIGH . LOW), as returned by
1486 `current-time' or `file-attributes'.
1487 The third, optional, argument UNIVERSAL, if non-nil, means describe TIME
1488 as Universal Time; nil means describe TIME in the local time zone.
1489 The value is a copy of FORMAT-STRING, but with certain constructs replaced
1490 by text that describes the specified date and time in TIME:
1492 %Y is the year, %y within the century, %C the century.
1493 %G is the year corresponding to the ISO week, %g within the century.
1494 %m is the numeric month.
1495 %b and %h are the locale's abbreviated month name, %B the full name.
1496 %d is the day of the month, zero-padded, %e is blank-padded.
1497 %u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.
1498 %a is the locale's abbreviated name of the day of week, %A the full name.
1499 %U is the week number starting on Sunday, %W starting on Monday,
1500 %V according to ISO 8601.
1501 %j is the day of the year.
1503 %H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H
1504 only blank-padded, %l is like %I blank-padded.
1505 %p is the locale's equivalent of either AM or PM.
1508 %Z is the time zone name, %z is the numeric form.
1509 %s is the number of seconds since 1970-01-01 00:00:00 +0000.
1511 %c is the locale's date and time format.
1512 %x is the locale's "preferred" date format.
1513 %D is like "%m/%d/%y".
1515 %R is like "%H:%M", %T is like "%H:%M:%S", %r is like "%I:%M:%S %p".
1516 %X is the locale's "preferred" time format.
1518 Finally, %n is a newline, %t is a tab, %% is a literal %.
1520 Certain flags and modifiers are available with some format controls.
1521 The flags are `_', `-', `^' and `#'. For certain characters X,
1522 %_X is like %X, but padded with blanks; %-X is like %X,
1523 ut without padding. %^X is like %X but with all textual
1524 characters up-cased; %#X is like %X but with letter-case of
1525 all textual characters reversed.
1526 %NX (where N stands for an integer) is like %X,
1527 but takes up at least N (a number) positions.
1528 The modifiers are `E' and `O'. For certain characters X,
1529 %EX is a locale's alternative version of %X;
1530 %OX is like %X, but uses the locale's number symbols.
1532 For example, to produce full ISO 8601 format, use "%Y-%m-%dT%T%z". */)
1533 (format_string
, time
, universal
)
1534 Lisp_Object format_string
, time
, universal
;
1539 int ut
= ! NILP (universal
);
1541 CHECK_STRING (format_string
);
1543 if (! lisp_time_argument (time
, &value
, NULL
))
1544 error ("Invalid time specification");
1546 format_string
= code_convert_string_norecord (format_string
,
1547 Vlocale_coding_system
, 1);
1549 /* This is probably enough. */
1550 size
= STRING_BYTES (XSTRING (format_string
)) * 6 + 50;
1552 tm
= ut
? gmtime (&value
) : localtime (&value
);
1554 error ("Specified time is not representable");
1556 synchronize_system_time_locale ();
1560 char *buf
= (char *) alloca (size
+ 1);
1564 result
= emacs_memftimeu (buf
, size
, XSTRING (format_string
)->data
,
1565 STRING_BYTES (XSTRING (format_string
)),
1567 if ((result
> 0 && result
< size
) || (result
== 0 && buf
[0] == '\0'))
1568 return code_convert_string_norecord (make_string (buf
, result
),
1569 Vlocale_coding_system
, 0);
1571 /* If buffer was too small, make it bigger and try again. */
1572 result
= emacs_memftimeu (NULL
, (size_t) -1,
1573 XSTRING (format_string
)->data
,
1574 STRING_BYTES (XSTRING (format_string
)),
1580 DEFUN ("decode-time", Fdecode_time
, Sdecode_time
, 0, 1, 0,
1581 doc
: /* Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST ZONE).
1582 The optional SPECIFIED-TIME should be a list of (HIGH LOW . IGNORED)
1583 or (HIGH . LOW), as from `current-time' and `file-attributes', or `nil'
1584 to use the current time. The list has the following nine members:
1585 SEC is an integer between 0 and 60; SEC is 60 for a leap second, which
1586 only some operating systems support. MINUTE is an integer between 0 and 59.
1587 HOUR is an integer between 0 and 23. DAY is an integer between 1 and 31.
1588 MONTH is an integer between 1 and 12. YEAR is an integer indicating the
1589 four-digit year. DOW is the day of week, an integer between 0 and 6, where
1590 0 is Sunday. DST is t if daylight savings time is effect, otherwise nil.
1591 ZONE is an integer indicating the number of seconds east of Greenwich.
1592 (Note that Common Lisp has different meanings for DOW and ZONE.) */)
1594 Lisp_Object specified_time
;
1598 struct tm
*decoded_time
;
1599 Lisp_Object list_args
[9];
1601 if (! lisp_time_argument (specified_time
, &time_spec
, NULL
))
1602 error ("Invalid time specification");
1604 decoded_time
= localtime (&time_spec
);
1606 error ("Specified time is not representable");
1607 XSETFASTINT (list_args
[0], decoded_time
->tm_sec
);
1608 XSETFASTINT (list_args
[1], decoded_time
->tm_min
);
1609 XSETFASTINT (list_args
[2], decoded_time
->tm_hour
);
1610 XSETFASTINT (list_args
[3], decoded_time
->tm_mday
);
1611 XSETFASTINT (list_args
[4], decoded_time
->tm_mon
+ 1);
1612 XSETINT (list_args
[5], decoded_time
->tm_year
+ 1900);
1613 XSETFASTINT (list_args
[6], decoded_time
->tm_wday
);
1614 list_args
[7] = (decoded_time
->tm_isdst
)? Qt
: Qnil
;
1616 /* Make a copy, in case gmtime modifies the struct. */
1617 save_tm
= *decoded_time
;
1618 decoded_time
= gmtime (&time_spec
);
1619 if (decoded_time
== 0)
1620 list_args
[8] = Qnil
;
1622 XSETINT (list_args
[8], tm_diff (&save_tm
, decoded_time
));
1623 return Flist (9, list_args
);
1626 DEFUN ("encode-time", Fencode_time
, Sencode_time
, 6, MANY
, 0,
1627 doc
: /* Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.
1628 This is the reverse operation of `decode-time', which see.
1629 ZONE defaults to the current time zone rule. This can
1630 be a string or t (as from `set-time-zone-rule'), or it can be a list
1631 \(as from `current-time-zone') or an integer (as from `decode-time')
1632 applied without consideration for daylight savings time.
1634 You can pass more than 7 arguments; then the first six arguments
1635 are used as SECOND through YEAR, and the *last* argument is used as ZONE.
1636 The intervening arguments are ignored.
1637 This feature lets (apply 'encode-time (decode-time ...)) work.
1639 Out-of-range values for SEC, MINUTE, HOUR, DAY, or MONTH are allowed;
1640 for example, a DAY of 0 means the day preceding the given month.
1641 Year numbers less than 100 are treated just like other year numbers.
1642 If you want them to stand for years in this century, you must do that yourself.
1644 usage: (encode-time SECOND MINUTE HOUR DAY MONTH YEAR &optional ZONE) */)
1647 register Lisp_Object
*args
;
1651 Lisp_Object zone
= (nargs
> 6 ? args
[nargs
- 1] : Qnil
);
1653 CHECK_NUMBER (args
[0]); /* second */
1654 CHECK_NUMBER (args
[1]); /* minute */
1655 CHECK_NUMBER (args
[2]); /* hour */
1656 CHECK_NUMBER (args
[3]); /* day */
1657 CHECK_NUMBER (args
[4]); /* month */
1658 CHECK_NUMBER (args
[5]); /* year */
1660 tm
.tm_sec
= XINT (args
[0]);
1661 tm
.tm_min
= XINT (args
[1]);
1662 tm
.tm_hour
= XINT (args
[2]);
1663 tm
.tm_mday
= XINT (args
[3]);
1664 tm
.tm_mon
= XINT (args
[4]) - 1;
1665 tm
.tm_year
= XINT (args
[5]) - 1900;
1671 time
= mktime (&tm
);
1676 char **oldenv
= environ
, **newenv
;
1680 else if (STRINGP (zone
))
1681 tzstring
= (char *) XSTRING (zone
)->data
;
1682 else if (INTEGERP (zone
))
1684 int abszone
= abs (XINT (zone
));
1685 sprintf (tzbuf
, "XXX%s%d:%02d:%02d", "-" + (XINT (zone
) < 0),
1686 abszone
/ (60*60), (abszone
/60) % 60, abszone
% 60);
1690 error ("Invalid time zone specification");
1692 /* Set TZ before calling mktime; merely adjusting mktime's returned
1693 value doesn't suffice, since that would mishandle leap seconds. */
1694 set_time_zone_rule (tzstring
);
1696 time
= mktime (&tm
);
1698 /* Restore TZ to previous value. */
1702 #ifdef LOCALTIME_CACHE
1707 if (time
== (time_t) -1)
1708 error ("Specified time is not representable");
1710 return make_time (time
);
1713 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
, 0, 1, 0,
1714 doc
: /* Return the current time, as a human-readable string.
1715 Programs can use this function to decode a time,
1716 since the number of columns in each field is fixed.
1717 The format is `Sun Sep 16 01:03:52 1973'.
1718 However, see also the functions `decode-time' and `format-time-string'
1719 which provide a much more powerful and general facility.
1721 If an argument is given, it specifies a time to format
1722 instead of the current time. The argument should have the form:
1725 (HIGH LOW . IGNORED).
1726 Thus, you can use times obtained from `current-time'
1727 and from `file-attributes'. */)
1729 Lisp_Object specified_time
;
1735 if (! lisp_time_argument (specified_time
, &value
, NULL
))
1737 tem
= (char *) ctime (&value
);
1739 strncpy (buf
, tem
, 24);
1742 return build_string (buf
);
1745 #define TM_YEAR_BASE 1900
1747 /* Yield A - B, measured in seconds.
1748 This function is copied from the GNU C Library. */
1753 /* Compute intervening leap days correctly even if year is negative.
1754 Take care to avoid int overflow in leap day calculations,
1755 but it's OK to assume that A and B are close to each other. */
1756 int a4
= (a
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (a
->tm_year
& 3);
1757 int b4
= (b
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (b
->tm_year
& 3);
1758 int a100
= a4
/ 25 - (a4
% 25 < 0);
1759 int b100
= b4
/ 25 - (b4
% 25 < 0);
1760 int a400
= a100
>> 2;
1761 int b400
= b100
>> 2;
1762 int intervening_leap_days
= (a4
- b4
) - (a100
- b100
) + (a400
- b400
);
1763 int years
= a
->tm_year
- b
->tm_year
;
1764 int days
= (365 * years
+ intervening_leap_days
1765 + (a
->tm_yday
- b
->tm_yday
));
1766 return (60 * (60 * (24 * days
+ (a
->tm_hour
- b
->tm_hour
))
1767 + (a
->tm_min
- b
->tm_min
))
1768 + (a
->tm_sec
- b
->tm_sec
));
1771 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 1, 0,
1772 doc
: /* Return the offset and name for the local time zone.
1773 This returns a list of the form (OFFSET NAME).
1774 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).
1775 A negative value means west of Greenwich.
1776 NAME is a string giving the name of the time zone.
1777 If an argument is given, it specifies when the time zone offset is determined
1778 instead of using the current time. The argument should have the form:
1781 (HIGH LOW . IGNORED).
1782 Thus, you can use times obtained from `current-time'
1783 and from `file-attributes'.
1785 Some operating systems cannot provide all this information to Emacs;
1786 in this case, `current-time-zone' returns a list containing nil for
1787 the data it can't find. */)
1789 Lisp_Object specified_time
;
1795 if (lisp_time_argument (specified_time
, &value
, NULL
)
1796 && (t
= gmtime (&value
)) != 0
1797 && (gmt
= *t
, t
= localtime (&value
)) != 0)
1799 int offset
= tm_diff (t
, &gmt
);
1804 s
= (char *)t
->tm_zone
;
1805 #else /* not HAVE_TM_ZONE */
1807 if (t
->tm_isdst
== 0 || t
->tm_isdst
== 1)
1808 s
= tzname
[t
->tm_isdst
];
1810 #endif /* not HAVE_TM_ZONE */
1812 #if defined HAVE_TM_ZONE || defined HAVE_TZNAME
1815 /* On Japanese w32, we can get a Japanese string as time
1816 zone name. Don't accept that. */
1818 for (p
= s
; *p
&& (isalnum ((unsigned char)*p
) || *p
== ' '); ++p
)
1827 /* No local time zone name is available; use "+-NNNN" instead. */
1828 int am
= (offset
< 0 ? -offset
: offset
) / 60;
1829 sprintf (buf
, "%c%02d%02d", (offset
< 0 ? '-' : '+'), am
/60, am
%60);
1832 return Fcons (make_number (offset
), Fcons (build_string (s
), Qnil
));
1835 return Fmake_list (make_number (2), Qnil
);
1838 /* This holds the value of `environ' produced by the previous
1839 call to Fset_time_zone_rule, or 0 if Fset_time_zone_rule
1840 has never been called. */
1841 static char **environbuf
;
1843 DEFUN ("set-time-zone-rule", Fset_time_zone_rule
, Sset_time_zone_rule
, 1, 1, 0,
1844 doc
: /* Set the local time zone using TZ, a string specifying a time zone rule.
1845 If TZ is nil, use implementation-defined default time zone information.
1846 If TZ is t, use Universal Time. */)
1854 else if (EQ (tz
, Qt
))
1859 tzstring
= (char *) XSTRING (tz
)->data
;
1862 set_time_zone_rule (tzstring
);
1865 environbuf
= environ
;
1870 #ifdef LOCALTIME_CACHE
1872 /* These two values are known to load tz files in buggy implementations,
1873 i.e. Solaris 1 executables running under either Solaris 1 or Solaris 2.
1874 Their values shouldn't matter in non-buggy implementations.
1875 We don't use string literals for these strings,
1876 since if a string in the environment is in readonly
1877 storage, it runs afoul of bugs in SVR4 and Solaris 2.3.
1878 See Sun bugs 1113095 and 1114114, ``Timezone routines
1879 improperly modify environment''. */
1881 static char set_time_zone_rule_tz1
[] = "TZ=GMT+0";
1882 static char set_time_zone_rule_tz2
[] = "TZ=GMT+1";
1886 /* Set the local time zone rule to TZSTRING.
1887 This allocates memory into `environ', which it is the caller's
1888 responsibility to free. */
1891 set_time_zone_rule (tzstring
)
1895 char **from
, **to
, **newenv
;
1897 /* Make the ENVIRON vector longer with room for TZSTRING. */
1898 for (from
= environ
; *from
; from
++)
1900 envptrs
= from
- environ
+ 2;
1901 newenv
= to
= (char **) xmalloc (envptrs
* sizeof (char *)
1902 + (tzstring
? strlen (tzstring
) + 4 : 0));
1904 /* Add TZSTRING to the end of environ, as a value for TZ. */
1907 char *t
= (char *) (to
+ envptrs
);
1909 strcat (t
, tzstring
);
1913 /* Copy the old environ vector elements into NEWENV,
1914 but don't copy the TZ variable.
1915 So we have only one definition of TZ, which came from TZSTRING. */
1916 for (from
= environ
; *from
; from
++)
1917 if (strncmp (*from
, "TZ=", 3) != 0)
1923 /* If we do have a TZSTRING, NEWENV points to the vector slot where
1924 the TZ variable is stored. If we do not have a TZSTRING,
1925 TO points to the vector slot which has the terminating null. */
1927 #ifdef LOCALTIME_CACHE
1929 /* In SunOS 4.1.3_U1 and 4.1.4, if TZ has a value like
1930 "US/Pacific" that loads a tz file, then changes to a value like
1931 "XXX0" that does not load a tz file, and then changes back to
1932 its original value, the last change is (incorrectly) ignored.
1933 Also, if TZ changes twice in succession to values that do
1934 not load a tz file, tzset can dump core (see Sun bug#1225179).
1935 The following code works around these bugs. */
1939 /* Temporarily set TZ to a value that loads a tz file
1940 and that differs from tzstring. */
1942 *newenv
= (strcmp (tzstring
, set_time_zone_rule_tz1
+ 3) == 0
1943 ? set_time_zone_rule_tz2
: set_time_zone_rule_tz1
);
1949 /* The implied tzstring is unknown, so temporarily set TZ to
1950 two different values that each load a tz file. */
1951 *to
= set_time_zone_rule_tz1
;
1954 *to
= set_time_zone_rule_tz2
;
1959 /* Now TZ has the desired value, and tzset can be invoked safely. */
1966 /* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC
1967 (if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a
1968 type of object is Lisp_String). INHERIT is passed to
1969 INSERT_FROM_STRING_FUNC as the last argument. */
1972 general_insert_function (insert_func
, insert_from_string_func
,
1973 inherit
, nargs
, args
)
1974 void (*insert_func
) P_ ((unsigned char *, int));
1975 void (*insert_from_string_func
) P_ ((Lisp_Object
, int, int, int, int, int));
1977 register Lisp_Object
*args
;
1979 register int argnum
;
1980 register Lisp_Object val
;
1982 for (argnum
= 0; argnum
< nargs
; argnum
++)
1988 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
1991 if (!NILP (current_buffer
->enable_multibyte_characters
))
1992 len
= CHAR_STRING (XFASTINT (val
), str
);
1995 str
[0] = (SINGLE_BYTE_CHAR_P (XINT (val
))
1997 : multibyte_char_to_unibyte (XINT (val
), Qnil
));
2000 (*insert_func
) (str
, len
);
2002 else if (STRINGP (val
))
2004 (*insert_from_string_func
) (val
, 0, 0,
2005 XSTRING (val
)->size
,
2006 STRING_BYTES (XSTRING (val
)),
2011 val
= wrong_type_argument (Qchar_or_string_p
, val
);
2025 /* Callers passing one argument to Finsert need not gcpro the
2026 argument "array", since the only element of the array will
2027 not be used after calling insert or insert_from_string, so
2028 we don't care if it gets trashed. */
2030 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
2031 doc
: /* Insert the arguments, either strings or characters, at point.
2032 Point and before-insertion markers move forward to end up
2033 after the inserted text.
2034 Any other markers at the point of insertion remain before the text.
2036 If the current buffer is multibyte, unibyte strings are converted
2037 to multibyte for insertion (see `unibyte-char-to-multibyte').
2038 If the current buffer is unibyte, multibyte strings are converted
2039 to unibyte for insertion.
2041 usage: (insert &rest ARGS) */)
2044 register Lisp_Object
*args
;
2046 general_insert_function (insert
, insert_from_string
, 0, nargs
, args
);
2050 DEFUN ("insert-and-inherit", Finsert_and_inherit
, Sinsert_and_inherit
,
2052 doc
: /* Insert the arguments at point, inheriting properties from adjoining text.
2053 Point and before-insertion markers move forward to end up
2054 after the inserted text.
2055 Any other markers at the point of insertion remain before the text.
2057 If the current buffer is multibyte, unibyte strings are converted
2058 to multibyte for insertion (see `unibyte-char-to-multibyte').
2059 If the current buffer is unibyte, multibyte strings are converted
2060 to unibyte for insertion.
2062 usage: (insert-and-inherit &rest ARGS) */)
2065 register Lisp_Object
*args
;
2067 general_insert_function (insert_and_inherit
, insert_from_string
, 1,
2072 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
2073 doc
: /* Insert strings or characters at point, relocating markers after the text.
2074 Point and markers move forward to end up after the inserted text.
2076 If the current buffer is multibyte, unibyte strings are converted
2077 to multibyte for insertion (see `unibyte-char-to-multibyte').
2078 If the current buffer is unibyte, multibyte strings are converted
2079 to unibyte for insertion.
2081 usage: (insert-before-markers &rest ARGS) */)
2084 register Lisp_Object
*args
;
2086 general_insert_function (insert_before_markers
,
2087 insert_from_string_before_markers
, 0,
2092 DEFUN ("insert-before-markers-and-inherit", Finsert_and_inherit_before_markers
,
2093 Sinsert_and_inherit_before_markers
, 0, MANY
, 0,
2094 doc
: /* Insert text at point, relocating markers and inheriting properties.
2095 Point and markers move forward to end up after the inserted text.
2097 If the current buffer is multibyte, unibyte strings are converted
2098 to multibyte for insertion (see `unibyte-char-to-multibyte').
2099 If the current buffer is unibyte, multibyte strings are converted
2100 to unibyte for insertion.
2102 usage: (insert-before-markers-and-inherit &rest ARGS) */)
2105 register Lisp_Object
*args
;
2107 general_insert_function (insert_before_markers_and_inherit
,
2108 insert_from_string_before_markers
, 1,
2113 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 2, 3, 0,
2114 doc
: /* Insert COUNT (second arg) copies of CHARACTER (first arg).
2115 Both arguments are required.
2116 Point, and before-insertion markers, are relocated as in the function `insert'.
2117 The optional third arg INHERIT, if non-nil, says to inherit text properties
2118 from adjoining text, if those properties are sticky. */)
2119 (character
, count
, inherit
)
2120 Lisp_Object character
, count
, inherit
;
2122 register unsigned char *string
;
2123 register int strlen
;
2126 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2128 CHECK_NUMBER (character
);
2129 CHECK_NUMBER (count
);
2131 if (!NILP (current_buffer
->enable_multibyte_characters
))
2132 len
= CHAR_STRING (XFASTINT (character
), str
);
2134 str
[0] = XFASTINT (character
), len
= 1;
2135 n
= XINT (count
) * len
;
2138 strlen
= min (n
, 256 * len
);
2139 string
= (unsigned char *) alloca (strlen
);
2140 for (i
= 0; i
< strlen
; i
++)
2141 string
[i
] = str
[i
% len
];
2145 if (!NILP (inherit
))
2146 insert_and_inherit (string
, strlen
);
2148 insert (string
, strlen
);
2153 if (!NILP (inherit
))
2154 insert_and_inherit (string
, n
);
2161 DEFUN ("insert-byte", Finsert_byte
, Sinsert_byte
, 2, 3, 0,
2162 doc
: /* Insert COUNT (second arg) copies of BYTE (first arg).
2163 Both arguments are required.
2164 BYTE is a number of the range 0..255.
2166 If BYTE is 128..255 and the current buffer is multibyte, the
2167 corresponding eight-bit character is inserted.
2169 Point, and before-insertion markers, are relocated as in the function `insert'.
2170 The optional third arg INHERIT, if non-nil, says to inherit text properties
2171 from adjoining text, if those properties are sticky. */)
2172 (byte
, count
, inherit
)
2173 Lisp_Object byte
, count
, inherit
;
2175 CHECK_NUMBER (byte
);
2176 if (XINT (byte
) < 0 || XINT (byte
) > 255)
2177 args_out_of_range_3 (byte
, make_number (0), make_number (255));
2178 if (XINT (byte
) >= 128
2179 && ! NILP (current_buffer
->enable_multibyte_characters
))
2180 XSETFASTINT (byte
, BYTE8_TO_CHAR (XINT (byte
)));
2181 Finsert_char (byte
, count
, inherit
);
2185 /* Making strings from buffer contents. */
2187 /* Return a Lisp_String containing the text of the current buffer from
2188 START to END. If text properties are in use and the current buffer
2189 has properties in the range specified, the resulting string will also
2190 have them, if PROPS is nonzero.
2192 We don't want to use plain old make_string here, because it calls
2193 make_uninit_string, which can cause the buffer arena to be
2194 compacted. make_string has no way of knowing that the data has
2195 been moved, and thus copies the wrong data into the string. This
2196 doesn't effect most of the other users of make_string, so it should
2197 be left as is. But we should use this function when conjuring
2198 buffer substrings. */
2201 make_buffer_string (start
, end
, props
)
2205 int start_byte
= CHAR_TO_BYTE (start
);
2206 int end_byte
= CHAR_TO_BYTE (end
);
2208 return make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
);
2211 /* Return a Lisp_String containing the text of the current buffer from
2212 START / START_BYTE to END / END_BYTE.
2214 If text properties are in use and the current buffer
2215 has properties in the range specified, the resulting string will also
2216 have them, if PROPS is nonzero.
2218 We don't want to use plain old make_string here, because it calls
2219 make_uninit_string, which can cause the buffer arena to be
2220 compacted. make_string has no way of knowing that the data has
2221 been moved, and thus copies the wrong data into the string. This
2222 doesn't effect most of the other users of make_string, so it should
2223 be left as is. But we should use this function when conjuring
2224 buffer substrings. */
2227 make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
)
2228 int start
, start_byte
, end
, end_byte
;
2231 Lisp_Object result
, tem
, tem1
;
2233 if (start
< GPT
&& GPT
< end
)
2236 if (! NILP (current_buffer
->enable_multibyte_characters
))
2237 result
= make_uninit_multibyte_string (end
- start
, end_byte
- start_byte
);
2239 result
= make_uninit_string (end
- start
);
2240 bcopy (BYTE_POS_ADDR (start_byte
), XSTRING (result
)->data
,
2241 end_byte
- start_byte
);
2243 /* If desired, update and copy the text properties. */
2246 update_buffer_properties (start
, end
);
2248 tem
= Fnext_property_change (make_number (start
), Qnil
, make_number (end
));
2249 tem1
= Ftext_properties_at (make_number (start
), Qnil
);
2251 if (XINT (tem
) != end
|| !NILP (tem1
))
2252 copy_intervals_to_string (result
, current_buffer
, start
,
2259 /* Call Vbuffer_access_fontify_functions for the range START ... END
2260 in the current buffer, if necessary. */
2263 update_buffer_properties (start
, end
)
2266 /* If this buffer has some access functions,
2267 call them, specifying the range of the buffer being accessed. */
2268 if (!NILP (Vbuffer_access_fontify_functions
))
2270 Lisp_Object args
[3];
2273 args
[0] = Qbuffer_access_fontify_functions
;
2274 XSETINT (args
[1], start
);
2275 XSETINT (args
[2], end
);
2277 /* But don't call them if we can tell that the work
2278 has already been done. */
2279 if (!NILP (Vbuffer_access_fontified_property
))
2281 tem
= Ftext_property_any (args
[1], args
[2],
2282 Vbuffer_access_fontified_property
,
2285 Frun_hook_with_args (3, args
);
2288 Frun_hook_with_args (3, args
);
2292 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
2293 doc
: /* Return the contents of part of the current buffer as a string.
2294 The two arguments START and END are character positions;
2295 they can be in either order.
2296 The string returned is multibyte if the buffer is multibyte.
2298 This function copies the text properties of that part of the buffer
2299 into the result string; if you don't want the text properties,
2300 use `buffer-substring-no-properties' instead. */)
2302 Lisp_Object start
, end
;
2306 validate_region (&start
, &end
);
2310 return make_buffer_string (b
, e
, 1);
2313 DEFUN ("buffer-substring-no-properties", Fbuffer_substring_no_properties
,
2314 Sbuffer_substring_no_properties
, 2, 2, 0,
2315 doc
: /* Return the characters of part of the buffer, without the text properties.
2316 The two arguments START and END are character positions;
2317 they can be in either order. */)
2319 Lisp_Object start
, end
;
2323 validate_region (&start
, &end
);
2327 return make_buffer_string (b
, e
, 0);
2330 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
2331 doc
: /* Return the contents of the current buffer as a string.
2332 If narrowing is in effect, this function returns only the visible part
2336 return make_buffer_string (BEGV
, ZV
, 1);
2339 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
2341 doc
: /* Insert before point a substring of the contents of buffer BUFFER.
2342 BUFFER may be a buffer or a buffer name.
2343 Arguments START and END are character numbers specifying the substring.
2344 They default to the beginning and the end of BUFFER. */)
2346 Lisp_Object buf
, start
, end
;
2348 register int b
, e
, temp
;
2349 register struct buffer
*bp
, *obuf
;
2352 buffer
= Fget_buffer (buf
);
2355 bp
= XBUFFER (buffer
);
2356 if (NILP (bp
->name
))
2357 error ("Selecting deleted buffer");
2363 CHECK_NUMBER_COERCE_MARKER (start
);
2370 CHECK_NUMBER_COERCE_MARKER (end
);
2375 temp
= b
, b
= e
, e
= temp
;
2377 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
2378 args_out_of_range (start
, end
);
2380 obuf
= current_buffer
;
2381 set_buffer_internal_1 (bp
);
2382 update_buffer_properties (b
, e
);
2383 set_buffer_internal_1 (obuf
);
2385 insert_from_buffer (bp
, b
, e
- b
, 0);
2389 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
2391 doc
: /* Compare two substrings of two buffers; return result as number.
2392 the value is -N if first string is less after N-1 chars,
2393 +N if first string is greater after N-1 chars, or 0 if strings match.
2394 Each substring is represented as three arguments: BUFFER, START and END.
2395 That makes six args in all, three for each substring.
2397 The value of `case-fold-search' in the current buffer
2398 determines whether case is significant or ignored. */)
2399 (buffer1
, start1
, end1
, buffer2
, start2
, end2
)
2400 Lisp_Object buffer1
, start1
, end1
, buffer2
, start2
, end2
;
2402 register int begp1
, endp1
, begp2
, endp2
, temp
;
2403 register struct buffer
*bp1
, *bp2
;
2404 register Lisp_Object
*trt
2405 = (!NILP (current_buffer
->case_fold_search
)
2406 ? XCHAR_TABLE (current_buffer
->case_canon_table
)->contents
: 0);
2408 int i1
, i2
, i1_byte
, i2_byte
;
2410 /* Find the first buffer and its substring. */
2413 bp1
= current_buffer
;
2417 buf1
= Fget_buffer (buffer1
);
2420 bp1
= XBUFFER (buf1
);
2421 if (NILP (bp1
->name
))
2422 error ("Selecting deleted buffer");
2426 begp1
= BUF_BEGV (bp1
);
2429 CHECK_NUMBER_COERCE_MARKER (start1
);
2430 begp1
= XINT (start1
);
2433 endp1
= BUF_ZV (bp1
);
2436 CHECK_NUMBER_COERCE_MARKER (end1
);
2437 endp1
= XINT (end1
);
2441 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
2443 if (!(BUF_BEGV (bp1
) <= begp1
2445 && endp1
<= BUF_ZV (bp1
)))
2446 args_out_of_range (start1
, end1
);
2448 /* Likewise for second substring. */
2451 bp2
= current_buffer
;
2455 buf2
= Fget_buffer (buffer2
);
2458 bp2
= XBUFFER (buf2
);
2459 if (NILP (bp2
->name
))
2460 error ("Selecting deleted buffer");
2464 begp2
= BUF_BEGV (bp2
);
2467 CHECK_NUMBER_COERCE_MARKER (start2
);
2468 begp2
= XINT (start2
);
2471 endp2
= BUF_ZV (bp2
);
2474 CHECK_NUMBER_COERCE_MARKER (end2
);
2475 endp2
= XINT (end2
);
2479 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
2481 if (!(BUF_BEGV (bp2
) <= begp2
2483 && endp2
<= BUF_ZV (bp2
)))
2484 args_out_of_range (start2
, end2
);
2488 i1_byte
= buf_charpos_to_bytepos (bp1
, i1
);
2489 i2_byte
= buf_charpos_to_bytepos (bp2
, i2
);
2491 while (i1
< endp1
&& i2
< endp2
)
2493 /* When we find a mismatch, we must compare the
2494 characters, not just the bytes. */
2499 if (! NILP (bp1
->enable_multibyte_characters
))
2501 c1
= BUF_FETCH_MULTIBYTE_CHAR (bp1
, i1_byte
);
2502 BUF_INC_POS (bp1
, i1_byte
);
2507 c1
= BUF_FETCH_BYTE (bp1
, i1
);
2508 c1
= unibyte_char_to_multibyte (c1
);
2512 if (! NILP (bp2
->enable_multibyte_characters
))
2514 c2
= BUF_FETCH_MULTIBYTE_CHAR (bp2
, i2_byte
);
2515 BUF_INC_POS (bp2
, i2_byte
);
2520 c2
= BUF_FETCH_BYTE (bp2
, i2
);
2521 c2
= unibyte_char_to_multibyte (c2
);
2527 c1
= XINT (trt
[c1
]);
2528 c2
= XINT (trt
[c2
]);
2531 return make_number (- 1 - chars
);
2533 return make_number (chars
+ 1);
2538 /* The strings match as far as they go.
2539 If one is shorter, that one is less. */
2540 if (chars
< endp1
- begp1
)
2541 return make_number (chars
+ 1);
2542 else if (chars
< endp2
- begp2
)
2543 return make_number (- chars
- 1);
2545 /* Same length too => they are equal. */
2546 return make_number (0);
2550 subst_char_in_region_unwind (arg
)
2553 return current_buffer
->undo_list
= arg
;
2557 subst_char_in_region_unwind_1 (arg
)
2560 return current_buffer
->filename
= arg
;
2563 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
2564 Ssubst_char_in_region
, 4, 5, 0,
2565 doc
: /* From START to END, replace FROMCHAR with TOCHAR each time it occurs.
2566 If optional arg NOUNDO is non-nil, don't record this change for undo
2567 and don't mark the buffer as really changed.
2568 Both characters must have the same length of multi-byte form. */)
2569 (start
, end
, fromchar
, tochar
, noundo
)
2570 Lisp_Object start
, end
, fromchar
, tochar
, noundo
;
2572 register int pos
, pos_byte
, stop
, i
, len
, end_byte
;
2574 unsigned char fromstr
[MAX_MULTIBYTE_LENGTH
], tostr
[MAX_MULTIBYTE_LENGTH
];
2576 int count
= specpdl_ptr
- specpdl
;
2577 #define COMBINING_NO 0
2578 #define COMBINING_BEFORE 1
2579 #define COMBINING_AFTER 2
2580 #define COMBINING_BOTH (COMBINING_BEFORE | COMBINING_AFTER)
2581 int maybe_byte_combining
= COMBINING_NO
;
2582 int last_changed
= 0;
2583 int multibyte_p
= !NILP (current_buffer
->enable_multibyte_characters
);
2585 validate_region (&start
, &end
);
2586 CHECK_NUMBER (fromchar
);
2587 CHECK_NUMBER (tochar
);
2591 len
= CHAR_STRING (XFASTINT (fromchar
), fromstr
);
2592 if (CHAR_STRING (XFASTINT (tochar
), tostr
) != len
)
2593 error ("Characters in subst-char-in-region have different byte-lengths");
2594 if (!ASCII_BYTE_P (*tostr
))
2596 /* If *TOSTR is in the range 0x80..0x9F and TOCHAR is not a
2597 complete multibyte character, it may be combined with the
2598 after bytes. If it is in the range 0xA0..0xFF, it may be
2599 combined with the before and after bytes. */
2600 if (!CHAR_HEAD_P (*tostr
))
2601 maybe_byte_combining
= COMBINING_BOTH
;
2602 else if (BYTES_BY_CHAR_HEAD (*tostr
) > len
)
2603 maybe_byte_combining
= COMBINING_AFTER
;
2609 fromstr
[0] = XFASTINT (fromchar
);
2610 tostr
[0] = XFASTINT (tochar
);
2614 pos_byte
= CHAR_TO_BYTE (pos
);
2615 stop
= CHAR_TO_BYTE (XINT (end
));
2618 /* If we don't want undo, turn off putting stuff on the list.
2619 That's faster than getting rid of things,
2620 and it prevents even the entry for a first change.
2621 Also inhibit locking the file. */
2624 record_unwind_protect (subst_char_in_region_unwind
,
2625 current_buffer
->undo_list
);
2626 current_buffer
->undo_list
= Qt
;
2627 /* Don't do file-locking. */
2628 record_unwind_protect (subst_char_in_region_unwind_1
,
2629 current_buffer
->filename
);
2630 current_buffer
->filename
= Qnil
;
2633 if (pos_byte
< GPT_BYTE
)
2634 stop
= min (stop
, GPT_BYTE
);
2637 int pos_byte_next
= pos_byte
;
2639 if (pos_byte
>= stop
)
2641 if (pos_byte
>= end_byte
) break;
2644 p
= BYTE_POS_ADDR (pos_byte
);
2646 INC_POS (pos_byte_next
);
2649 if (pos_byte_next
- pos_byte
== len
2650 && p
[0] == fromstr
[0]
2652 || (p
[1] == fromstr
[1]
2653 && (len
== 2 || (p
[2] == fromstr
[2]
2654 && (len
== 3 || p
[3] == fromstr
[3]))))))
2659 modify_region (current_buffer
, changed
, XINT (end
));
2661 if (! NILP (noundo
))
2663 if (MODIFF
- 1 == SAVE_MODIFF
)
2665 if (MODIFF
- 1 == current_buffer
->auto_save_modified
)
2666 current_buffer
->auto_save_modified
++;
2670 /* Take care of the case where the new character
2671 combines with neighboring bytes. */
2672 if (maybe_byte_combining
2673 && (maybe_byte_combining
== COMBINING_AFTER
2674 ? (pos_byte_next
< Z_BYTE
2675 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2676 : ((pos_byte_next
< Z_BYTE
2677 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2678 || (pos_byte
> BEG_BYTE
2679 && ! ASCII_BYTE_P (FETCH_BYTE (pos_byte
- 1))))))
2681 Lisp_Object tem
, string
;
2683 struct gcpro gcpro1
;
2685 tem
= current_buffer
->undo_list
;
2688 /* Make a multibyte string containing this single character. */
2689 string
= make_multibyte_string (tostr
, 1, len
);
2690 /* replace_range is less efficient, because it moves the gap,
2691 but it handles combining correctly. */
2692 replace_range (pos
, pos
+ 1, string
,
2694 pos_byte_next
= CHAR_TO_BYTE (pos
);
2695 if (pos_byte_next
> pos_byte
)
2696 /* Before combining happened. We should not increment
2697 POS. So, to cancel the later increment of POS,
2701 INC_POS (pos_byte_next
);
2703 if (! NILP (noundo
))
2704 current_buffer
->undo_list
= tem
;
2711 record_change (pos
, 1);
2712 for (i
= 0; i
< len
; i
++) *p
++ = tostr
[i
];
2714 last_changed
= pos
+ 1;
2716 pos_byte
= pos_byte_next
;
2722 signal_after_change (changed
,
2723 last_changed
- changed
, last_changed
- changed
);
2724 update_compositions (changed
, last_changed
, CHECK_ALL
);
2727 unbind_to (count
, Qnil
);
2731 DEFUN ("translate-region", Ftranslate_region
, Stranslate_region
, 3, 3, 0,
2732 doc
: /* From START to END, translate characters according to TABLE.
2733 TABLE is a string; the Nth character in it is the mapping
2734 for the character with code N.
2735 This function does not alter multibyte characters.
2736 It returns the number of characters changed. */)
2740 register Lisp_Object table
;
2742 register int pos_byte
, stop
; /* Limits of the region. */
2743 register unsigned char *tt
; /* Trans table. */
2744 register int nc
; /* New character. */
2745 int cnt
; /* Number of changes made. */
2746 int size
; /* Size of translate table. */
2748 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
2750 validate_region (&start
, &end
);
2751 CHECK_STRING (table
);
2753 size
= STRING_BYTES (XSTRING (table
));
2754 tt
= XSTRING (table
)->data
;
2756 pos_byte
= CHAR_TO_BYTE (XINT (start
));
2757 stop
= CHAR_TO_BYTE (XINT (end
));
2758 modify_region (current_buffer
, XINT (start
), XINT (end
));
2762 for (; pos_byte
< stop
; )
2764 register unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
2770 oc
= STRING_CHAR_AND_LENGTH (p
, stop
- pos_byte
, len
);
2773 pos_byte_next
= pos_byte
+ len
;
2774 if (oc
< size
&& len
== 1)
2779 /* Take care of the case where the new character
2780 combines with neighboring bytes. */
2781 if (!ASCII_BYTE_P (nc
)
2782 && (CHAR_HEAD_P (nc
)
2783 ? ! CHAR_HEAD_P (FETCH_BYTE (pos_byte
+ 1))
2784 : (pos_byte
> BEG_BYTE
2785 && ! ASCII_BYTE_P (FETCH_BYTE (pos_byte
- 1)))))
2789 string
= make_multibyte_string (tt
+ oc
, 1, 1);
2790 /* This is less efficient, because it moves the gap,
2791 but it handles combining correctly. */
2792 replace_range (pos
, pos
+ 1, string
,
2794 pos_byte_next
= CHAR_TO_BYTE (pos
);
2795 if (pos_byte_next
> pos_byte
)
2796 /* Before combining happened. We should not
2797 increment POS. So, to cancel the later
2798 increment of POS, we decrease it now. */
2801 INC_POS (pos_byte_next
);
2805 record_change (pos
, 1);
2807 signal_after_change (pos
, 1, 1);
2808 update_compositions (pos
, pos
+ 1, CHECK_BORDER
);
2813 pos_byte
= pos_byte_next
;
2817 return make_number (cnt
);
2820 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
2821 doc
: /* Delete the text between point and mark.
2822 When called from a program, expects two arguments,
2823 positions (integers or markers) specifying the stretch to be deleted. */)
2825 Lisp_Object start
, end
;
2827 validate_region (&start
, &end
);
2828 del_range (XINT (start
), XINT (end
));
2832 DEFUN ("delete-and-extract-region", Fdelete_and_extract_region
,
2833 Sdelete_and_extract_region
, 2, 2, 0,
2834 doc
: /* Delete the text between START and END and return it. */)
2836 Lisp_Object start
, end
;
2838 validate_region (&start
, &end
);
2839 return del_range_1 (XINT (start
), XINT (end
), 1, 1);
2842 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
2843 doc
: /* Remove restrictions (narrowing) from current buffer.
2844 This allows the buffer's full text to be seen and edited. */)
2847 if (BEG
!= BEGV
|| Z
!= ZV
)
2848 current_buffer
->clip_changed
= 1;
2850 BEGV_BYTE
= BEG_BYTE
;
2851 SET_BUF_ZV_BOTH (current_buffer
, Z
, Z_BYTE
);
2852 /* Changing the buffer bounds invalidates any recorded current column. */
2853 invalidate_current_column ();
2857 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
2858 doc
: /* Restrict editing in this buffer to the current region.
2859 The rest of the text becomes temporarily invisible and untouchable
2860 but is not deleted; if you save the buffer in a file, the invisible
2861 text is included in the file. \\[widen] makes all visible again.
2862 See also `save-restriction'.
2864 When calling from a program, pass two arguments; positions (integers
2865 or markers) bounding the text that should remain visible. */)
2867 register Lisp_Object start
, end
;
2869 CHECK_NUMBER_COERCE_MARKER (start
);
2870 CHECK_NUMBER_COERCE_MARKER (end
);
2872 if (XINT (start
) > XINT (end
))
2875 tem
= start
; start
= end
; end
= tem
;
2878 if (!(BEG
<= XINT (start
) && XINT (start
) <= XINT (end
) && XINT (end
) <= Z
))
2879 args_out_of_range (start
, end
);
2881 if (BEGV
!= XFASTINT (start
) || ZV
!= XFASTINT (end
))
2882 current_buffer
->clip_changed
= 1;
2884 SET_BUF_BEGV (current_buffer
, XFASTINT (start
));
2885 SET_BUF_ZV (current_buffer
, XFASTINT (end
));
2886 if (PT
< XFASTINT (start
))
2887 SET_PT (XFASTINT (start
));
2888 if (PT
> XFASTINT (end
))
2889 SET_PT (XFASTINT (end
));
2890 /* Changing the buffer bounds invalidates any recorded current column. */
2891 invalidate_current_column ();
2896 save_restriction_save ()
2898 if (BEGV
== BEG
&& ZV
== Z
)
2899 /* The common case that the buffer isn't narrowed.
2900 We return just the buffer object, which save_restriction_restore
2901 recognizes as meaning `no restriction'. */
2902 return Fcurrent_buffer ();
2904 /* We have to save a restriction, so return a pair of markers, one
2905 for the beginning and one for the end. */
2907 Lisp_Object beg
, end
;
2909 beg
= buildmark (BEGV
, BEGV_BYTE
);
2910 end
= buildmark (ZV
, ZV_BYTE
);
2912 /* END must move forward if text is inserted at its exact location. */
2913 XMARKER(end
)->insertion_type
= 1;
2915 return Fcons (beg
, end
);
2920 save_restriction_restore (data
)
2924 /* A pair of marks bounding a saved restriction. */
2926 struct Lisp_Marker
*beg
= XMARKER (XCAR (data
));
2927 struct Lisp_Marker
*end
= XMARKER (XCDR (data
));
2928 struct buffer
*buf
= beg
->buffer
; /* END should have the same buffer. */
2930 if (beg
->charpos
!= BUF_BEGV(buf
) || end
->charpos
!= BUF_ZV(buf
))
2931 /* The restriction has changed from the saved one, so restore
2932 the saved restriction. */
2934 int pt
= BUF_PT (buf
);
2936 SET_BUF_BEGV_BOTH (buf
, beg
->charpos
, beg
->bytepos
);
2937 SET_BUF_ZV_BOTH (buf
, end
->charpos
, end
->bytepos
);
2939 if (pt
< beg
->charpos
|| pt
> end
->charpos
)
2940 /* The point is outside the new visible range, move it inside. */
2941 SET_BUF_PT_BOTH (buf
,
2942 clip_to_bounds (beg
->charpos
, pt
, end
->charpos
),
2943 clip_to_bounds (beg
->bytepos
, BUF_PT_BYTE(buf
),
2946 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
2950 /* A buffer, which means that there was no old restriction. */
2952 struct buffer
*buf
= XBUFFER (data
);
2954 if (BUF_BEGV(buf
) != BUF_BEG(buf
) || BUF_ZV(buf
) != BUF_Z(buf
))
2955 /* The buffer has been narrowed, get rid of the narrowing. */
2957 SET_BUF_BEGV_BOTH (buf
, BUF_BEG(buf
), BUF_BEG_BYTE(buf
));
2958 SET_BUF_ZV_BOTH (buf
, BUF_Z(buf
), BUF_Z_BYTE(buf
));
2960 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
2967 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
2968 doc
: /* Execute BODY, saving and restoring current buffer's restrictions.
2969 The buffer's restrictions make parts of the beginning and end invisible.
2970 (They are set up with `narrow-to-region' and eliminated with `widen'.)
2971 This special form, `save-restriction', saves the current buffer's restrictions
2972 when it is entered, and restores them when it is exited.
2973 So any `narrow-to-region' within BODY lasts only until the end of the form.
2974 The old restrictions settings are restored
2975 even in case of abnormal exit (throw or error).
2977 The value returned is the value of the last form in BODY.
2979 Note: if you are using both `save-excursion' and `save-restriction',
2980 use `save-excursion' outermost:
2981 (save-excursion (save-restriction ...))
2983 usage: (save-restriction &rest BODY) */)
2987 register Lisp_Object val
;
2988 int count
= specpdl_ptr
- specpdl
;
2990 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
2991 val
= Fprogn (body
);
2992 return unbind_to (count
, val
);
2995 /* Buffer for the most recent text displayed by Fmessage_box. */
2996 static char *message_text
;
2998 /* Allocated length of that buffer. */
2999 static int message_length
;
3001 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
3002 doc
: /* Print a one-line message at the bottom of the screen.
3003 The first argument is a format control string, and the rest are data
3004 to be formatted under control of the string. See `format' for details.
3006 If the first argument is nil, clear any existing message; let the
3007 minibuffer contents show.
3009 usage: (message STRING &rest ARGS) */)
3021 register Lisp_Object val
;
3022 val
= Fformat (nargs
, args
);
3023 message3 (val
, STRING_BYTES (XSTRING (val
)), STRING_MULTIBYTE (val
));
3028 DEFUN ("message-box", Fmessage_box
, Smessage_box
, 1, MANY
, 0,
3029 doc
: /* Display a message, in a dialog box if possible.
3030 If a dialog box is not available, use the echo area.
3031 The first argument is a format control string, and the rest are data
3032 to be formatted under control of the string. See `format' for details.
3034 If the first argument is nil, clear any existing message; let the
3035 minibuffer contents show.
3037 usage: (message-box STRING &rest ARGS) */)
3049 register Lisp_Object val
;
3050 val
= Fformat (nargs
, args
);
3052 /* The MS-DOS frames support popup menus even though they are
3053 not FRAME_WINDOW_P. */
3054 if (FRAME_WINDOW_P (XFRAME (selected_frame
))
3055 || FRAME_MSDOS_P (XFRAME (selected_frame
)))
3057 Lisp_Object pane
, menu
, obj
;
3058 struct gcpro gcpro1
;
3059 pane
= Fcons (Fcons (build_string ("OK"), Qt
), Qnil
);
3061 menu
= Fcons (val
, pane
);
3062 obj
= Fx_popup_dialog (Qt
, menu
);
3066 #endif /* HAVE_MENUS */
3067 /* Copy the data so that it won't move when we GC. */
3070 message_text
= (char *)xmalloc (80);
3071 message_length
= 80;
3073 if (STRING_BYTES (XSTRING (val
)) > message_length
)
3075 message_length
= STRING_BYTES (XSTRING (val
));
3076 message_text
= (char *)xrealloc (message_text
, message_length
);
3078 bcopy (XSTRING (val
)->data
, message_text
, STRING_BYTES (XSTRING (val
)));
3079 message2 (message_text
, STRING_BYTES (XSTRING (val
)),
3080 STRING_MULTIBYTE (val
));
3085 extern Lisp_Object last_nonmenu_event
;
3088 DEFUN ("message-or-box", Fmessage_or_box
, Smessage_or_box
, 1, MANY
, 0,
3089 doc
: /* Display a message in a dialog box or in the echo area.
3090 If this command was invoked with the mouse, use a dialog box if
3091 `use-dialog-box' is non-nil.
3092 Otherwise, use the echo area.
3093 The first argument is a format control string, and the rest are data
3094 to be formatted under control of the string. See `format' for details.
3096 If the first argument is nil, clear any existing message; let the
3097 minibuffer contents show.
3099 usage: (message-or-box STRING &rest ARGS) */)
3105 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3107 return Fmessage_box (nargs
, args
);
3109 return Fmessage (nargs
, args
);
3112 DEFUN ("current-message", Fcurrent_message
, Scurrent_message
, 0, 0, 0,
3113 doc
: /* Return the string currently displayed in the echo area, or nil if none. */)
3116 return current_message ();
3120 DEFUN ("propertize", Fpropertize
, Spropertize
, 1, MANY
, 0,
3121 doc
: /* Return a copy of STRING with text properties added.
3122 First argument is the string to copy.
3123 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
3124 properties to add to the result.
3125 usage: (propertize STRING &rest PROPERTIES) */)
3130 Lisp_Object properties
, string
;
3131 struct gcpro gcpro1
, gcpro2
;
3134 /* Number of args must be odd. */
3135 if ((nargs
& 1) == 0 || nargs
< 1)
3136 error ("Wrong number of arguments");
3138 properties
= string
= Qnil
;
3139 GCPRO2 (properties
, string
);
3141 /* First argument must be a string. */
3142 CHECK_STRING (args
[0]);
3143 string
= Fcopy_sequence (args
[0]);
3145 for (i
= 1; i
< nargs
; i
+= 2)
3147 CHECK_SYMBOL (args
[i
]);
3148 properties
= Fcons (args
[i
], Fcons (args
[i
+ 1], properties
));
3151 Fadd_text_properties (make_number (0),
3152 make_number (XSTRING (string
)->size
),
3153 properties
, string
);
3154 RETURN_UNGCPRO (string
);
3158 /* Number of bytes that STRING will occupy when put into the result.
3159 MULTIBYTE is nonzero if the result should be multibyte. */
3161 #define CONVERTED_BYTE_SIZE(MULTIBYTE, STRING) \
3162 (((MULTIBYTE) && ! STRING_MULTIBYTE (STRING)) \
3163 ? count_size_as_multibyte (XSTRING (STRING)->data, \
3164 STRING_BYTES (XSTRING (STRING))) \
3165 : STRING_BYTES (XSTRING (STRING)))
3167 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
3168 doc
: /* Format a string out of a control-string and arguments.
3169 The first argument is a control string.
3170 The other arguments are substituted into it to make the result, a string.
3171 It may contain %-sequences meaning to substitute the next argument.
3172 %s means print a string argument. Actually, prints any object, with `princ'.
3173 %d means print as number in decimal (%o octal, %x hex).
3174 %X is like %x, but uses upper case.
3175 %e means print a number in exponential notation.
3176 %f means print a number in decimal-point notation.
3177 %g means print a number in exponential notation
3178 or decimal-point notation, whichever uses fewer characters.
3179 %c means print a number as a single character.
3180 %S means print any object as an s-expression (using `prin1').
3181 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.
3182 Use %% to put a single % into the output.
3184 usage: (format STRING &rest OBJECTS) */)
3187 register Lisp_Object
*args
;
3189 register int n
; /* The number of the next arg to substitute */
3190 register int total
; /* An estimate of the final length */
3192 register unsigned char *format
, *end
;
3194 /* Nonzero if the output should be a multibyte string,
3195 which is true if any of the inputs is one. */
3197 /* When we make a multibyte string, we must pay attention to the
3198 byte combining problem, i.e., a byte may be combined with a
3199 multibyte charcter of the previous string. This flag tells if we
3200 must consider such a situation or not. */
3201 int maybe_combine_byte
;
3202 unsigned char *this_format
;
3210 /* It should not be necessary to GCPRO ARGS, because
3211 the caller in the interpreter should take care of that. */
3213 /* Try to determine whether the result should be multibyte.
3214 This is not always right; sometimes the result needs to be multibyte
3215 because of an object that we will pass through prin1,
3216 and in that case, we won't know it here. */
3217 for (n
= 0; n
< nargs
; n
++)
3218 if (STRINGP (args
[n
]) && STRING_MULTIBYTE (args
[n
]))
3221 CHECK_STRING (args
[0]);
3223 /* If we start out planning a unibyte result,
3224 and later find it has to be multibyte, we jump back to retry. */
3227 format
= XSTRING (args
[0])->data
;
3228 end
= format
+ STRING_BYTES (XSTRING (args
[0]));
3231 /* Make room in result for all the non-%-codes in the control string. */
3232 total
= 5 + CONVERTED_BYTE_SIZE (multibyte
, args
[0]);
3234 /* Add to TOTAL enough space to hold the converted arguments. */
3237 while (format
!= end
)
3238 if (*format
++ == '%')
3241 int actual_width
= 0;
3242 unsigned char *this_format_start
= format
- 1;
3243 int field_width
, precision
;
3245 /* General format specifications look like
3247 '%' [flags] [field-width] [precision] format
3252 field-width ::= [0-9]+
3253 precision ::= '.' [0-9]*
3255 If a field-width is specified, it specifies to which width
3256 the output should be padded with blanks, iff the output
3257 string is shorter than field-width.
3259 if precision is specified, it specifies the number of
3260 digits to print after the '.' for floats, or the max.
3261 number of chars to print from a string. */
3263 precision
= field_width
= 0;
3265 while (index ("-*# 0", *format
))
3268 if (*format
>= '0' && *format
<= '9')
3270 for (field_width
= 0; *format
>= '0' && *format
<= '9'; ++format
)
3271 field_width
= 10 * field_width
+ *format
- '0';
3277 for (precision
= 0; *format
>= '0' && *format
<= '9'; ++format
)
3278 precision
= 10 * precision
+ *format
- '0';
3281 if (format
- this_format_start
+ 1 > longest_format
)
3282 longest_format
= format
- this_format_start
+ 1;
3285 error ("Format string ends in middle of format specifier");
3288 else if (++n
>= nargs
)
3289 error ("Not enough arguments for format string");
3290 else if (*format
== 'S')
3292 /* For `S', prin1 the argument and then treat like a string. */
3293 register Lisp_Object tem
;
3294 tem
= Fprin1_to_string (args
[n
], Qnil
);
3295 if (STRING_MULTIBYTE (tem
) && ! multibyte
)
3303 else if (SYMBOLP (args
[n
]))
3305 /* Use a temp var to avoid problems when ENABLE_CHECKING
3307 struct Lisp_String
*t
= XSYMBOL (args
[n
])->name
;
3308 XSETSTRING (args
[n
], t
);
3309 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
3316 else if (STRINGP (args
[n
]))
3319 if (*format
!= 's' && *format
!= 'S')
3320 error ("Format specifier doesn't match argument type");
3321 thissize
= CONVERTED_BYTE_SIZE (multibyte
, args
[n
]);
3322 actual_width
= lisp_string_width (args
[n
], -1, NULL
, NULL
);
3324 /* Would get MPV otherwise, since Lisp_Int's `point' to low memory. */
3325 else if (INTEGERP (args
[n
]) && *format
!= 's')
3327 /* The following loop assumes the Lisp type indicates
3328 the proper way to pass the argument.
3329 So make sure we have a flonum if the argument should
3331 if (*format
== 'e' || *format
== 'f' || *format
== 'g')
3332 args
[n
] = Ffloat (args
[n
]);
3334 if (*format
!= 'd' && *format
!= 'o' && *format
!= 'x'
3335 && *format
!= 'i' && *format
!= 'X' && *format
!= 'c')
3336 error ("Invalid format operation %%%c", *format
);
3340 && (! ASCII_CHAR_P (XINT (args
[n
]))
3341 || XINT (args
[n
]) == 0))
3348 args
[n
] = Fchar_to_string (args
[n
]);
3349 thissize
= STRING_BYTES (XSTRING (args
[n
]));
3352 else if (FLOATP (args
[n
]) && *format
!= 's')
3354 if (! (*format
== 'e' || *format
== 'f' || *format
== 'g'))
3355 args
[n
] = Ftruncate (args
[n
], Qnil
);
3357 /* Note that we're using sprintf to print floats,
3358 so we have to take into account what that function
3360 thissize
= MAX_10_EXP
+ 100 + precision
;
3364 /* Anything but a string, convert to a string using princ. */
3365 register Lisp_Object tem
;
3366 tem
= Fprin1_to_string (args
[n
], Qt
);
3367 if (STRING_MULTIBYTE (tem
) & ! multibyte
)
3376 thissize
+= max (0, field_width
- actual_width
);
3377 total
+= thissize
+ 4;
3380 /* Now we can no longer jump to retry.
3381 TOTAL and LONGEST_FORMAT are known for certain. */
3383 this_format
= (unsigned char *) alloca (longest_format
+ 1);
3385 /* Allocate the space for the result.
3386 Note that TOTAL is an overestimate. */
3388 buf
= (char *) alloca (total
+ 1);
3390 buf
= (char *) xmalloc (total
+ 1);
3396 /* Scan the format and store result in BUF. */
3397 format
= XSTRING (args
[0])->data
;
3398 maybe_combine_byte
= 0;
3399 while (format
!= end
)
3405 unsigned char *this_format_start
= format
;
3409 /* Process a numeric arg and skip it. */
3410 minlen
= atoi (format
);
3412 minlen
= - minlen
, negative
= 1;
3414 while ((*format
>= '0' && *format
<= '9')
3415 || *format
== '-' || *format
== ' ' || *format
== '.')
3418 if (*format
++ == '%')
3427 if (STRINGP (args
[n
]))
3429 int padding
, nbytes
, start
, end
;
3430 int width
= lisp_string_width (args
[n
], -1, NULL
, NULL
);
3432 /* If spec requires it, pad on right with spaces. */
3433 padding
= minlen
- width
;
3435 while (padding
-- > 0)
3445 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3446 && STRING_MULTIBYTE (args
[n
])
3447 && !CHAR_HEAD_P (XSTRING (args
[n
])->data
[0]))
3448 maybe_combine_byte
= 1;
3449 nbytes
= copy_text (XSTRING (args
[n
])->data
, p
,
3450 STRING_BYTES (XSTRING (args
[n
])),
3451 STRING_MULTIBYTE (args
[n
]), multibyte
);
3453 nchars
+= XSTRING (args
[n
])->size
;
3457 while (padding
-- > 0)
3463 /* If this argument has text properties, record where
3464 in the result string it appears. */
3465 if (XSTRING (args
[n
])->intervals
)
3469 int nbytes
= nargs
* sizeof *info
;
3470 info
= (struct info
*) alloca (nbytes
);
3471 bzero (info
, nbytes
);
3474 info
[n
].start
= start
;
3478 else if (INTEGERP (args
[n
]) || FLOATP (args
[n
]))
3482 bcopy (this_format_start
, this_format
,
3483 format
- this_format_start
);
3484 this_format
[format
- this_format_start
] = 0;
3486 if (INTEGERP (args
[n
]))
3487 sprintf (p
, this_format
, XINT (args
[n
]));
3489 sprintf (p
, this_format
, XFLOAT_DATA (args
[n
]));
3493 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3494 && !CHAR_HEAD_P (*((unsigned char *) p
)))
3495 maybe_combine_byte
= 1;
3496 this_nchars
= strlen (p
);
3498 p
+= str_to_multibyte (p
, buf
+ total
- p
, this_nchars
);
3501 nchars
+= this_nchars
;
3504 else if (STRING_MULTIBYTE (args
[0]))
3506 /* Copy a whole multibyte character. */
3509 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3510 && !CHAR_HEAD_P (*format
))
3511 maybe_combine_byte
= 1;
3513 while (! CHAR_HEAD_P (*format
)) *p
++ = *format
++;
3518 /* Convert a single-byte character to multibyte. */
3519 int len
= copy_text (format
, p
, 1, 0, 1);
3526 *p
++ = *format
++, nchars
++;
3529 if (p
> buf
+ total
+ 1)
3532 if (maybe_combine_byte
)
3533 nchars
= multibyte_chars_in_text (buf
, p
- buf
);
3534 val
= make_specified_string (buf
, nchars
, p
- buf
, multibyte
);
3536 /* If we allocated BUF with malloc, free it too. */
3540 /* If the format string has text properties, or any of the string
3541 arguments has text properties, set up text properties of the
3544 if (XSTRING (args
[0])->intervals
|| info
)
3546 Lisp_Object len
, new_len
, props
;
3547 struct gcpro gcpro1
;
3549 /* Add text properties from the format string. */
3550 len
= make_number (XSTRING (args
[0])->size
);
3551 props
= text_property_list (args
[0], make_number (0), len
, Qnil
);
3556 new_len
= make_number (XSTRING (val
)->size
);
3557 extend_property_ranges (props
, len
, new_len
);
3558 add_text_properties_from_list (val
, props
, make_number (0));
3561 /* Add text properties from arguments. */
3563 for (n
= 1; n
< nargs
; ++n
)
3566 len
= make_number (XSTRING (args
[n
])->size
);
3567 new_len
= make_number (info
[n
].end
- info
[n
].start
);
3568 props
= text_property_list (args
[n
], make_number (0), len
, Qnil
);
3569 extend_property_ranges (props
, len
, new_len
);
3570 /* If successive arguments have properites, be sure that
3571 the value of `composition' property be the copy. */
3572 if (n
> 1 && info
[n
- 1].end
)
3573 make_composition_value_copy (props
);
3574 add_text_properties_from_list (val
, props
,
3575 make_number (info
[n
].start
));
3588 format1 (string1
, arg0
, arg1
, arg2
, arg3
, arg4
)
3589 EMACS_INT arg0
, arg1
, arg2
, arg3
, arg4
;
3603 doprnt (buf
, sizeof buf
, string1
, (char *)0, 5, (char **) args
);
3605 doprnt (buf
, sizeof buf
, string1
, (char *)0, 5, &string1
+ 1);
3607 return build_string (buf
);
3610 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
3611 doc
: /* Return t if two characters match, optionally ignoring case.
3612 Both arguments must be characters (i.e. integers).
3613 Case is ignored if `case-fold-search' is non-nil in the current buffer. */)
3615 register Lisp_Object c1
, c2
;
3621 if (XINT (c1
) == XINT (c2
))
3623 if (NILP (current_buffer
->case_fold_search
))
3626 /* Do these in separate statements,
3627 then compare the variables.
3628 because of the way DOWNCASE uses temp variables. */
3630 if (NILP (current_buffer
->enable_multibyte_characters
)
3631 && ! ASCII_CHAR_P (i1
))
3633 MAKE_CHAR_MULTIBYTE (i1
);
3636 if (NILP (current_buffer
->enable_multibyte_characters
)
3637 && ! ASCII_CHAR_P (i2
))
3639 MAKE_CHAR_MULTIBYTE (i2
);
3643 return (i1
== i2
? Qt
: Qnil
);
3646 /* Transpose the markers in two regions of the current buffer, and
3647 adjust the ones between them if necessary (i.e.: if the regions
3650 START1, END1 are the character positions of the first region.
3651 START1_BYTE, END1_BYTE are the byte positions.
3652 START2, END2 are the character positions of the second region.
3653 START2_BYTE, END2_BYTE are the byte positions.
3655 Traverses the entire marker list of the buffer to do so, adding an
3656 appropriate amount to some, subtracting from some, and leaving the
3657 rest untouched. Most of this is copied from adjust_markers in insdel.c.
3659 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
3662 transpose_markers (start1
, end1
, start2
, end2
,
3663 start1_byte
, end1_byte
, start2_byte
, end2_byte
)
3664 register int start1
, end1
, start2
, end2
;
3665 register int start1_byte
, end1_byte
, start2_byte
, end2_byte
;
3667 register int amt1
, amt1_byte
, amt2
, amt2_byte
, diff
, diff_byte
, mpos
;
3668 register Lisp_Object marker
;
3670 /* Update point as if it were a marker. */
3674 TEMP_SET_PT_BOTH (PT
+ (end2
- end1
),
3675 PT_BYTE
+ (end2_byte
- end1_byte
));
3676 else if (PT
< start2
)
3677 TEMP_SET_PT_BOTH (PT
+ (end2
- start2
) - (end1
- start1
),
3678 (PT_BYTE
+ (end2_byte
- start2_byte
)
3679 - (end1_byte
- start1_byte
)));
3681 TEMP_SET_PT_BOTH (PT
- (start2
- start1
),
3682 PT_BYTE
- (start2_byte
- start1_byte
));
3684 /* We used to adjust the endpoints here to account for the gap, but that
3685 isn't good enough. Even if we assume the caller has tried to move the
3686 gap out of our way, it might still be at start1 exactly, for example;
3687 and that places it `inside' the interval, for our purposes. The amount
3688 of adjustment is nontrivial if there's a `denormalized' marker whose
3689 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
3690 the dirty work to Fmarker_position, below. */
3692 /* The difference between the region's lengths */
3693 diff
= (end2
- start2
) - (end1
- start1
);
3694 diff_byte
= (end2_byte
- start2_byte
) - (end1_byte
- start1_byte
);
3696 /* For shifting each marker in a region by the length of the other
3697 region plus the distance between the regions. */
3698 amt1
= (end2
- start2
) + (start2
- end1
);
3699 amt2
= (end1
- start1
) + (start2
- end1
);
3700 amt1_byte
= (end2_byte
- start2_byte
) + (start2_byte
- end1_byte
);
3701 amt2_byte
= (end1_byte
- start1_byte
) + (start2_byte
- end1_byte
);
3703 for (marker
= BUF_MARKERS (current_buffer
); !NILP (marker
);
3704 marker
= XMARKER (marker
)->chain
)
3706 mpos
= marker_byte_position (marker
);
3707 if (mpos
>= start1_byte
&& mpos
< end2_byte
)
3709 if (mpos
< end1_byte
)
3711 else if (mpos
< start2_byte
)
3715 XMARKER (marker
)->bytepos
= mpos
;
3717 mpos
= XMARKER (marker
)->charpos
;
3718 if (mpos
>= start1
&& mpos
< end2
)
3722 else if (mpos
< start2
)
3727 XMARKER (marker
)->charpos
= mpos
;
3731 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
3732 doc
: /* Transpose region START1 to END1 with START2 to END2.
3733 The regions may not be overlapping, because the size of the buffer is
3734 never changed in a transposition.
3736 Optional fifth arg LEAVE_MARKERS, if non-nil, means don't update
3737 any markers that happen to be located in the regions.
3739 Transposing beyond buffer boundaries is an error. */)
3740 (startr1
, endr1
, startr2
, endr2
, leave_markers
)
3741 Lisp_Object startr1
, endr1
, startr2
, endr2
, leave_markers
;
3743 register int start1
, end1
, start2
, end2
;
3744 int start1_byte
, start2_byte
, len1_byte
, len2_byte
;
3745 int gap
, len1
, len_mid
, len2
;
3746 unsigned char *start1_addr
, *start2_addr
, *temp
;
3748 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
;
3749 cur_intv
= BUF_INTERVALS (current_buffer
);
3751 validate_region (&startr1
, &endr1
);
3752 validate_region (&startr2
, &endr2
);
3754 start1
= XFASTINT (startr1
);
3755 end1
= XFASTINT (endr1
);
3756 start2
= XFASTINT (startr2
);
3757 end2
= XFASTINT (endr2
);
3760 /* Swap the regions if they're reversed. */
3763 register int glumph
= start1
;
3771 len1
= end1
- start1
;
3772 len2
= end2
- start2
;
3775 error ("Transposed regions overlap");
3776 else if (start1
== end1
|| start2
== end2
)
3777 error ("Transposed region has length 0");
3779 /* The possibilities are:
3780 1. Adjacent (contiguous) regions, or separate but equal regions
3781 (no, really equal, in this case!), or
3782 2. Separate regions of unequal size.
3784 The worst case is usually No. 2. It means that (aside from
3785 potential need for getting the gap out of the way), there also
3786 needs to be a shifting of the text between the two regions. So
3787 if they are spread far apart, we are that much slower... sigh. */
3789 /* It must be pointed out that the really studly thing to do would
3790 be not to move the gap at all, but to leave it in place and work
3791 around it if necessary. This would be extremely efficient,
3792 especially considering that people are likely to do
3793 transpositions near where they are working interactively, which
3794 is exactly where the gap would be found. However, such code
3795 would be much harder to write and to read. So, if you are
3796 reading this comment and are feeling squirrely, by all means have
3797 a go! I just didn't feel like doing it, so I will simply move
3798 the gap the minimum distance to get it out of the way, and then
3799 deal with an unbroken array. */
3801 /* Make sure the gap won't interfere, by moving it out of the text
3802 we will operate on. */
3803 if (start1
< gap
&& gap
< end2
)
3805 if (gap
- start1
< end2
- gap
)
3811 start1_byte
= CHAR_TO_BYTE (start1
);
3812 start2_byte
= CHAR_TO_BYTE (start2
);
3813 len1_byte
= CHAR_TO_BYTE (end1
) - start1_byte
;
3814 len2_byte
= CHAR_TO_BYTE (end2
) - start2_byte
;
3816 #ifdef BYTE_COMBINING_DEBUG
3819 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
3820 len2_byte
, start1
, start1_byte
)
3821 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
3822 len1_byte
, end2
, start2_byte
+ len2_byte
)
3823 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
3824 len1_byte
, end2
, start2_byte
+ len2_byte
))
3829 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
3830 len2_byte
, start1
, start1_byte
)
3831 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
3832 len1_byte
, start2
, start2_byte
)
3833 || count_combining_after (BYTE_POS_ADDR (start2_byte
),
3834 len2_byte
, end1
, start1_byte
+ len1_byte
)
3835 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
3836 len1_byte
, end2
, start2_byte
+ len2_byte
))
3841 /* Hmmm... how about checking to see if the gap is large
3842 enough to use as the temporary storage? That would avoid an
3843 allocation... interesting. Later, don't fool with it now. */
3845 /* Working without memmove, for portability (sigh), so must be
3846 careful of overlapping subsections of the array... */
3848 if (end1
== start2
) /* adjacent regions */
3850 modify_region (current_buffer
, start1
, end2
);
3851 record_change (start1
, len1
+ len2
);
3853 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
3854 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
3855 Fset_text_properties (make_number (start1
), make_number (end2
),
3858 /* First region smaller than second. */
3859 if (len1_byte
< len2_byte
)
3861 /* We use alloca only if it is small,
3862 because we want to avoid stack overflow. */
3863 if (len2_byte
> 20000)
3864 temp
= (unsigned char *) xmalloc (len2_byte
);
3866 temp
= (unsigned char *) alloca (len2_byte
);
3868 /* Don't precompute these addresses. We have to compute them
3869 at the last minute, because the relocating allocator might
3870 have moved the buffer around during the xmalloc. */
3871 start1_addr
= BYTE_POS_ADDR (start1_byte
);
3872 start2_addr
= BYTE_POS_ADDR (start2_byte
);
3874 bcopy (start2_addr
, temp
, len2_byte
);
3875 bcopy (start1_addr
, start1_addr
+ len2_byte
, len1_byte
);
3876 bcopy (temp
, start1_addr
, len2_byte
);
3877 if (len2_byte
> 20000)
3881 /* First region not smaller than second. */
3883 if (len1_byte
> 20000)
3884 temp
= (unsigned char *) xmalloc (len1_byte
);
3886 temp
= (unsigned char *) alloca (len1_byte
);
3887 start1_addr
= BYTE_POS_ADDR (start1_byte
);
3888 start2_addr
= BYTE_POS_ADDR (start2_byte
);
3889 bcopy (start1_addr
, temp
, len1_byte
);
3890 bcopy (start2_addr
, start1_addr
, len2_byte
);
3891 bcopy (temp
, start1_addr
+ len2_byte
, len1_byte
);
3892 if (len1_byte
> 20000)
3895 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
3896 len1
, current_buffer
, 0);
3897 graft_intervals_into_buffer (tmp_interval2
, start1
,
3898 len2
, current_buffer
, 0);
3899 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
3900 update_compositions (start1
+ len2
, end2
, CHECK_TAIL
);
3902 /* Non-adjacent regions, because end1 != start2, bleagh... */
3905 len_mid
= start2_byte
- (start1_byte
+ len1_byte
);
3907 if (len1_byte
== len2_byte
)
3908 /* Regions are same size, though, how nice. */
3910 modify_region (current_buffer
, start1
, end1
);
3911 modify_region (current_buffer
, start2
, end2
);
3912 record_change (start1
, len1
);
3913 record_change (start2
, len2
);
3914 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
3915 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
3916 Fset_text_properties (make_number (start1
), make_number (end1
),
3918 Fset_text_properties (make_number (start2
), make_number (end2
),
3921 if (len1_byte
> 20000)
3922 temp
= (unsigned char *) xmalloc (len1_byte
);
3924 temp
= (unsigned char *) alloca (len1_byte
);
3925 start1_addr
= BYTE_POS_ADDR (start1_byte
);
3926 start2_addr
= BYTE_POS_ADDR (start2_byte
);
3927 bcopy (start1_addr
, temp
, len1_byte
);
3928 bcopy (start2_addr
, start1_addr
, len2_byte
);
3929 bcopy (temp
, start2_addr
, len1_byte
);
3930 if (len1_byte
> 20000)
3932 graft_intervals_into_buffer (tmp_interval1
, start2
,
3933 len1
, current_buffer
, 0);
3934 graft_intervals_into_buffer (tmp_interval2
, start1
,
3935 len2
, current_buffer
, 0);
3938 else if (len1_byte
< len2_byte
) /* Second region larger than first */
3939 /* Non-adjacent & unequal size, area between must also be shifted. */
3941 modify_region (current_buffer
, start1
, end2
);
3942 record_change (start1
, (end2
- start1
));
3943 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
3944 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
3945 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
3946 Fset_text_properties (make_number (start1
), make_number (end2
),
3949 /* holds region 2 */
3950 if (len2_byte
> 20000)
3951 temp
= (unsigned char *) xmalloc (len2_byte
);
3953 temp
= (unsigned char *) alloca (len2_byte
);
3954 start1_addr
= BYTE_POS_ADDR (start1_byte
);
3955 start2_addr
= BYTE_POS_ADDR (start2_byte
);
3956 bcopy (start2_addr
, temp
, len2_byte
);
3957 bcopy (start1_addr
, start1_addr
+ len_mid
+ len2_byte
, len1_byte
);
3958 safe_bcopy (start1_addr
+ len1_byte
, start1_addr
+ len2_byte
, len_mid
);
3959 bcopy (temp
, start1_addr
, len2_byte
);
3960 if (len2_byte
> 20000)
3962 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
3963 len1
, current_buffer
, 0);
3964 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
3965 len_mid
, current_buffer
, 0);
3966 graft_intervals_into_buffer (tmp_interval2
, start1
,
3967 len2
, current_buffer
, 0);
3970 /* Second region smaller than first. */
3972 record_change (start1
, (end2
- start1
));
3973 modify_region (current_buffer
, start1
, end2
);
3975 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
3976 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
3977 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
3978 Fset_text_properties (make_number (start1
), make_number (end2
),
3981 /* holds region 1 */
3982 if (len1_byte
> 20000)
3983 temp
= (unsigned char *) xmalloc (len1_byte
);
3985 temp
= (unsigned char *) alloca (len1_byte
);
3986 start1_addr
= BYTE_POS_ADDR (start1_byte
);
3987 start2_addr
= BYTE_POS_ADDR (start2_byte
);
3988 bcopy (start1_addr
, temp
, len1_byte
);
3989 bcopy (start2_addr
, start1_addr
, len2_byte
);
3990 bcopy (start1_addr
+ len1_byte
, start1_addr
+ len2_byte
, len_mid
);
3991 bcopy (temp
, start1_addr
+ len2_byte
+ len_mid
, len1_byte
);
3992 if (len1_byte
> 20000)
3994 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
3995 len1
, current_buffer
, 0);
3996 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
3997 len_mid
, current_buffer
, 0);
3998 graft_intervals_into_buffer (tmp_interval2
, start1
,
3999 len2
, current_buffer
, 0);
4002 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4003 update_compositions (end2
- len1
, end2
, CHECK_BORDER
);
4006 /* When doing multiple transpositions, it might be nice
4007 to optimize this. Perhaps the markers in any one buffer
4008 should be organized in some sorted data tree. */
4009 if (NILP (leave_markers
))
4011 transpose_markers (start1
, end1
, start2
, end2
,
4012 start1_byte
, start1_byte
+ len1_byte
,
4013 start2_byte
, start2_byte
+ len2_byte
);
4014 fix_overlays_in_range (start1
, end2
);
4026 Qbuffer_access_fontify_functions
4027 = intern ("buffer-access-fontify-functions");
4028 staticpro (&Qbuffer_access_fontify_functions
);
4030 DEFVAR_LISP ("inhibit-field-text-motion", &Vinhibit_field_text_motion
,
4031 doc
: /* Non-nil means.text motion commands don't notice fields. */);
4032 Vinhibit_field_text_motion
= Qnil
;
4034 DEFVAR_LISP ("buffer-access-fontify-functions",
4035 &Vbuffer_access_fontify_functions
,
4036 doc
: /* List of functions called by `buffer-substring' to fontify if necessary.
4037 Each function is called with two arguments which specify the range
4038 of the buffer being accessed. */);
4039 Vbuffer_access_fontify_functions
= Qnil
;
4043 extern Lisp_Object Vprin1_to_string_buffer
;
4044 obuf
= Fcurrent_buffer ();
4045 /* Do this here, because init_buffer_once is too early--it won't work. */
4046 Fset_buffer (Vprin1_to_string_buffer
);
4047 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
4048 Fset (Fmake_local_variable (intern ("buffer-access-fontify-functions")),
4053 DEFVAR_LISP ("buffer-access-fontified-property",
4054 &Vbuffer_access_fontified_property
,
4055 doc
: /* Property which (if non-nil) indicates text has been fontified.
4056 `buffer-substring' need not call the `buffer-access-fontify-functions'
4057 functions if all the text being accessed has this property. */);
4058 Vbuffer_access_fontified_property
= Qnil
;
4060 DEFVAR_LISP ("system-name", &Vsystem_name
,
4061 doc
: /* The name of the machine Emacs is running on. */);
4063 DEFVAR_LISP ("user-full-name", &Vuser_full_name
,
4064 doc
: /* The full name of the user logged in. */);
4066 DEFVAR_LISP ("user-login-name", &Vuser_login_name
,
4067 doc
: /* The user's name, taken from environment variables if possible. */);
4069 DEFVAR_LISP ("user-real-login-name", &Vuser_real_login_name
,
4070 doc
: /* The user's name, based upon the real uid only. */);
4072 defsubr (&Spropertize
);
4073 defsubr (&Schar_equal
);
4074 defsubr (&Sgoto_char
);
4075 defsubr (&Sstring_to_char
);
4076 defsubr (&Schar_to_string
);
4077 defsubr (&Sbuffer_substring
);
4078 defsubr (&Sbuffer_substring_no_properties
);
4079 defsubr (&Sbuffer_string
);
4081 defsubr (&Spoint_marker
);
4082 defsubr (&Smark_marker
);
4084 defsubr (&Sregion_beginning
);
4085 defsubr (&Sregion_end
);
4087 staticpro (&Qfield
);
4088 Qfield
= intern ("field");
4089 staticpro (&Qboundary
);
4090 Qboundary
= intern ("boundary");
4091 defsubr (&Sfield_beginning
);
4092 defsubr (&Sfield_end
);
4093 defsubr (&Sfield_string
);
4094 defsubr (&Sfield_string_no_properties
);
4095 defsubr (&Sdelete_field
);
4096 defsubr (&Sconstrain_to_field
);
4098 defsubr (&Sline_beginning_position
);
4099 defsubr (&Sline_end_position
);
4101 /* defsubr (&Smark); */
4102 /* defsubr (&Sset_mark); */
4103 defsubr (&Ssave_excursion
);
4104 defsubr (&Ssave_current_buffer
);
4106 defsubr (&Sbufsize
);
4107 defsubr (&Spoint_max
);
4108 defsubr (&Spoint_min
);
4109 defsubr (&Spoint_min_marker
);
4110 defsubr (&Spoint_max_marker
);
4111 defsubr (&Sgap_position
);
4112 defsubr (&Sgap_size
);
4113 defsubr (&Sposition_bytes
);
4114 defsubr (&Sbyte_to_position
);
4120 defsubr (&Sfollowing_char
);
4121 defsubr (&Sprevious_char
);
4122 defsubr (&Schar_after
);
4123 defsubr (&Schar_before
);
4125 defsubr (&Sinsert_before_markers
);
4126 defsubr (&Sinsert_and_inherit
);
4127 defsubr (&Sinsert_and_inherit_before_markers
);
4128 defsubr (&Sinsert_char
);
4129 defsubr (&Sinsert_byte
);
4131 defsubr (&Suser_login_name
);
4132 defsubr (&Suser_real_login_name
);
4133 defsubr (&Suser_uid
);
4134 defsubr (&Suser_real_uid
);
4135 defsubr (&Suser_full_name
);
4136 defsubr (&Semacs_pid
);
4137 defsubr (&Scurrent_time
);
4138 defsubr (&Sformat_time_string
);
4139 defsubr (&Sfloat_time
);
4140 defsubr (&Sdecode_time
);
4141 defsubr (&Sencode_time
);
4142 defsubr (&Scurrent_time_string
);
4143 defsubr (&Scurrent_time_zone
);
4144 defsubr (&Sset_time_zone_rule
);
4145 defsubr (&Ssystem_name
);
4146 defsubr (&Smessage
);
4147 defsubr (&Smessage_box
);
4148 defsubr (&Smessage_or_box
);
4149 defsubr (&Scurrent_message
);
4152 defsubr (&Sinsert_buffer_substring
);
4153 defsubr (&Scompare_buffer_substrings
);
4154 defsubr (&Ssubst_char_in_region
);
4155 defsubr (&Stranslate_region
);
4156 defsubr (&Sdelete_region
);
4157 defsubr (&Sdelete_and_extract_region
);
4159 defsubr (&Snarrow_to_region
);
4160 defsubr (&Ssave_restriction
);
4161 defsubr (&Stranspose_regions
);