1 /* Lisp functions pertaining to editing.
2 Copyright (C) 1985,86,87,89,93,94,95,96,97,98, 1999 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs; see the file COPYING. If not, write to
18 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
19 Boston, MA 02111-1307, USA. */
23 #include <sys/types.h>
36 #include "intervals.h"
44 #define min(a, b) ((a) < (b) ? (a) : (b))
45 #define max(a, b) ((a) > (b) ? (a) : (b))
51 extern char **environ
;
52 extern Lisp_Object
make_time ();
53 extern void insert_from_buffer ();
54 static int tm_diff ();
55 static void update_buffer_properties ();
56 size_t emacs_strftimeu ();
57 void set_time_zone_rule ();
59 Lisp_Object Vbuffer_access_fontify_functions
;
60 Lisp_Object Qbuffer_access_fontify_functions
;
61 Lisp_Object Vbuffer_access_fontified_property
;
63 Lisp_Object
Fuser_full_name ();
65 /* Some static data, and a function to initialize it for each run */
67 Lisp_Object Vsystem_name
;
68 Lisp_Object Vuser_real_login_name
; /* login name of current user ID */
69 Lisp_Object Vuser_full_name
; /* full name of current user */
70 Lisp_Object Vuser_login_name
; /* user name from LOGNAME or USER */
76 register unsigned char *p
;
77 struct passwd
*pw
; /* password entry for the current user */
80 /* Set up system_name even when dumping. */
84 /* Don't bother with this on initial start when just dumping out */
87 #endif /* not CANNOT_DUMP */
89 pw
= (struct passwd
*) getpwuid (getuid ());
91 /* We let the real user name default to "root" because that's quite
92 accurate on MSDOG and because it lets Emacs find the init file.
93 (The DVX libraries override the Djgpp libraries here.) */
94 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "root");
96 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "unknown");
99 /* Get the effective user name, by consulting environment variables,
100 or the effective uid if those are unset. */
101 user_name
= (char *) getenv ("LOGNAME");
104 user_name
= (char *) getenv ("USERNAME"); /* it's USERNAME on NT */
105 #else /* WINDOWSNT */
106 user_name
= (char *) getenv ("USER");
107 #endif /* WINDOWSNT */
110 pw
= (struct passwd
*) getpwuid (geteuid ());
111 user_name
= (char *) (pw
? pw
->pw_name
: "unknown");
113 Vuser_login_name
= build_string (user_name
);
115 /* If the user name claimed in the environment vars differs from
116 the real uid, use the claimed name to find the full name. */
117 tem
= Fstring_equal (Vuser_login_name
, Vuser_real_login_name
);
118 Vuser_full_name
= Fuser_full_name (NILP (tem
)? make_number (geteuid())
121 p
= (unsigned char *) getenv ("NAME");
123 Vuser_full_name
= build_string (p
);
124 else if (NILP (Vuser_full_name
))
125 Vuser_full_name
= build_string ("unknown");
128 DEFUN ("char-to-string", Fchar_to_string
, Schar_to_string
, 1, 1, 0,
129 "Convert arg CHAR to a string containing that character.")
131 Lisp_Object character
;
134 unsigned char workbuf
[4], *str
;
136 CHECK_NUMBER (character
, 0);
138 len
= CHAR_STRING (XFASTINT (character
), workbuf
, str
);
139 return make_string_from_bytes (str
, 1, len
);
142 DEFUN ("string-to-char", Fstring_to_char
, Sstring_to_char
, 1, 1, 0,
143 "Convert arg STRING to a character, the first character of that string.\n\
144 A multibyte character is handled correctly.")
146 register Lisp_Object string
;
148 register Lisp_Object val
;
149 register struct Lisp_String
*p
;
150 CHECK_STRING (string
, 0);
151 p
= XSTRING (string
);
154 if (STRING_MULTIBYTE (string
))
155 XSETFASTINT (val
, STRING_CHAR (p
->data
, STRING_BYTES (p
)));
157 XSETFASTINT (val
, p
->data
[0]);
160 XSETFASTINT (val
, 0);
165 buildmark (charpos
, bytepos
)
166 int charpos
, bytepos
;
168 register Lisp_Object mark
;
169 mark
= Fmake_marker ();
170 set_marker_both (mark
, Qnil
, charpos
, bytepos
);
174 DEFUN ("point", Fpoint
, Spoint
, 0, 0, 0,
175 "Return value of point, as an integer.\n\
176 Beginning of buffer is position (point-min)")
180 XSETFASTINT (temp
, PT
);
184 DEFUN ("point-marker", Fpoint_marker
, Spoint_marker
, 0, 0, 0,
185 "Return value of point, as a marker object.")
188 return buildmark (PT
, PT_BYTE
);
192 clip_to_bounds (lower
, num
, upper
)
193 int lower
, num
, upper
;
197 else if (num
> upper
)
203 DEFUN ("goto-char", Fgoto_char
, Sgoto_char
, 1, 1, "NGoto char: ",
204 "Set point to POSITION, a number or marker.\n\
205 Beginning of buffer is position (point-min), end is (point-max).\n\
206 If the position is in the middle of a multibyte form,\n\
207 the actual point is set at the head of the multibyte form\n\
208 except in the case that `enable-multibyte-characters' is nil.")
210 register Lisp_Object position
;
214 if (MARKERP (position
)
215 && current_buffer
== XMARKER (position
)->buffer
)
217 pos
= marker_position (position
);
219 SET_PT_BOTH (BEGV
, BEGV_BYTE
);
221 SET_PT_BOTH (ZV
, ZV_BYTE
);
223 SET_PT_BOTH (pos
, marker_byte_position (position
));
228 CHECK_NUMBER_COERCE_MARKER (position
, 0);
230 pos
= clip_to_bounds (BEGV
, XINT (position
), ZV
);
236 region_limit (beginningp
)
239 extern Lisp_Object Vmark_even_if_inactive
; /* Defined in callint.c. */
240 register Lisp_Object m
;
241 if (!NILP (Vtransient_mark_mode
) && NILP (Vmark_even_if_inactive
)
242 && NILP (current_buffer
->mark_active
))
243 Fsignal (Qmark_inactive
, Qnil
);
244 m
= Fmarker_position (current_buffer
->mark
);
245 if (NILP (m
)) error ("There is no region now");
246 if ((PT
< XFASTINT (m
)) == beginningp
)
247 return (make_number (PT
));
252 DEFUN ("region-beginning", Fregion_beginning
, Sregion_beginning
, 0, 0, 0,
253 "Return position of beginning of region, as an integer.")
256 return (region_limit (1));
259 DEFUN ("region-end", Fregion_end
, Sregion_end
, 0, 0, 0,
260 "Return position of end of region, as an integer.")
263 return (region_limit (0));
266 DEFUN ("mark-marker", Fmark_marker
, Smark_marker
, 0, 0, 0,
267 "Return this buffer's mark, as a marker object.\n\
268 Watch out! Moving this marker changes the mark position.\n\
269 If you set the marker not to point anywhere, the buffer will have no mark.")
272 return current_buffer
->mark
;
275 /* Return nonzero if POS1 and POS2 have the same value
276 for the text property PROP. */
279 text_property_eq (prop
, pos1
, pos2
)
281 Lisp_Object pos1
, pos2
;
283 Lisp_Object pval1
, pval2
;
285 pval1
= Fget_text_property (pos1
, prop
, Qnil
);
286 pval2
= Fget_text_property (pos2
, prop
, Qnil
);
288 return EQ (pval1
, pval2
);
291 /* Return the direction from which the text-property PROP would be
292 inherited by any new text inserted at POS: 1 if it would be
293 inherited from the char after POS, -1 if it would be inherited from
294 the char before POS, and 0 if from neither. */
297 text_property_stickiness (prop
, pos
)
301 Lisp_Object front_sticky
;
303 if (XINT (pos
) > BEGV
)
304 /* Consider previous character. */
306 Lisp_Object prev_pos
, rear_non_sticky
;
308 prev_pos
= make_number (XINT (pos
) - 1);
309 rear_non_sticky
= Fget_text_property (prev_pos
, Qrear_nonsticky
, Qnil
);
311 if (EQ (rear_non_sticky
, Qnil
)
312 || (CONSP (rear_non_sticky
)
313 && !Fmemq (prop
, rear_non_sticky
)))
314 /* PROP is not rear-non-sticky, and since this takes precedence over
315 any front-stickiness, PROP is inherited from before. */
319 /* Consider following character. */
320 front_sticky
= Fget_text_property (pos
, Qfront_sticky
, Qnil
);
322 if (EQ (front_sticky
, Qt
)
323 || (CONSP (front_sticky
)
324 && Fmemq (prop
, front_sticky
)))
325 /* PROP is inherited from after. */
328 /* PROP is not inherited from either side. */
332 /* Symbol for the text property used to mark fields. */
335 /* Find the field surrounding POS in *BEG and *END. If POS is nil,
336 the value of point is used instead.
338 If MERGE_AT_BOUNDARY is nonzero, then if POS is at the very first
339 position of a field, then the beginning of the previous field
340 is returned instead of the beginning of POS's field (since the end of
341 a field is actually also the beginning of the next input
342 field, this behavior is sometimes useful).
344 Either BEG or END may be 0, in which case the corresponding value
348 find_field (pos
, merge_at_boundary
, beg
, end
)
350 Lisp_Object merge_at_boundary
;
353 /* 1 if POS counts as the start of a field. */
354 int at_field_start
= 0;
355 /* 1 if POS counts as the end of a field. */
356 int at_field_end
= 0;
359 XSETFASTINT (pos
, PT
);
361 CHECK_NUMBER_COERCE_MARKER (pos
, 0);
363 if (NILP (merge_at_boundary
) && XFASTINT (pos
) > BEGV
)
364 /* See if we need to handle the case where POS is at beginning of a
365 field, which can also be interpreted as the end of the previous
366 field. We decide which one by seeing which field the `field'
367 property sticks to. The case where if MERGE_AT_BOUNDARY is
368 non-nil (see function comment) is actually the more natural one;
369 then we avoid treating the beginning of a field specially. */
371 /* First see if POS is actually *at* a boundary. */
372 Lisp_Object after_field
, before_field
;
374 after_field
= Fget_text_property (pos
, Qfield
, Qnil
);
375 before_field
= Fget_text_property (make_number (XINT (pos
) - 1),
378 if (! EQ (after_field
, before_field
))
379 /* We are at a boundary, see which direction is inclusive. */
381 int stickiness
= text_property_stickiness (Qfield
, pos
);
385 else if (stickiness
< 0)
388 /* STICKINESS == 0 means that any inserted text will get a
389 `field' text-property of nil, so check to see if that
390 matches either of the adjacent characters (this being a
391 kind of "stickiness by default"). */
393 if (NILP (before_field
))
394 at_field_end
= 1; /* Sticks to the left. */
395 else if (NILP (after_field
))
396 at_field_start
= 1; /* Sticks to the right. */
404 /* POS is at the edge of a field, and we should consider it as
405 the beginning of the following field. */
406 *beg
= XFASTINT (pos
);
408 /* Find the previous field boundary. */
411 prev
= Fprevious_single_property_change (pos
, Qfield
, Qnil
, Qnil
);
412 *beg
= NILP (prev
) ? BEGV
: XFASTINT (prev
);
419 /* POS is at the edge of a field, and we should consider it as
420 the end of the previous field. */
421 *end
= XFASTINT (pos
);
423 /* Find the next field boundary. */
426 next
= Fnext_single_property_change (pos
, Qfield
, Qnil
, Qnil
);
427 *end
= NILP (next
) ? ZV
: XFASTINT (next
);
432 DEFUN ("delete-field", Fdelete_field
, Sdelete_field
, 0, 1, "d",
433 "Delete the field surrounding POS.\n\
434 A field is a region of text with the same `field' property.\n\
435 If POS is nil, the value of point is used for POS.")
440 find_field (pos
, Qnil
, &beg
, &end
);
442 del_range (beg
, end
);
445 DEFUN ("field-string", Ffield_string
, Sfield_string
, 0, 1, 0,
446 "Return the contents of the field surrounding POS as a string.\n\
447 A field is a region of text with the same `field' property.\n\
448 If POS is nil, the value of point is used for POS.")
453 find_field (pos
, Qnil
, &beg
, &end
);
454 return make_buffer_string (beg
, end
, 1);
457 DEFUN ("field-string-no-properties", Ffield_string_no_properties
, Sfield_string_no_properties
, 0, 1, 0,
458 "Return the contents of the field around POS, without text-properties.\n\
459 A field is a region of text with the same `field' property.\n\
460 If POS is nil, the value of point is used for POS.")
465 find_field (pos
, Qnil
, &beg
, &end
);
466 return make_buffer_string (beg
, end
, 0);
469 DEFUN ("field-beginning", Ffield_beginning
, Sfield_beginning
, 0, 2, 0,
470 "Return the beginning of the field surrounding POS.\n\
471 A field is a region of text with the same `field' property.\n\
472 If POS is nil, the value of point is used for POS.\n\
473 If ESCAPE-FROM-EDGE is non-nil and POS is at the beginning of its\n\
474 field, then the beginning of the *previous* field is returned.")
475 (pos
, escape_from_edge
)
476 Lisp_Object pos
, escape_from_edge
;
479 find_field (pos
, escape_from_edge
, &beg
, 0);
480 return make_number (beg
);
483 DEFUN ("field-end", Ffield_end
, Sfield_end
, 0, 2, 0,
484 "Return the end of the field surrounding POS.\n\
485 A field is a region of text with the same `field' property.\n\
486 If POS is nil, the value of point is used for POS.\n\
487 If ESCAPE-FROM-EDGE is non-nil and POS is at the end of its field,\n\
488 then the end of the *following* field is returned.")
489 (pos
, escape_from_edge
)
490 Lisp_Object pos
, escape_from_edge
;
493 find_field (pos
, escape_from_edge
, 0, &end
);
494 return make_number (end
);
497 DEFUN ("constrain-to-field", Fconstrain_to_field
, Sconstrain_to_field
, 2, 4, 0,
498 "Return the position closest to NEW-POS that is in the same field as OLD-POS.\n\
499 A field is a region of text with the same `field' property.\n\
500 If NEW-POS is nil, then the current point is used instead, and set to the\n\
501 constrained position if that is is different.\n\
503 If OLD-POS is at the boundary of two fields, then the allowable\n\
504 positions for NEW-POS depends on the value of the optional argument\n\
505 ESCAPE-FROM-EDGE: If ESCAPE-FROM-EDGE is nil, then NEW-POS is\n\
506 constrained to the field that has the same `field' text-property\n\
507 as any new characters inserted at OLD-POS, whereas if ESCAPE-FROM-EDGE\n\
508 is non-nil, NEW-POS is constrained to the union of the two adjacent\n\
511 If the optional argument ONLY-IN-LINE is non-nil and constraining\n\
512 NEW-POS would move it to a different line, NEW-POS is returned\n\
513 unconstrained. This useful for commands that move by line, like\n\
514 \\[next-line] or \\[beginning-of-line], which should generally respect field boundaries\n\
515 only in the case where they can still move to the right line.")
516 (new_pos
, old_pos
, escape_from_edge
, only_in_line
)
517 Lisp_Object new_pos
, old_pos
, escape_from_edge
, only_in_line
;
519 /* If non-zero, then the original point, before re-positioning. */
523 /* Use the current point, and afterwards, set it. */
526 XSETFASTINT (new_pos
, PT
);
529 if (!EQ (new_pos
, old_pos
) && !text_property_eq (Qfield
, new_pos
, old_pos
))
530 /* NEW_POS is not within the same field as OLD_POS; try to
531 move NEW_POS so that it is. */
534 Lisp_Object field_bound
;
536 CHECK_NUMBER_COERCE_MARKER (new_pos
, 0);
537 CHECK_NUMBER_COERCE_MARKER (old_pos
, 0);
539 fwd
= (XFASTINT (new_pos
) > XFASTINT (old_pos
));
542 field_bound
= Ffield_end (old_pos
, escape_from_edge
);
544 field_bound
= Ffield_beginning (old_pos
, escape_from_edge
);
546 if (/* If ONLY_IN_LINE is non-nil, we only constrain NEW_POS if doing
547 so would remain within the same line. */
549 /* In that case, see if ESCAPE_FROM_EDGE caused FIELD_BOUND
550 to jump to the other side of NEW_POS, which would mean
551 that NEW_POS is already acceptable, and that we don't
552 have to do the line-check. */
553 || ((XFASTINT (field_bound
) < XFASTINT (new_pos
)) ? !fwd
: fwd
)
554 /* If not, see if there's no newline intervening between
555 NEW_POS and FIELD_BOUND. */
556 || (find_before_next_newline (XFASTINT (new_pos
),
557 XFASTINT (field_bound
),
559 == XFASTINT (field_bound
)))
560 /* Constrain NEW_POS to FIELD_BOUND. */
561 new_pos
= field_bound
;
563 if (orig_point
&& XFASTINT (new_pos
) != orig_point
)
564 /* The NEW_POS argument was originally nil, so automatically set PT. */
565 SET_PT (XFASTINT (new_pos
));
571 DEFUN ("line-beginning-position", Fline_beginning_position
, Sline_beginning_position
,
573 "Return the character position of the first character on the current line.\n\
574 With argument N not nil or 1, move forward N - 1 lines first.\n\
575 If scan reaches end of buffer, return that position.\n\
576 The scan does not cross a field boundary unless it would move\n\
577 beyond there to a different line. And if N is nil or 1,\n\
578 and scan starts at a field boundary, the scan stops as soon as it starts.\n\n\
579 This function does not move point.")
583 register int orig
, orig_byte
, end
;
592 Fforward_line (make_number (XINT (n
) - 1));
595 SET_PT_BOTH (orig
, orig_byte
);
597 /* Return END constrained to the current input field. */
598 return Fconstrain_to_field (make_number (end
), make_number (orig
),
599 XINT (n
) != 1 ? Qt
: Qnil
,
603 DEFUN ("line-end-position", Fline_end_position
, Sline_end_position
,
605 "Return the character position of the last character on the current line.\n\
606 With argument N not nil or 1, move forward N - 1 lines first.\n\
607 If scan reaches end of buffer, return that position.\n\
608 This function does not move point.")
613 register int orig
= PT
;
620 end_pos
= find_before_next_newline (orig
, 0, XINT (n
) - (XINT (n
) <= 0));
622 /* Return END_POS constrained to the current input field. */
624 Fconstrain_to_field (make_number (end_pos
), make_number (orig
), Qnil
, Qt
);
628 save_excursion_save ()
630 register int visible
= (XBUFFER (XWINDOW (selected_window
)->buffer
)
633 return Fcons (Fpoint_marker (),
634 Fcons (Fcopy_marker (current_buffer
->mark
, Qnil
),
635 Fcons (visible
? Qt
: Qnil
,
636 current_buffer
->mark_active
)));
640 save_excursion_restore (info
)
643 Lisp_Object tem
, tem1
, omark
, nmark
;
644 struct gcpro gcpro1
, gcpro2
, gcpro3
;
646 tem
= Fmarker_buffer (Fcar (info
));
647 /* If buffer being returned to is now deleted, avoid error */
648 /* Otherwise could get error here while unwinding to top level
650 /* In that case, Fmarker_buffer returns nil now. */
654 omark
= nmark
= Qnil
;
655 GCPRO3 (info
, omark
, nmark
);
660 unchain_marker (tem
);
661 tem
= Fcar (Fcdr (info
));
662 omark
= Fmarker_position (current_buffer
->mark
);
663 Fset_marker (current_buffer
->mark
, tem
, Fcurrent_buffer ());
664 nmark
= Fmarker_position (tem
);
665 unchain_marker (tem
);
666 tem
= Fcdr (Fcdr (info
));
667 #if 0 /* We used to make the current buffer visible in the selected window
668 if that was true previously. That avoids some anomalies.
669 But it creates others, and it wasn't documented, and it is simpler
670 and cleaner never to alter the window/buffer connections. */
673 && current_buffer
!= XBUFFER (XWINDOW (selected_window
)->buffer
))
674 Fswitch_to_buffer (Fcurrent_buffer (), Qnil
);
677 tem1
= current_buffer
->mark_active
;
678 current_buffer
->mark_active
= Fcdr (tem
);
679 if (!NILP (Vrun_hooks
))
681 /* If mark is active now, and either was not active
682 or was at a different place, run the activate hook. */
683 if (! NILP (current_buffer
->mark_active
))
685 if (! EQ (omark
, nmark
))
686 call1 (Vrun_hooks
, intern ("activate-mark-hook"));
688 /* If mark has ceased to be active, run deactivate hook. */
689 else if (! NILP (tem1
))
690 call1 (Vrun_hooks
, intern ("deactivate-mark-hook"));
696 DEFUN ("save-excursion", Fsave_excursion
, Ssave_excursion
, 0, UNEVALLED
, 0,
697 "Save point, mark, and current buffer; execute BODY; restore those things.\n\
698 Executes BODY just like `progn'.\n\
699 The values of point, mark and the current buffer are restored\n\
700 even in case of abnormal exit (throw or error).\n\
701 The state of activation of the mark is also restored.\n\
703 This construct does not save `deactivate-mark', and therefore\n\
704 functions that change the buffer will still cause deactivation\n\
705 of the mark at the end of the command. To prevent that, bind\n\
706 `deactivate-mark' with `let'.")
710 register Lisp_Object val
;
711 int count
= specpdl_ptr
- specpdl
;
713 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
716 return unbind_to (count
, val
);
719 DEFUN ("save-current-buffer", Fsave_current_buffer
, Ssave_current_buffer
, 0, UNEVALLED
, 0,
720 "Save the current buffer; execute BODY; restore the current buffer.\n\
721 Executes BODY just like `progn'.")
725 register Lisp_Object val
;
726 int count
= specpdl_ptr
- specpdl
;
728 record_unwind_protect (set_buffer_if_live
, Fcurrent_buffer ());
731 return unbind_to (count
, val
);
734 DEFUN ("buffer-size", Fbufsize
, Sbufsize
, 0, 1, 0,
735 "Return the number of characters in the current buffer.\n\
736 If BUFFER, return the number of characters in that buffer instead.")
741 return make_number (Z
- BEG
);
744 CHECK_BUFFER (buffer
, 1);
745 return make_number (BUF_Z (XBUFFER (buffer
))
746 - BUF_BEG (XBUFFER (buffer
)));
750 DEFUN ("point-min", Fpoint_min
, Spoint_min
, 0, 0, 0,
751 "Return the minimum permissible value of point in the current buffer.\n\
752 This is 1, unless narrowing (a buffer restriction) is in effect.")
756 XSETFASTINT (temp
, BEGV
);
760 DEFUN ("point-min-marker", Fpoint_min_marker
, Spoint_min_marker
, 0, 0, 0,
761 "Return a marker to the minimum permissible value of point in this buffer.\n\
762 This is the beginning, unless narrowing (a buffer restriction) is in effect.")
765 return buildmark (BEGV
, BEGV_BYTE
);
768 DEFUN ("point-max", Fpoint_max
, Spoint_max
, 0, 0, 0,
769 "Return the maximum permissible value of point in the current buffer.\n\
770 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)\n\
771 is in effect, in which case it is less.")
775 XSETFASTINT (temp
, ZV
);
779 DEFUN ("point-max-marker", Fpoint_max_marker
, Spoint_max_marker
, 0, 0, 0,
780 "Return a marker to the maximum permissible value of point in this buffer.\n\
781 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)\n\
782 is in effect, in which case it is less.")
785 return buildmark (ZV
, ZV_BYTE
);
788 DEFUN ("gap-position", Fgap_position
, Sgap_position
, 0, 0, 0,
789 "Return the position of the gap, in the current buffer.\n\
790 See also `gap-size'.")
794 XSETFASTINT (temp
, GPT
);
798 DEFUN ("gap-size", Fgap_size
, Sgap_size
, 0, 0, 0,
799 "Return the size of the current buffer's gap.\n\
800 See also `gap-position'.")
804 XSETFASTINT (temp
, GAP_SIZE
);
808 DEFUN ("position-bytes", Fposition_bytes
, Sposition_bytes
, 1, 1, 0,
809 "Return the byte position for character position POSITION.\n\
810 If POSITION is out of range, the value is nil.")
812 Lisp_Object position
;
814 CHECK_NUMBER_COERCE_MARKER (position
, 1);
815 if (XINT (position
) < BEG
|| XINT (position
) > Z
)
817 return make_number (CHAR_TO_BYTE (XINT (position
)));
820 DEFUN ("byte-to-position", Fbyte_to_position
, Sbyte_to_position
, 1, 1, 0,
821 "Return the character position for byte position BYTEPOS.\n\
822 If BYTEPOS is out of range, the value is nil.")
826 CHECK_NUMBER (bytepos
, 1);
827 if (XINT (bytepos
) < BEG_BYTE
|| XINT (bytepos
) > Z_BYTE
)
829 return make_number (BYTE_TO_CHAR (XINT (bytepos
)));
832 DEFUN ("following-char", Ffollowing_char
, Sfollowing_char
, 0, 0, 0,
833 "Return the character following point, as a number.\n\
834 At the end of the buffer or accessible region, return 0.\n\
835 If `enable-multibyte-characters' is nil or point is not\n\
836 at character boundary, multibyte form is ignored,\n\
837 and only one byte following point is returned as a character.")
842 XSETFASTINT (temp
, 0);
844 XSETFASTINT (temp
, FETCH_CHAR (PT_BYTE
));
848 DEFUN ("preceding-char", Fprevious_char
, Sprevious_char
, 0, 0, 0,
849 "Return the character preceding point, as a number.\n\
850 At the beginning of the buffer or accessible region, return 0.\n\
851 If `enable-multibyte-characters' is nil or point is not\n\
852 at character boundary, multi-byte form is ignored,\n\
853 and only one byte preceding point is returned as a character.")
858 XSETFASTINT (temp
, 0);
859 else if (!NILP (current_buffer
->enable_multibyte_characters
))
863 XSETFASTINT (temp
, FETCH_CHAR (pos
));
866 XSETFASTINT (temp
, FETCH_BYTE (PT_BYTE
- 1));
870 DEFUN ("bobp", Fbobp
, Sbobp
, 0, 0, 0,
871 "Return t if point is at the beginning of the buffer.\n\
872 If the buffer is narrowed, this means the beginning of the narrowed part.")
880 DEFUN ("eobp", Feobp
, Seobp
, 0, 0, 0,
881 "Return t if point is at the end of the buffer.\n\
882 If the buffer is narrowed, this means the end of the narrowed part.")
890 DEFUN ("bolp", Fbolp
, Sbolp
, 0, 0, 0,
891 "Return t if point is at the beginning of a line.")
894 if (PT
== BEGV
|| FETCH_BYTE (PT_BYTE
- 1) == '\n')
899 DEFUN ("eolp", Feolp
, Seolp
, 0, 0, 0,
900 "Return t if point is at the end of a line.\n\
901 `End of a line' includes point being at the end of the buffer.")
904 if (PT
== ZV
|| FETCH_BYTE (PT_BYTE
) == '\n')
909 DEFUN ("char-after", Fchar_after
, Schar_after
, 0, 1, 0,
910 "Return character in current buffer at position POS.\n\
911 POS is an integer or a buffer pointer.\n\
912 If POS is out of range, the value is nil.")
916 register int pos_byte
;
921 XSETFASTINT (pos
, PT
);
926 pos_byte
= marker_byte_position (pos
);
927 if (pos_byte
< BEGV_BYTE
|| pos_byte
>= ZV_BYTE
)
932 CHECK_NUMBER_COERCE_MARKER (pos
, 0);
933 if (XINT (pos
) < BEGV
|| XINT (pos
) >= ZV
)
936 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
939 return make_number (FETCH_CHAR (pos_byte
));
942 DEFUN ("char-before", Fchar_before
, Schar_before
, 0, 1, 0,
943 "Return character in current buffer preceding position POS.\n\
944 POS is an integer or a buffer pointer.\n\
945 If POS is out of range, the value is nil.")
949 register Lisp_Object val
;
950 register int pos_byte
;
955 XSETFASTINT (pos
, PT
);
960 pos_byte
= marker_byte_position (pos
);
962 if (pos_byte
<= BEGV_BYTE
|| pos_byte
> ZV_BYTE
)
967 CHECK_NUMBER_COERCE_MARKER (pos
, 0);
969 if (XINT (pos
) <= BEGV
|| XINT (pos
) > ZV
)
972 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
975 if (!NILP (current_buffer
->enable_multibyte_characters
))
978 XSETFASTINT (val
, FETCH_CHAR (pos_byte
));
983 XSETFASTINT (val
, FETCH_BYTE (pos_byte
));
988 DEFUN ("user-login-name", Fuser_login_name
, Suser_login_name
, 0, 1, 0,
989 "Return the name under which the user logged in, as a string.\n\
990 This is based on the effective uid, not the real uid.\n\
991 Also, if the environment variable LOGNAME or USER is set,\n\
992 that determines the value of this function.\n\n\
993 If optional argument UID is an integer, return the login name of the user\n\
994 with that uid, or nil if there is no such user.")
1000 /* Set up the user name info if we didn't do it before.
1001 (That can happen if Emacs is dumpable
1002 but you decide to run `temacs -l loadup' and not dump. */
1003 if (INTEGERP (Vuser_login_name
))
1007 return Vuser_login_name
;
1009 CHECK_NUMBER (uid
, 0);
1010 pw
= (struct passwd
*) getpwuid (XINT (uid
));
1011 return (pw
? build_string (pw
->pw_name
) : Qnil
);
1014 DEFUN ("user-real-login-name", Fuser_real_login_name
, Suser_real_login_name
,
1016 "Return the name of the user's real uid, as a string.\n\
1017 This ignores the environment variables LOGNAME and USER, so it differs from\n\
1018 `user-login-name' when running under `su'.")
1021 /* Set up the user name info if we didn't do it before.
1022 (That can happen if Emacs is dumpable
1023 but you decide to run `temacs -l loadup' and not dump. */
1024 if (INTEGERP (Vuser_login_name
))
1026 return Vuser_real_login_name
;
1029 DEFUN ("user-uid", Fuser_uid
, Suser_uid
, 0, 0, 0,
1030 "Return the effective uid of Emacs, as an integer.")
1033 return make_number (geteuid ());
1036 DEFUN ("user-real-uid", Fuser_real_uid
, Suser_real_uid
, 0, 0, 0,
1037 "Return the real uid of Emacs, as an integer.")
1040 return make_number (getuid ());
1043 DEFUN ("user-full-name", Fuser_full_name
, Suser_full_name
, 0, 1, 0,
1044 "Return the full name of the user logged in, as a string.\n\
1045 If the full name corresponding to Emacs's userid is not known,\n\
1046 return \"unknown\".\n\
1048 If optional argument UID is an integer, return the full name of the user\n\
1049 with that uid, or nil if there is no such user.\n\
1050 If UID is a string, return the full name of the user with that login\n\
1051 name, or nil if there is no such user.")
1056 register unsigned char *p
, *q
;
1057 extern char *index ();
1061 return Vuser_full_name
;
1062 else if (NUMBERP (uid
))
1063 pw
= (struct passwd
*) getpwuid (XINT (uid
));
1064 else if (STRINGP (uid
))
1065 pw
= (struct passwd
*) getpwnam (XSTRING (uid
)->data
);
1067 error ("Invalid UID specification");
1072 p
= (unsigned char *) USER_FULL_NAME
;
1073 /* Chop off everything after the first comma. */
1074 q
= (unsigned char *) index (p
, ',');
1075 full
= make_string (p
, q
? q
- p
: strlen (p
));
1077 #ifdef AMPERSAND_FULL_NAME
1078 p
= XSTRING (full
)->data
;
1079 q
= (unsigned char *) index (p
, '&');
1080 /* Substitute the login name for the &, upcasing the first character. */
1083 register unsigned char *r
;
1086 login
= Fuser_login_name (make_number (pw
->pw_uid
));
1087 r
= (unsigned char *) alloca (strlen (p
) + XSTRING (login
)->size
+ 1);
1088 bcopy (p
, r
, q
- p
);
1090 strcat (r
, XSTRING (login
)->data
);
1091 r
[q
- p
] = UPCASE (r
[q
- p
]);
1093 full
= build_string (r
);
1095 #endif /* AMPERSAND_FULL_NAME */
1100 DEFUN ("system-name", Fsystem_name
, Ssystem_name
, 0, 0, 0,
1101 "Return the name of the machine you are running on, as a string.")
1104 return Vsystem_name
;
1107 /* For the benefit of callers who don't want to include lisp.h */
1111 if (STRINGP (Vsystem_name
))
1112 return (char *) XSTRING (Vsystem_name
)->data
;
1117 DEFUN ("emacs-pid", Femacs_pid
, Semacs_pid
, 0, 0, 0,
1118 "Return the process ID of Emacs, as an integer.")
1121 return make_number (getpid ());
1124 DEFUN ("current-time", Fcurrent_time
, Scurrent_time
, 0, 0, 0,
1125 "Return the current time, as the number of seconds since 1970-01-01 00:00:00.\n\
1126 The time is returned as a list of three integers. The first has the\n\
1127 most significant 16 bits of the seconds, while the second has the\n\
1128 least significant 16 bits. The third integer gives the microsecond\n\
1131 The microsecond count is zero on systems that do not provide\n\
1132 resolution finer than a second.")
1136 Lisp_Object result
[3];
1139 XSETINT (result
[0], (EMACS_SECS (t
) >> 16) & 0xffff);
1140 XSETINT (result
[1], (EMACS_SECS (t
) >> 0) & 0xffff);
1141 XSETINT (result
[2], EMACS_USECS (t
));
1143 return Flist (3, result
);
1148 lisp_time_argument (specified_time
, result
)
1149 Lisp_Object specified_time
;
1152 if (NILP (specified_time
))
1153 return time (result
) != -1;
1156 Lisp_Object high
, low
;
1157 high
= Fcar (specified_time
);
1158 CHECK_NUMBER (high
, 0);
1159 low
= Fcdr (specified_time
);
1162 CHECK_NUMBER (low
, 0);
1163 *result
= (XINT (high
) << 16) + (XINT (low
) & 0xffff);
1164 return *result
>> 16 == XINT (high
);
1168 /* Write information into buffer S of size MAXSIZE, according to the
1169 FORMAT of length FORMAT_LEN, using time information taken from *TP.
1170 Default to Universal Time if UT is nonzero, local time otherwise.
1171 Return the number of bytes written, not including the terminating
1172 '\0'. If S is NULL, nothing will be written anywhere; so to
1173 determine how many bytes would be written, use NULL for S and
1174 ((size_t) -1) for MAXSIZE.
1176 This function behaves like emacs_strftimeu, except it allows null
1179 emacs_memftimeu (s
, maxsize
, format
, format_len
, tp
, ut
)
1184 const struct tm
*tp
;
1189 /* Loop through all the null-terminated strings in the format
1190 argument. Normally there's just one null-terminated string, but
1191 there can be arbitrarily many, concatenated together, if the
1192 format contains '\0' bytes. emacs_strftimeu stops at the first
1193 '\0' byte so we must invoke it separately for each such string. */
1202 result
= emacs_strftimeu (s
, maxsize
, format
, tp
, ut
);
1206 if (result
== 0 && s
[0] != '\0')
1211 maxsize
-= result
+ 1;
1213 len
= strlen (format
);
1214 if (len
== format_len
)
1218 format_len
-= len
+ 1;
1223 DEFUN ("format-time-string", Fformat_time_string, Sformat_time_string, 1, 3, 0,
1224 "Use FORMAT-STRING to format the time TIME, or now if omitted.\n\
1225 TIME is specified as (HIGH LOW . IGNORED) or (HIGH . LOW), as returned by\n\
1226 `current-time' or `file-attributes'.\n\
1227 The third, optional, argument UNIVERSAL, if non-nil, means describe TIME\n\
1228 as Universal Time; nil means describe TIME in the local time zone.\n\
1229 The value is a copy of FORMAT-STRING, but with certain constructs replaced\n\
1230 by text that describes the specified date and time in TIME:\n\
1232 %Y is the year, %y within the century, %C the century.\n\
1233 %G is the year corresponding to the ISO week, %g within the century.\n\
1234 %m is the numeric month.\n\
1235 %b and %h are the locale's abbreviated month name, %B the full name.\n\
1236 %d is the day of the month, zero-padded, %e is blank-padded.\n\
1237 %u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.\n\
1238 %a is the locale's abbreviated name of the day of week, %A the full name.\n\
1239 %U is the week number starting on Sunday, %W starting on Monday,\n\
1240 %V according to ISO 8601.\n\
1241 %j is the day of the year.\n\
1243 %H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H\n\
1244 only blank-padded, %l is like %I blank-padded.\n\
1245 %p is the locale's equivalent of either AM or PM.\n\
1246 %M is the minute.\n\
1247 %S is the second.\n\
1248 %Z is the time zone name, %z is the numeric form.\n\
1249 %s is the number of seconds since 1970-01-01 00:00:00 +0000.\n\
1251 %c is the locale's date and time format.\n\
1252 %x is the locale's \"preferred\" date format.\n\
1253 %D is like \"%m/%d/%y\".\n\
1255 %R is like \"%H:%M\", %T is like \"%H:%M:%S\", %r is like \"%I:%M:%S %p\".\n\
1256 %X is the locale's \"preferred\" time format.\n\
1258 Finally, %n is a newline, %t is a tab, %% is a literal %.\n\
1260 Certain flags and modifiers are available with some format controls.\n\
1261 The flags are `_' and `-'. For certain characters X, %_X is like %X,\n\
1262 but padded with blanks; %-X is like %X, but without padding.\n\
1263 %NX (where N stands for an integer) is like %X,\n\
1264 but takes up at least N (a number) positions.\n\
1265 The modifiers are `E' and `O'. For certain characters X,\n\
1266 %EX is a locale's alternative version of %X;\n\
1267 %OX is like %X, but uses the locale's number symbols.\n\
1269 For example, to produce full ISO 8601 format, use \"%Y-%m-%dT%T%z\".")
1270 (format_string, time, universal)
1273 DEFUN ("format-time-string", Fformat_time_string
, Sformat_time_string
, 1, 3, 0,
1274 0 /* See immediately above */)
1275 (format_string
, time
, universal
)
1276 Lisp_Object format_string
, time
, universal
;
1281 int ut
= ! NILP (universal
);
1283 CHECK_STRING (format_string
, 1);
1285 if (! lisp_time_argument (time
, &value
))
1286 error ("Invalid time specification");
1288 format_string
= code_convert_string_norecord (format_string
,
1289 Vlocale_coding_system
, 1);
1291 /* This is probably enough. */
1292 size
= STRING_BYTES (XSTRING (format_string
)) * 6 + 50;
1294 tm
= ut
? gmtime (&value
) : localtime (&value
);
1296 error ("Specified time is not representable");
1298 synchronize_time_locale ();
1302 char *buf
= (char *) alloca (size
+ 1);
1306 result
= emacs_memftimeu (buf
, size
, XSTRING (format_string
)->data
,
1307 STRING_BYTES (XSTRING (format_string
)),
1309 if ((result
> 0 && result
< size
) || (result
== 0 && buf
[0] == '\0'))
1310 return code_convert_string_norecord (make_string (buf
, result
),
1311 Vlocale_coding_system
, 0);
1313 /* If buffer was too small, make it bigger and try again. */
1314 result
= emacs_memftimeu (NULL
, (size_t) -1,
1315 XSTRING (format_string
)->data
,
1316 STRING_BYTES (XSTRING (format_string
)),
1322 DEFUN ("decode-time", Fdecode_time
, Sdecode_time
, 0, 1, 0,
1323 "Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST ZONE).\n\
1324 The optional SPECIFIED-TIME should be a list of (HIGH LOW . IGNORED)\n\
1325 or (HIGH . LOW), as from `current-time' and `file-attributes', or `nil'\n\
1326 to use the current time. The list has the following nine members:\n\
1327 SEC is an integer between 0 and 60; SEC is 60 for a leap second, which\n\
1328 only some operating systems support. MINUTE is an integer between 0 and 59.\n\
1329 HOUR is an integer between 0 and 23. DAY is an integer between 1 and 31.\n\
1330 MONTH is an integer between 1 and 12. YEAR is an integer indicating the\n\
1331 four-digit year. DOW is the day of week, an integer between 0 and 6, where\n\
1332 0 is Sunday. DST is t if daylight savings time is effect, otherwise nil.\n\
1333 ZONE is an integer indicating the number of seconds east of Greenwich.\n\
1334 \(Note that Common Lisp has different meanings for DOW and ZONE.)")
1336 Lisp_Object specified_time
;
1340 struct tm
*decoded_time
;
1341 Lisp_Object list_args
[9];
1343 if (! lisp_time_argument (specified_time
, &time_spec
))
1344 error ("Invalid time specification");
1346 decoded_time
= localtime (&time_spec
);
1348 error ("Specified time is not representable");
1349 XSETFASTINT (list_args
[0], decoded_time
->tm_sec
);
1350 XSETFASTINT (list_args
[1], decoded_time
->tm_min
);
1351 XSETFASTINT (list_args
[2], decoded_time
->tm_hour
);
1352 XSETFASTINT (list_args
[3], decoded_time
->tm_mday
);
1353 XSETFASTINT (list_args
[4], decoded_time
->tm_mon
+ 1);
1354 XSETINT (list_args
[5], decoded_time
->tm_year
+ 1900);
1355 XSETFASTINT (list_args
[6], decoded_time
->tm_wday
);
1356 list_args
[7] = (decoded_time
->tm_isdst
)? Qt
: Qnil
;
1358 /* Make a copy, in case gmtime modifies the struct. */
1359 save_tm
= *decoded_time
;
1360 decoded_time
= gmtime (&time_spec
);
1361 if (decoded_time
== 0)
1362 list_args
[8] = Qnil
;
1364 XSETINT (list_args
[8], tm_diff (&save_tm
, decoded_time
));
1365 return Flist (9, list_args
);
1368 DEFUN ("encode-time", Fencode_time
, Sencode_time
, 6, MANY
, 0,
1369 "Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.\n\
1370 This is the reverse operation of `decode-time', which see.\n\
1371 ZONE defaults to the current time zone rule. This can\n\
1372 be a string or t (as from `set-time-zone-rule'), or it can be a list\n\
1373 \(as from `current-time-zone') or an integer (as from `decode-time')\n\
1374 applied without consideration for daylight savings time.\n\
1376 You can pass more than 7 arguments; then the first six arguments\n\
1377 are used as SECOND through YEAR, and the *last* argument is used as ZONE.\n\
1378 The intervening arguments are ignored.\n\
1379 This feature lets (apply 'encode-time (decode-time ...)) work.\n\
1381 Out-of-range values for SEC, MINUTE, HOUR, DAY, or MONTH are allowed;\n\
1382 for example, a DAY of 0 means the day preceding the given month.\n\
1383 Year numbers less than 100 are treated just like other year numbers.\n\
1384 If you want them to stand for years in this century, you must do that yourself.")
1387 register Lisp_Object
*args
;
1391 Lisp_Object zone
= (nargs
> 6 ? args
[nargs
- 1] : Qnil
);
1393 CHECK_NUMBER (args
[0], 0); /* second */
1394 CHECK_NUMBER (args
[1], 1); /* minute */
1395 CHECK_NUMBER (args
[2], 2); /* hour */
1396 CHECK_NUMBER (args
[3], 3); /* day */
1397 CHECK_NUMBER (args
[4], 4); /* month */
1398 CHECK_NUMBER (args
[5], 5); /* year */
1400 tm
.tm_sec
= XINT (args
[0]);
1401 tm
.tm_min
= XINT (args
[1]);
1402 tm
.tm_hour
= XINT (args
[2]);
1403 tm
.tm_mday
= XINT (args
[3]);
1404 tm
.tm_mon
= XINT (args
[4]) - 1;
1405 tm
.tm_year
= XINT (args
[5]) - 1900;
1411 time
= mktime (&tm
);
1416 char **oldenv
= environ
, **newenv
;
1420 else if (STRINGP (zone
))
1421 tzstring
= (char *) XSTRING (zone
)->data
;
1422 else if (INTEGERP (zone
))
1424 int abszone
= abs (XINT (zone
));
1425 sprintf (tzbuf
, "XXX%s%d:%02d:%02d", "-" + (XINT (zone
) < 0),
1426 abszone
/ (60*60), (abszone
/60) % 60, abszone
% 60);
1430 error ("Invalid time zone specification");
1432 /* Set TZ before calling mktime; merely adjusting mktime's returned
1433 value doesn't suffice, since that would mishandle leap seconds. */
1434 set_time_zone_rule (tzstring
);
1436 time
= mktime (&tm
);
1438 /* Restore TZ to previous value. */
1442 #ifdef LOCALTIME_CACHE
1447 if (time
== (time_t) -1)
1448 error ("Specified time is not representable");
1450 return make_time (time
);
1453 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
, 0, 1, 0,
1454 "Return the current time, as a human-readable string.\n\
1455 Programs can use this function to decode a time,\n\
1456 since the number of columns in each field is fixed.\n\
1457 The format is `Sun Sep 16 01:03:52 1973'.\n\
1458 However, see also the functions `decode-time' and `format-time-string'\n\
1459 which provide a much more powerful and general facility.\n\
1461 If an argument is given, it specifies a time to format\n\
1462 instead of the current time. The argument should have the form:\n\
1465 (HIGH LOW . IGNORED).\n\
1466 Thus, you can use times obtained from `current-time'\n\
1467 and from `file-attributes'.")
1469 Lisp_Object specified_time
;
1475 if (! lisp_time_argument (specified_time
, &value
))
1477 tem
= (char *) ctime (&value
);
1479 strncpy (buf
, tem
, 24);
1482 return build_string (buf
);
1485 #define TM_YEAR_BASE 1900
1487 /* Yield A - B, measured in seconds.
1488 This function is copied from the GNU C Library. */
1493 /* Compute intervening leap days correctly even if year is negative.
1494 Take care to avoid int overflow in leap day calculations,
1495 but it's OK to assume that A and B are close to each other. */
1496 int a4
= (a
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (a
->tm_year
& 3);
1497 int b4
= (b
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (b
->tm_year
& 3);
1498 int a100
= a4
/ 25 - (a4
% 25 < 0);
1499 int b100
= b4
/ 25 - (b4
% 25 < 0);
1500 int a400
= a100
>> 2;
1501 int b400
= b100
>> 2;
1502 int intervening_leap_days
= (a4
- b4
) - (a100
- b100
) + (a400
- b400
);
1503 int years
= a
->tm_year
- b
->tm_year
;
1504 int days
= (365 * years
+ intervening_leap_days
1505 + (a
->tm_yday
- b
->tm_yday
));
1506 return (60 * (60 * (24 * days
+ (a
->tm_hour
- b
->tm_hour
))
1507 + (a
->tm_min
- b
->tm_min
))
1508 + (a
->tm_sec
- b
->tm_sec
));
1511 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 1, 0,
1512 "Return the offset and name for the local time zone.\n\
1513 This returns a list of the form (OFFSET NAME).\n\
1514 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).\n\
1515 A negative value means west of Greenwich.\n\
1516 NAME is a string giving the name of the time zone.\n\
1517 If an argument is given, it specifies when the time zone offset is determined\n\
1518 instead of using the current time. The argument should have the form:\n\
1521 (HIGH LOW . IGNORED).\n\
1522 Thus, you can use times obtained from `current-time'\n\
1523 and from `file-attributes'.\n\
1525 Some operating systems cannot provide all this information to Emacs;\n\
1526 in this case, `current-time-zone' returns a list containing nil for\n\
1527 the data it can't find.")
1529 Lisp_Object specified_time
;
1535 if (lisp_time_argument (specified_time
, &value
)
1536 && (t
= gmtime (&value
)) != 0
1537 && (gmt
= *t
, t
= localtime (&value
)) != 0)
1539 int offset
= tm_diff (t
, &gmt
);
1544 s
= (char *)t
->tm_zone
;
1545 #else /* not HAVE_TM_ZONE */
1547 if (t
->tm_isdst
== 0 || t
->tm_isdst
== 1)
1548 s
= tzname
[t
->tm_isdst
];
1550 #endif /* not HAVE_TM_ZONE */
1553 /* No local time zone name is available; use "+-NNNN" instead. */
1554 int am
= (offset
< 0 ? -offset
: offset
) / 60;
1555 sprintf (buf
, "%c%02d%02d", (offset
< 0 ? '-' : '+'), am
/60, am
%60);
1558 return Fcons (make_number (offset
), Fcons (build_string (s
), Qnil
));
1561 return Fmake_list (make_number (2), Qnil
);
1564 /* This holds the value of `environ' produced by the previous
1565 call to Fset_time_zone_rule, or 0 if Fset_time_zone_rule
1566 has never been called. */
1567 static char **environbuf
;
1569 DEFUN ("set-time-zone-rule", Fset_time_zone_rule
, Sset_time_zone_rule
, 1, 1, 0,
1570 "Set the local time zone using TZ, a string specifying a time zone rule.\n\
1571 If TZ is nil, use implementation-defined default time zone information.\n\
1572 If TZ is t, use Universal Time.")
1580 else if (EQ (tz
, Qt
))
1584 CHECK_STRING (tz
, 0);
1585 tzstring
= (char *) XSTRING (tz
)->data
;
1588 set_time_zone_rule (tzstring
);
1591 environbuf
= environ
;
1596 #ifdef LOCALTIME_CACHE
1598 /* These two values are known to load tz files in buggy implementations,
1599 i.e. Solaris 1 executables running under either Solaris 1 or Solaris 2.
1600 Their values shouldn't matter in non-buggy implementations.
1601 We don't use string literals for these strings,
1602 since if a string in the environment is in readonly
1603 storage, it runs afoul of bugs in SVR4 and Solaris 2.3.
1604 See Sun bugs 1113095 and 1114114, ``Timezone routines
1605 improperly modify environment''. */
1607 static char set_time_zone_rule_tz1
[] = "TZ=GMT+0";
1608 static char set_time_zone_rule_tz2
[] = "TZ=GMT+1";
1612 /* Set the local time zone rule to TZSTRING.
1613 This allocates memory into `environ', which it is the caller's
1614 responsibility to free. */
1616 set_time_zone_rule (tzstring
)
1620 char **from
, **to
, **newenv
;
1622 /* Make the ENVIRON vector longer with room for TZSTRING. */
1623 for (from
= environ
; *from
; from
++)
1625 envptrs
= from
- environ
+ 2;
1626 newenv
= to
= (char **) xmalloc (envptrs
* sizeof (char *)
1627 + (tzstring
? strlen (tzstring
) + 4 : 0));
1629 /* Add TZSTRING to the end of environ, as a value for TZ. */
1632 char *t
= (char *) (to
+ envptrs
);
1634 strcat (t
, tzstring
);
1638 /* Copy the old environ vector elements into NEWENV,
1639 but don't copy the TZ variable.
1640 So we have only one definition of TZ, which came from TZSTRING. */
1641 for (from
= environ
; *from
; from
++)
1642 if (strncmp (*from
, "TZ=", 3) != 0)
1648 /* If we do have a TZSTRING, NEWENV points to the vector slot where
1649 the TZ variable is stored. If we do not have a TZSTRING,
1650 TO points to the vector slot which has the terminating null. */
1652 #ifdef LOCALTIME_CACHE
1654 /* In SunOS 4.1.3_U1 and 4.1.4, if TZ has a value like
1655 "US/Pacific" that loads a tz file, then changes to a value like
1656 "XXX0" that does not load a tz file, and then changes back to
1657 its original value, the last change is (incorrectly) ignored.
1658 Also, if TZ changes twice in succession to values that do
1659 not load a tz file, tzset can dump core (see Sun bug#1225179).
1660 The following code works around these bugs. */
1664 /* Temporarily set TZ to a value that loads a tz file
1665 and that differs from tzstring. */
1667 *newenv
= (strcmp (tzstring
, set_time_zone_rule_tz1
+ 3) == 0
1668 ? set_time_zone_rule_tz2
: set_time_zone_rule_tz1
);
1674 /* The implied tzstring is unknown, so temporarily set TZ to
1675 two different values that each load a tz file. */
1676 *to
= set_time_zone_rule_tz1
;
1679 *to
= set_time_zone_rule_tz2
;
1684 /* Now TZ has the desired value, and tzset can be invoked safely. */
1691 /* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC
1692 (if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a
1693 type of object is Lisp_String). INHERIT is passed to
1694 INSERT_FROM_STRING_FUNC as the last argument. */
1697 general_insert_function (insert_func
, insert_from_string_func
,
1698 inherit
, nargs
, args
)
1699 void (*insert_func
) P_ ((unsigned char *, int));
1700 void (*insert_from_string_func
) P_ ((Lisp_Object
, int, int, int, int, int));
1702 register Lisp_Object
*args
;
1704 register int argnum
;
1705 register Lisp_Object val
;
1707 for (argnum
= 0; argnum
< nargs
; argnum
++)
1713 unsigned char workbuf
[4], *str
;
1716 if (!NILP (current_buffer
->enable_multibyte_characters
))
1717 len
= CHAR_STRING (XFASTINT (val
), workbuf
, str
);
1720 workbuf
[0] = (SINGLE_BYTE_CHAR_P (XINT (val
))
1722 : multibyte_char_to_unibyte (XINT (val
), Qnil
));
1726 (*insert_func
) (str
, len
);
1728 else if (STRINGP (val
))
1730 (*insert_from_string_func
) (val
, 0, 0,
1731 XSTRING (val
)->size
,
1732 STRING_BYTES (XSTRING (val
)),
1737 val
= wrong_type_argument (Qchar_or_string_p
, val
);
1751 /* Callers passing one argument to Finsert need not gcpro the
1752 argument "array", since the only element of the array will
1753 not be used after calling insert or insert_from_string, so
1754 we don't care if it gets trashed. */
1756 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
1757 "Insert the arguments, either strings or characters, at point.\n\
1758 Point and before-insertion markers move forward to end up\n\
1759 after the inserted text.\n\
1760 Any other markers at the point of insertion remain before the text.\n\
1762 If the current buffer is multibyte, unibyte strings are converted\n\
1763 to multibyte for insertion (see `unibyte-char-to-multibyte').\n\
1764 If the current buffer is unibyte, multibyte strings are converted\n\
1765 to unibyte for insertion.")
1768 register Lisp_Object
*args
;
1770 general_insert_function (insert
, insert_from_string
, 0, nargs
, args
);
1774 DEFUN ("insert-and-inherit", Finsert_and_inherit
, Sinsert_and_inherit
,
1776 "Insert the arguments at point, inheriting properties from adjoining text.\n\
1777 Point and before-insertion markers move forward to end up\n\
1778 after the inserted text.\n\
1779 Any other markers at the point of insertion remain before the text.\n\
1781 If the current buffer is multibyte, unibyte strings are converted\n\
1782 to multibyte for insertion (see `unibyte-char-to-multibyte').\n\
1783 If the current buffer is unibyte, multibyte strings are converted\n\
1784 to unibyte for insertion.")
1787 register Lisp_Object
*args
;
1789 general_insert_function (insert_and_inherit
, insert_from_string
, 1,
1794 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
1795 "Insert strings or characters at point, relocating markers after the text.\n\
1796 Point and markers move forward to end up after the inserted text.\n\
1798 If the current buffer is multibyte, unibyte strings are converted\n\
1799 to multibyte for insertion (see `unibyte-char-to-multibyte').\n\
1800 If the current buffer is unibyte, multibyte strings are converted\n\
1801 to unibyte for insertion.")
1804 register Lisp_Object
*args
;
1806 general_insert_function (insert_before_markers
,
1807 insert_from_string_before_markers
, 0,
1812 DEFUN ("insert-before-markers-and-inherit", Finsert_and_inherit_before_markers
,
1813 Sinsert_and_inherit_before_markers
, 0, MANY
, 0,
1814 "Insert text at point, relocating markers and inheriting properties.\n\
1815 Point and markers move forward to end up after the inserted text.\n\
1817 If the current buffer is multibyte, unibyte strings are converted\n\
1818 to multibyte for insertion (see `unibyte-char-to-multibyte').\n\
1819 If the current buffer is unibyte, multibyte strings are converted\n\
1820 to unibyte for insertion.")
1823 register Lisp_Object
*args
;
1825 general_insert_function (insert_before_markers_and_inherit
,
1826 insert_from_string_before_markers
, 1,
1831 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 2, 3, 0,
1832 "Insert COUNT (second arg) copies of CHARACTER (first arg).\n\
1833 Both arguments are required.\n\
1834 Point, and before-insertion markers, are relocated as in the function `insert'.\n\
1835 The optional third arg INHERIT, if non-nil, says to inherit text properties\n\
1836 from adjoining text, if those properties are sticky.")
1837 (character
, count
, inherit
)
1838 Lisp_Object character
, count
, inherit
;
1840 register unsigned char *string
;
1841 register int strlen
;
1844 unsigned char workbuf
[4], *str
;
1846 CHECK_NUMBER (character
, 0);
1847 CHECK_NUMBER (count
, 1);
1849 if (!NILP (current_buffer
->enable_multibyte_characters
))
1850 len
= CHAR_STRING (XFASTINT (character
), workbuf
, str
);
1852 workbuf
[0] = XFASTINT (character
), str
= workbuf
, len
= 1;
1853 n
= XINT (count
) * len
;
1856 strlen
= min (n
, 256 * len
);
1857 string
= (unsigned char *) alloca (strlen
);
1858 for (i
= 0; i
< strlen
; i
++)
1859 string
[i
] = str
[i
% len
];
1863 if (!NILP (inherit
))
1864 insert_and_inherit (string
, strlen
);
1866 insert (string
, strlen
);
1871 if (!NILP (inherit
))
1872 insert_and_inherit (string
, n
);
1880 /* Making strings from buffer contents. */
1882 /* Return a Lisp_String containing the text of the current buffer from
1883 START to END. If text properties are in use and the current buffer
1884 has properties in the range specified, the resulting string will also
1885 have them, if PROPS is nonzero.
1887 We don't want to use plain old make_string here, because it calls
1888 make_uninit_string, which can cause the buffer arena to be
1889 compacted. make_string has no way of knowing that the data has
1890 been moved, and thus copies the wrong data into the string. This
1891 doesn't effect most of the other users of make_string, so it should
1892 be left as is. But we should use this function when conjuring
1893 buffer substrings. */
1896 make_buffer_string (start
, end
, props
)
1900 int start_byte
= CHAR_TO_BYTE (start
);
1901 int end_byte
= CHAR_TO_BYTE (end
);
1903 return make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
);
1906 /* Return a Lisp_String containing the text of the current buffer from
1907 START / START_BYTE to END / END_BYTE.
1909 If text properties are in use and the current buffer
1910 has properties in the range specified, the resulting string will also
1911 have them, if PROPS is nonzero.
1913 We don't want to use plain old make_string here, because it calls
1914 make_uninit_string, which can cause the buffer arena to be
1915 compacted. make_string has no way of knowing that the data has
1916 been moved, and thus copies the wrong data into the string. This
1917 doesn't effect most of the other users of make_string, so it should
1918 be left as is. But we should use this function when conjuring
1919 buffer substrings. */
1922 make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
)
1923 int start
, start_byte
, end
, end_byte
;
1926 Lisp_Object result
, tem
, tem1
;
1928 if (start
< GPT
&& GPT
< end
)
1931 if (! NILP (current_buffer
->enable_multibyte_characters
))
1932 result
= make_uninit_multibyte_string (end
- start
, end_byte
- start_byte
);
1934 result
= make_uninit_string (end
- start
);
1935 bcopy (BYTE_POS_ADDR (start_byte
), XSTRING (result
)->data
,
1936 end_byte
- start_byte
);
1938 /* If desired, update and copy the text properties. */
1941 update_buffer_properties (start
, end
);
1943 tem
= Fnext_property_change (make_number (start
), Qnil
, make_number (end
));
1944 tem1
= Ftext_properties_at (make_number (start
), Qnil
);
1946 if (XINT (tem
) != end
|| !NILP (tem1
))
1947 copy_intervals_to_string (result
, current_buffer
, start
,
1954 /* Call Vbuffer_access_fontify_functions for the range START ... END
1955 in the current buffer, if necessary. */
1958 update_buffer_properties (start
, end
)
1961 /* If this buffer has some access functions,
1962 call them, specifying the range of the buffer being accessed. */
1963 if (!NILP (Vbuffer_access_fontify_functions
))
1965 Lisp_Object args
[3];
1968 args
[0] = Qbuffer_access_fontify_functions
;
1969 XSETINT (args
[1], start
);
1970 XSETINT (args
[2], end
);
1972 /* But don't call them if we can tell that the work
1973 has already been done. */
1974 if (!NILP (Vbuffer_access_fontified_property
))
1976 tem
= Ftext_property_any (args
[1], args
[2],
1977 Vbuffer_access_fontified_property
,
1980 Frun_hook_with_args (3, args
);
1983 Frun_hook_with_args (3, args
);
1987 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
1988 "Return the contents of part of the current buffer as a string.\n\
1989 The two arguments START and END are character positions;\n\
1990 they can be in either order.\n\
1991 The string returned is multibyte if the buffer is multibyte.")
1993 Lisp_Object start
, end
;
1997 validate_region (&start
, &end
);
2001 return make_buffer_string (b
, e
, 1);
2004 DEFUN ("buffer-substring-no-properties", Fbuffer_substring_no_properties
,
2005 Sbuffer_substring_no_properties
, 2, 2, 0,
2006 "Return the characters of part of the buffer, without the text properties.\n\
2007 The two arguments START and END are character positions;\n\
2008 they can be in either order.")
2010 Lisp_Object start
, end
;
2014 validate_region (&start
, &end
);
2018 return make_buffer_string (b
, e
, 0);
2021 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
2022 "Return the contents of the current buffer as a string.\n\
2023 If narrowing is in effect, this function returns only the visible part\n\
2024 of the buffer. If in a mini-buffer, don't include the prompt in the\n\
2028 return make_buffer_string (BEGV
, ZV
, 1);
2031 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
2033 "Insert before point a substring of the contents of buffer BUFFER.\n\
2034 BUFFER may be a buffer or a buffer name.\n\
2035 Arguments START and END are character numbers specifying the substring.\n\
2036 They default to the beginning and the end of BUFFER.")
2038 Lisp_Object buf
, start
, end
;
2040 register int b
, e
, temp
;
2041 register struct buffer
*bp
, *obuf
;
2044 buffer
= Fget_buffer (buf
);
2047 bp
= XBUFFER (buffer
);
2048 if (NILP (bp
->name
))
2049 error ("Selecting deleted buffer");
2055 CHECK_NUMBER_COERCE_MARKER (start
, 0);
2062 CHECK_NUMBER_COERCE_MARKER (end
, 1);
2067 temp
= b
, b
= e
, e
= temp
;
2069 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
2070 args_out_of_range (start
, end
);
2072 obuf
= current_buffer
;
2073 set_buffer_internal_1 (bp
);
2074 update_buffer_properties (b
, e
);
2075 set_buffer_internal_1 (obuf
);
2077 insert_from_buffer (bp
, b
, e
- b
, 0);
2081 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
2083 "Compare two substrings of two buffers; return result as number.\n\
2084 the value is -N if first string is less after N-1 chars,\n\
2085 +N if first string is greater after N-1 chars, or 0 if strings match.\n\
2086 Each substring is represented as three arguments: BUFFER, START and END.\n\
2087 That makes six args in all, three for each substring.\n\n\
2088 The value of `case-fold-search' in the current buffer\n\
2089 determines whether case is significant or ignored.")
2090 (buffer1
, start1
, end1
, buffer2
, start2
, end2
)
2091 Lisp_Object buffer1
, start1
, end1
, buffer2
, start2
, end2
;
2093 register int begp1
, endp1
, begp2
, endp2
, temp
;
2094 register struct buffer
*bp1
, *bp2
;
2095 register Lisp_Object
*trt
2096 = (!NILP (current_buffer
->case_fold_search
)
2097 ? XCHAR_TABLE (current_buffer
->case_canon_table
)->contents
: 0);
2099 int i1
, i2
, i1_byte
, i2_byte
;
2101 /* Find the first buffer and its substring. */
2104 bp1
= current_buffer
;
2108 buf1
= Fget_buffer (buffer1
);
2111 bp1
= XBUFFER (buf1
);
2112 if (NILP (bp1
->name
))
2113 error ("Selecting deleted buffer");
2117 begp1
= BUF_BEGV (bp1
);
2120 CHECK_NUMBER_COERCE_MARKER (start1
, 1);
2121 begp1
= XINT (start1
);
2124 endp1
= BUF_ZV (bp1
);
2127 CHECK_NUMBER_COERCE_MARKER (end1
, 2);
2128 endp1
= XINT (end1
);
2132 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
2134 if (!(BUF_BEGV (bp1
) <= begp1
2136 && endp1
<= BUF_ZV (bp1
)))
2137 args_out_of_range (start1
, end1
);
2139 /* Likewise for second substring. */
2142 bp2
= current_buffer
;
2146 buf2
= Fget_buffer (buffer2
);
2149 bp2
= XBUFFER (buf2
);
2150 if (NILP (bp2
->name
))
2151 error ("Selecting deleted buffer");
2155 begp2
= BUF_BEGV (bp2
);
2158 CHECK_NUMBER_COERCE_MARKER (start2
, 4);
2159 begp2
= XINT (start2
);
2162 endp2
= BUF_ZV (bp2
);
2165 CHECK_NUMBER_COERCE_MARKER (end2
, 5);
2166 endp2
= XINT (end2
);
2170 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
2172 if (!(BUF_BEGV (bp2
) <= begp2
2174 && endp2
<= BUF_ZV (bp2
)))
2175 args_out_of_range (start2
, end2
);
2179 i1_byte
= buf_charpos_to_bytepos (bp1
, i1
);
2180 i2_byte
= buf_charpos_to_bytepos (bp2
, i2
);
2182 while (i1
< endp1
&& i2
< endp2
)
2184 /* When we find a mismatch, we must compare the
2185 characters, not just the bytes. */
2188 if (! NILP (bp1
->enable_multibyte_characters
))
2190 c1
= BUF_FETCH_MULTIBYTE_CHAR (bp1
, i1_byte
);
2191 BUF_INC_POS (bp1
, i1_byte
);
2196 c1
= BUF_FETCH_BYTE (bp1
, i1
);
2197 c1
= unibyte_char_to_multibyte (c1
);
2201 if (! NILP (bp2
->enable_multibyte_characters
))
2203 c2
= BUF_FETCH_MULTIBYTE_CHAR (bp2
, i2_byte
);
2204 BUF_INC_POS (bp2
, i2_byte
);
2209 c2
= BUF_FETCH_BYTE (bp2
, i2
);
2210 c2
= unibyte_char_to_multibyte (c2
);
2216 c1
= XINT (trt
[c1
]);
2217 c2
= XINT (trt
[c2
]);
2220 return make_number (- 1 - chars
);
2222 return make_number (chars
+ 1);
2227 /* The strings match as far as they go.
2228 If one is shorter, that one is less. */
2229 if (chars
< endp1
- begp1
)
2230 return make_number (chars
+ 1);
2231 else if (chars
< endp2
- begp2
)
2232 return make_number (- chars
- 1);
2234 /* Same length too => they are equal. */
2235 return make_number (0);
2239 subst_char_in_region_unwind (arg
)
2242 return current_buffer
->undo_list
= arg
;
2246 subst_char_in_region_unwind_1 (arg
)
2249 return current_buffer
->filename
= arg
;
2252 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
2253 Ssubst_char_in_region
, 4, 5, 0,
2254 "From START to END, replace FROMCHAR with TOCHAR each time it occurs.\n\
2255 If optional arg NOUNDO is non-nil, don't record this change for undo\n\
2256 and don't mark the buffer as really changed.\n\
2257 Both characters must have the same length of multi-byte form.")
2258 (start
, end
, fromchar
, tochar
, noundo
)
2259 Lisp_Object start
, end
, fromchar
, tochar
, noundo
;
2261 register int pos
, pos_byte
, stop
, i
, len
, end_byte
;
2263 unsigned char fromwork
[4], *fromstr
, towork
[4], *tostr
, *p
;
2264 int count
= specpdl_ptr
- specpdl
;
2265 #define COMBINING_NO 0
2266 #define COMBINING_BEFORE 1
2267 #define COMBINING_AFTER 2
2268 #define COMBINING_BOTH (COMBINING_BEFORE | COMBINING_AFTER)
2269 int maybe_byte_combining
= COMBINING_NO
;
2271 validate_region (&start
, &end
);
2272 CHECK_NUMBER (fromchar
, 2);
2273 CHECK_NUMBER (tochar
, 3);
2275 if (! NILP (current_buffer
->enable_multibyte_characters
))
2277 len
= CHAR_STRING (XFASTINT (fromchar
), fromwork
, fromstr
);
2278 if (CHAR_STRING (XFASTINT (tochar
), towork
, tostr
) != len
)
2279 error ("Characters in subst-char-in-region have different byte-lengths");
2280 if (!ASCII_BYTE_P (*tostr
))
2282 /* If *TOSTR is in the range 0x80..0x9F and TOCHAR is not a
2283 complete multibyte character, it may be combined with the
2284 after bytes. If it is in the range 0xA0..0xFF, it may be
2285 combined with the before and after bytes. */
2286 if (!CHAR_HEAD_P (*tostr
))
2287 maybe_byte_combining
= COMBINING_BOTH
;
2288 else if (BYTES_BY_CHAR_HEAD (*tostr
) > len
)
2289 maybe_byte_combining
= COMBINING_AFTER
;
2295 fromwork
[0] = XFASTINT (fromchar
), fromstr
= fromwork
;
2296 towork
[0] = XFASTINT (tochar
), tostr
= towork
;
2300 pos_byte
= CHAR_TO_BYTE (pos
);
2301 stop
= CHAR_TO_BYTE (XINT (end
));
2304 /* If we don't want undo, turn off putting stuff on the list.
2305 That's faster than getting rid of things,
2306 and it prevents even the entry for a first change.
2307 Also inhibit locking the file. */
2310 record_unwind_protect (subst_char_in_region_unwind
,
2311 current_buffer
->undo_list
);
2312 current_buffer
->undo_list
= Qt
;
2313 /* Don't do file-locking. */
2314 record_unwind_protect (subst_char_in_region_unwind_1
,
2315 current_buffer
->filename
);
2316 current_buffer
->filename
= Qnil
;
2319 if (pos_byte
< GPT_BYTE
)
2320 stop
= min (stop
, GPT_BYTE
);
2323 int pos_byte_next
= pos_byte
;
2325 if (pos_byte
>= stop
)
2327 if (pos_byte
>= end_byte
) break;
2330 p
= BYTE_POS_ADDR (pos_byte
);
2331 INC_POS (pos_byte_next
);
2332 if (pos_byte_next
- pos_byte
== len
2333 && p
[0] == fromstr
[0]
2335 || (p
[1] == fromstr
[1]
2336 && (len
== 2 || (p
[2] == fromstr
[2]
2337 && (len
== 3 || p
[3] == fromstr
[3]))))))
2341 modify_region (current_buffer
, XINT (start
), XINT (end
));
2343 if (! NILP (noundo
))
2345 if (MODIFF
- 1 == SAVE_MODIFF
)
2347 if (MODIFF
- 1 == current_buffer
->auto_save_modified
)
2348 current_buffer
->auto_save_modified
++;
2354 /* Take care of the case where the new character
2355 combines with neighboring bytes. */
2356 if (maybe_byte_combining
2357 && (maybe_byte_combining
== COMBINING_AFTER
2358 ? (pos_byte_next
< Z_BYTE
2359 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2360 : ((pos_byte_next
< Z_BYTE
2361 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2362 || (pos_byte
> BEG_BYTE
2363 && ! ASCII_BYTE_P (FETCH_BYTE (pos_byte
- 1))))))
2365 Lisp_Object tem
, string
;
2367 struct gcpro gcpro1
;
2369 tem
= current_buffer
->undo_list
;
2372 /* Make a multibyte string containing this single character. */
2373 string
= make_multibyte_string (tostr
, 1, len
);
2374 /* replace_range is less efficient, because it moves the gap,
2375 but it handles combining correctly. */
2376 replace_range (pos
, pos
+ 1, string
,
2378 pos_byte_next
= CHAR_TO_BYTE (pos
);
2379 if (pos_byte_next
> pos_byte
)
2380 /* Before combining happened. We should not increment
2381 POS. So, to cancel the later increment of POS,
2385 INC_POS (pos_byte_next
);
2387 if (! NILP (noundo
))
2388 current_buffer
->undo_list
= tem
;
2395 record_change (pos
, 1);
2396 for (i
= 0; i
< len
; i
++) *p
++ = tostr
[i
];
2399 pos_byte
= pos_byte_next
;
2404 signal_after_change (XINT (start
),
2405 XINT (end
) - XINT (start
), XINT (end
) - XINT (start
));
2407 unbind_to (count
, Qnil
);
2411 DEFUN ("translate-region", Ftranslate_region
, Stranslate_region
, 3, 3, 0,
2412 "From START to END, translate characters according to TABLE.\n\
2413 TABLE is a string; the Nth character in it is the mapping\n\
2414 for the character with code N.\n\
2415 This function does not alter multibyte characters.\n\
2416 It returns the number of characters changed.")
2420 register Lisp_Object table
;
2422 register int pos_byte
, stop
; /* Limits of the region. */
2423 register unsigned char *tt
; /* Trans table. */
2424 register int nc
; /* New character. */
2425 int cnt
; /* Number of changes made. */
2426 int size
; /* Size of translate table. */
2429 validate_region (&start
, &end
);
2430 CHECK_STRING (table
, 2);
2432 size
= STRING_BYTES (XSTRING (table
));
2433 tt
= XSTRING (table
)->data
;
2435 pos_byte
= CHAR_TO_BYTE (XINT (start
));
2436 stop
= CHAR_TO_BYTE (XINT (end
));
2437 modify_region (current_buffer
, XINT (start
), XINT (end
));
2441 for (; pos_byte
< stop
; )
2443 register unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
2448 oc
= STRING_CHAR_AND_LENGTH (p
, stop
- pos_byte
, len
);
2449 pos_byte_next
= pos_byte
+ len
;
2450 if (oc
< size
&& len
== 1)
2455 /* Take care of the case where the new character
2456 combines with neighboring bytes. */
2457 if (!ASCII_BYTE_P (nc
)
2458 && (CHAR_HEAD_P (nc
)
2459 ? ! CHAR_HEAD_P (FETCH_BYTE (pos_byte
+ 1))
2460 : (pos_byte
> BEG_BYTE
2461 && ! ASCII_BYTE_P (FETCH_BYTE (pos_byte
- 1)))))
2465 string
= make_multibyte_string (tt
+ oc
, 1, 1);
2466 /* This is less efficient, because it moves the gap,
2467 but it handles combining correctly. */
2468 replace_range (pos
, pos
+ 1, string
,
2470 pos_byte_next
= CHAR_TO_BYTE (pos
);
2471 if (pos_byte_next
> pos_byte
)
2472 /* Before combining happened. We should not
2473 increment POS. So, to cancel the later
2474 increment of POS, we decrease it now. */
2477 INC_POS (pos_byte_next
);
2481 record_change (pos
, 1);
2483 signal_after_change (pos
, 1, 1);
2488 pos_byte
= pos_byte_next
;
2492 return make_number (cnt
);
2495 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
2496 "Delete the text between point and mark.\n\
2497 When called from a program, expects two arguments,\n\
2498 positions (integers or markers) specifying the stretch to be deleted.")
2500 Lisp_Object start
, end
;
2502 validate_region (&start
, &end
);
2503 del_range (XINT (start
), XINT (end
));
2507 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
2508 "Remove restrictions (narrowing) from current buffer.\n\
2509 This allows the buffer's full text to be seen and edited.")
2512 if (BEG
!= BEGV
|| Z
!= ZV
)
2513 current_buffer
->clip_changed
= 1;
2515 BEGV_BYTE
= BEG_BYTE
;
2516 SET_BUF_ZV_BOTH (current_buffer
, Z
, Z_BYTE
);
2517 /* Changing the buffer bounds invalidates any recorded current column. */
2518 invalidate_current_column ();
2522 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
2523 "Restrict editing in this buffer to the current region.\n\
2524 The rest of the text becomes temporarily invisible and untouchable\n\
2525 but is not deleted; if you save the buffer in a file, the invisible\n\
2526 text is included in the file. \\[widen] makes all visible again.\n\
2527 See also `save-restriction'.\n\
2529 When calling from a program, pass two arguments; positions (integers\n\
2530 or markers) bounding the text that should remain visible.")
2532 register Lisp_Object start
, end
;
2534 CHECK_NUMBER_COERCE_MARKER (start
, 0);
2535 CHECK_NUMBER_COERCE_MARKER (end
, 1);
2537 if (XINT (start
) > XINT (end
))
2540 tem
= start
; start
= end
; end
= tem
;
2543 if (!(BEG
<= XINT (start
) && XINT (start
) <= XINT (end
) && XINT (end
) <= Z
))
2544 args_out_of_range (start
, end
);
2546 if (BEGV
!= XFASTINT (start
) || ZV
!= XFASTINT (end
))
2547 current_buffer
->clip_changed
= 1;
2549 SET_BUF_BEGV (current_buffer
, XFASTINT (start
));
2550 SET_BUF_ZV (current_buffer
, XFASTINT (end
));
2551 if (PT
< XFASTINT (start
))
2552 SET_PT (XFASTINT (start
));
2553 if (PT
> XFASTINT (end
))
2554 SET_PT (XFASTINT (end
));
2555 /* Changing the buffer bounds invalidates any recorded current column. */
2556 invalidate_current_column ();
2561 save_restriction_save ()
2563 register Lisp_Object bottom
, top
;
2564 /* Note: I tried using markers here, but it does not win
2565 because insertion at the end of the saved region
2566 does not advance mh and is considered "outside" the saved region. */
2567 XSETFASTINT (bottom
, BEGV
- BEG
);
2568 XSETFASTINT (top
, Z
- ZV
);
2570 return Fcons (Fcurrent_buffer (), Fcons (bottom
, top
));
2574 save_restriction_restore (data
)
2577 register struct buffer
*buf
;
2578 register int newhead
, newtail
;
2579 register Lisp_Object tem
;
2582 buf
= XBUFFER (XCAR (data
));
2587 newhead
= XINT (tem
);
2589 newtail
= XINT (tem
);
2590 if (newhead
+ newtail
> BUF_Z (buf
) - BUF_BEG (buf
))
2596 obegv
= BUF_BEGV (buf
);
2599 SET_BUF_BEGV (buf
, BUF_BEG (buf
) + newhead
);
2600 SET_BUF_ZV (buf
, BUF_Z (buf
) - newtail
);
2602 if (obegv
!= BUF_BEGV (buf
) || ozv
!= BUF_ZV (buf
))
2603 current_buffer
->clip_changed
= 1;
2605 /* If point is outside the new visible range, move it inside. */
2606 SET_BUF_PT_BOTH (buf
,
2607 clip_to_bounds (BUF_BEGV (buf
), BUF_PT (buf
), BUF_ZV (buf
)),
2608 clip_to_bounds (BUF_BEGV_BYTE (buf
), BUF_PT_BYTE (buf
),
2609 BUF_ZV_BYTE (buf
)));
2614 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
2615 "Execute BODY, saving and restoring current buffer's restrictions.\n\
2616 The buffer's restrictions make parts of the beginning and end invisible.\n\
2617 \(They are set up with `narrow-to-region' and eliminated with `widen'.)\n\
2618 This special form, `save-restriction', saves the current buffer's restrictions\n\
2619 when it is entered, and restores them when it is exited.\n\
2620 So any `narrow-to-region' within BODY lasts only until the end of the form.\n\
2621 The old restrictions settings are restored\n\
2622 even in case of abnormal exit (throw or error).\n\
2624 The value returned is the value of the last form in BODY.\n\
2626 `save-restriction' can get confused if, within the BODY, you widen\n\
2627 and then make changes outside the area within the saved restrictions.\n\
2628 See Info node `(elisp)Narrowing' for details and an appropriate technique.\n\
2630 Note: if you are using both `save-excursion' and `save-restriction',\n\
2631 use `save-excursion' outermost:\n\
2632 (save-excursion (save-restriction ...))")
2636 register Lisp_Object val
;
2637 int count
= specpdl_ptr
- specpdl
;
2639 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
2640 val
= Fprogn (body
);
2641 return unbind_to (count
, val
);
2646 /* Buffer for the most recent text displayed by Fmessage. */
2647 static char *message_text
;
2649 /* Allocated length of that buffer. */
2650 static int message_length
;
2652 #endif /* not HAVE_MENUS */
2654 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
2655 "Print a one-line message at the bottom of the screen.\n\
2656 The first argument is a format control string, and the rest are data\n\
2657 to be formatted under control of the string. See `format' for details.\n\
2659 If the first argument is nil, clear any existing message; let the\n\
2660 minibuffer contents show.")
2672 register Lisp_Object val
;
2673 val
= Fformat (nargs
, args
);
2674 message3 (val
, STRING_BYTES (XSTRING (val
)), STRING_MULTIBYTE (val
));
2679 DEFUN ("message-box", Fmessage_box
, Smessage_box
, 1, MANY
, 0,
2680 "Display a message, in a dialog box if possible.\n\
2681 If a dialog box is not available, use the echo area.\n\
2682 The first argument is a format control string, and the rest are data\n\
2683 to be formatted under control of the string. See `format' for details.\n\
2685 If the first argument is nil, clear any existing message; let the\n\
2686 minibuffer contents show.")
2698 register Lisp_Object val
;
2699 val
= Fformat (nargs
, args
);
2702 Lisp_Object pane
, menu
, obj
;
2703 struct gcpro gcpro1
;
2704 pane
= Fcons (Fcons (build_string ("OK"), Qt
), Qnil
);
2706 menu
= Fcons (val
, pane
);
2707 obj
= Fx_popup_dialog (Qt
, menu
);
2711 #else /* not HAVE_MENUS */
2712 /* Copy the data so that it won't move when we GC. */
2715 message_text
= (char *)xmalloc (80);
2716 message_length
= 80;
2718 if (STRING_BYTES (XSTRING (val
)) > message_length
)
2720 message_length
= STRING_BYTES (XSTRING (val
));
2721 message_text
= (char *)xrealloc (message_text
, message_length
);
2723 bcopy (XSTRING (val
)->data
, message_text
, STRING_BYTES (XSTRING (val
)));
2724 message2 (message_text
, STRING_BYTES (XSTRING (val
)),
2725 STRING_MULTIBYTE (val
));
2727 #endif /* not HAVE_MENUS */
2731 extern Lisp_Object last_nonmenu_event
;
2734 DEFUN ("message-or-box", Fmessage_or_box
, Smessage_or_box
, 1, MANY
, 0,
2735 "Display a message in a dialog box or in the echo area.\n\
2736 If this command was invoked with the mouse, use a dialog box.\n\
2737 Otherwise, use the echo area.\n\
2738 The first argument is a format control string, and the rest are data\n\
2739 to be formatted under control of the string. See `format' for details.\n\
2741 If the first argument is nil, clear any existing message; let the\n\
2742 minibuffer contents show.")
2748 if (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2749 return Fmessage_box (nargs
, args
);
2751 return Fmessage (nargs
, args
);
2754 DEFUN ("current-message", Fcurrent_message
, Scurrent_message
, 0, 0, 0,
2755 "Return the string currently displayed in the echo area, or nil if none.")
2758 return current_message ();
2762 DEFUN ("propertize", Fpropertize
, Spropertize
, 3, MANY
, 0,
2763 "Return a copy of STRING with text properties added.\n\
2764 First argument is the string to copy.\n\
2765 Remaining arguments are sequences of PROPERTY VALUE pairs for text\n\
2766 properties to add to the result ")
2771 Lisp_Object properties
, string
;
2772 struct gcpro gcpro1
, gcpro2
;
2775 /* Number of args must be odd. */
2776 if ((nargs
& 1) == 0 || nargs
< 3)
2777 error ("Wrong number of arguments");
2779 properties
= string
= Qnil
;
2780 GCPRO2 (properties
, string
);
2782 /* First argument must be a string. */
2783 CHECK_STRING (args
[0], 0);
2784 string
= Fcopy_sequence (args
[0]);
2786 for (i
= 1; i
< nargs
; i
+= 2)
2788 CHECK_SYMBOL (args
[i
], i
);
2789 properties
= Fcons (args
[i
], Fcons (args
[i
+ 1], properties
));
2792 Fadd_text_properties (make_number (0),
2793 make_number (XSTRING (string
)->size
),
2794 properties
, string
);
2795 RETURN_UNGCPRO (string
);
2799 /* Number of bytes that STRING will occupy when put into the result.
2800 MULTIBYTE is nonzero if the result should be multibyte. */
2802 #define CONVERTED_BYTE_SIZE(MULTIBYTE, STRING) \
2803 (((MULTIBYTE) && ! STRING_MULTIBYTE (STRING)) \
2804 ? count_size_as_multibyte (XSTRING (STRING)->data, \
2805 STRING_BYTES (XSTRING (STRING))) \
2806 : STRING_BYTES (XSTRING (STRING)))
2808 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
2809 "Format a string out of a control-string and arguments.\n\
2810 The first argument is a control string.\n\
2811 The other arguments are substituted into it to make the result, a string.\n\
2812 It may contain %-sequences meaning to substitute the next argument.\n\
2813 %s means print a string argument. Actually, prints any object, with `princ'.\n\
2814 %d means print as number in decimal (%o octal, %x hex).\n\
2815 %e means print a number in exponential notation.\n\
2816 %f means print a number in decimal-point notation.\n\
2817 %g means print a number in exponential notation\n\
2818 or decimal-point notation, whichever uses fewer characters.\n\
2819 %c means print a number as a single character.\n\
2820 %S means print any object as an s-expression (using `prin1').\n\
2821 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.\n\
2822 Use %% to put a single % into the output.")
2825 register Lisp_Object
*args
;
2827 register int n
; /* The number of the next arg to substitute */
2828 register int total
; /* An estimate of the final length */
2830 register unsigned char *format
, *end
;
2832 /* Nonzero if the output should be a multibyte string,
2833 which is true if any of the inputs is one. */
2835 /* When we make a multibyte string, we must pay attention to the
2836 byte combining problem, i.e., a byte may be combined with a
2837 multibyte charcter of the previous string. This flag tells if we
2838 must consider such a situation or not. */
2839 int maybe_combine_byte
;
2840 unsigned char *this_format
;
2848 extern char *index ();
2850 /* It should not be necessary to GCPRO ARGS, because
2851 the caller in the interpreter should take care of that. */
2853 /* Try to determine whether the result should be multibyte.
2854 This is not always right; sometimes the result needs to be multibyte
2855 because of an object that we will pass through prin1,
2856 and in that case, we won't know it here. */
2857 for (n
= 0; n
< nargs
; n
++)
2858 if (STRINGP (args
[n
]) && STRING_MULTIBYTE (args
[n
]))
2861 CHECK_STRING (args
[0], 0);
2863 /* If we start out planning a unibyte result,
2864 and later find it has to be multibyte, we jump back to retry. */
2867 format
= XSTRING (args
[0])->data
;
2868 end
= format
+ STRING_BYTES (XSTRING (args
[0]));
2871 /* Make room in result for all the non-%-codes in the control string. */
2872 total
= 5 + CONVERTED_BYTE_SIZE (multibyte
, args
[0]);
2874 /* Add to TOTAL enough space to hold the converted arguments. */
2877 while (format
!= end
)
2878 if (*format
++ == '%')
2880 int minlen
, thissize
= 0;
2881 unsigned char *this_format_start
= format
- 1;
2883 /* Process a numeric arg and skip it. */
2884 minlen
= atoi (format
);
2888 while ((*format
>= '0' && *format
<= '9')
2889 || *format
== '-' || *format
== ' ' || *format
== '.')
2892 if (format
- this_format_start
+ 1 > longest_format
)
2893 longest_format
= format
- this_format_start
+ 1;
2896 error ("Format string ends in middle of format specifier");
2899 else if (++n
>= nargs
)
2900 error ("Not enough arguments for format string");
2901 else if (*format
== 'S')
2903 /* For `S', prin1 the argument and then treat like a string. */
2904 register Lisp_Object tem
;
2905 tem
= Fprin1_to_string (args
[n
], Qnil
);
2906 if (STRING_MULTIBYTE (tem
) && ! multibyte
)
2914 else if (SYMBOLP (args
[n
]))
2916 XSETSTRING (args
[n
], XSYMBOL (args
[n
])->name
);
2917 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
2924 else if (STRINGP (args
[n
]))
2927 if (*format
!= 's' && *format
!= 'S')
2928 error ("Format specifier doesn't match argument type");
2929 thissize
= CONVERTED_BYTE_SIZE (multibyte
, args
[n
]);
2931 /* Would get MPV otherwise, since Lisp_Int's `point' to low memory. */
2932 else if (INTEGERP (args
[n
]) && *format
!= 's')
2934 #ifdef LISP_FLOAT_TYPE
2935 /* The following loop assumes the Lisp type indicates
2936 the proper way to pass the argument.
2937 So make sure we have a flonum if the argument should
2939 if (*format
== 'e' || *format
== 'f' || *format
== 'g')
2940 args
[n
] = Ffloat (args
[n
]);
2943 if (*format
!= 'd' && *format
!= 'o' && *format
!= 'x'
2944 && *format
!= 'i' && *format
!= 'X' && *format
!= 'c')
2945 error ("Invalid format operation %%%c", *format
);
2949 && (! SINGLE_BYTE_CHAR_P (XINT (args
[n
]))
2950 || XINT (args
[n
]) == 0))
2957 args
[n
] = Fchar_to_string (args
[n
]);
2958 thissize
= STRING_BYTES (XSTRING (args
[n
]));
2961 #ifdef LISP_FLOAT_TYPE
2962 else if (FLOATP (args
[n
]) && *format
!= 's')
2964 if (! (*format
== 'e' || *format
== 'f' || *format
== 'g'))
2965 args
[n
] = Ftruncate (args
[n
], Qnil
);
2971 /* Anything but a string, convert to a string using princ. */
2972 register Lisp_Object tem
;
2973 tem
= Fprin1_to_string (args
[n
], Qt
);
2974 if (STRING_MULTIBYTE (tem
) & ! multibyte
)
2983 if (thissize
< minlen
)
2986 total
+= thissize
+ 4;
2989 /* Now we can no longer jump to retry.
2990 TOTAL and LONGEST_FORMAT are known for certain. */
2992 this_format
= (unsigned char *) alloca (longest_format
+ 1);
2994 /* Allocate the space for the result.
2995 Note that TOTAL is an overestimate. */
2997 buf
= (char *) alloca (total
+ 1);
2999 buf
= (char *) xmalloc (total
+ 1);
3005 /* Scan the format and store result in BUF. */
3006 format
= XSTRING (args
[0])->data
;
3007 maybe_combine_byte
= 0;
3008 while (format
!= end
)
3014 unsigned char *this_format_start
= format
;
3018 /* Process a numeric arg and skip it. */
3019 minlen
= atoi (format
);
3021 minlen
= - minlen
, negative
= 1;
3023 while ((*format
>= '0' && *format
<= '9')
3024 || *format
== '-' || *format
== ' ' || *format
== '.')
3027 if (*format
++ == '%')
3036 if (STRINGP (args
[n
]))
3038 int padding
, nbytes
;
3039 int width
= strwidth (XSTRING (args
[n
])->data
,
3040 STRING_BYTES (XSTRING (args
[n
])));
3043 /* If spec requires it, pad on right with spaces. */
3044 padding
= minlen
- width
;
3046 while (padding
-- > 0)
3054 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3055 && STRING_MULTIBYTE (args
[n
])
3056 && !CHAR_HEAD_P (XSTRING (args
[n
])->data
[0]))
3057 maybe_combine_byte
= 1;
3058 nbytes
= copy_text (XSTRING (args
[n
])->data
, p
,
3059 STRING_BYTES (XSTRING (args
[n
])),
3060 STRING_MULTIBYTE (args
[n
]), multibyte
);
3062 nchars
+= XSTRING (args
[n
])->size
;
3065 while (padding
-- > 0)
3071 /* If this argument has text properties, record where
3072 in the result string it appears. */
3073 if (XSTRING (args
[n
])->intervals
)
3077 int nbytes
= nargs
* sizeof *info
;
3078 info
= (struct info
*) alloca (nbytes
);
3079 bzero (info
, nbytes
);
3082 info
[n
].start
= start
;
3083 info
[n
].end
= nchars
;
3086 else if (INTEGERP (args
[n
]) || FLOATP (args
[n
]))
3090 bcopy (this_format_start
, this_format
,
3091 format
- this_format_start
);
3092 this_format
[format
- this_format_start
] = 0;
3094 if (INTEGERP (args
[n
]))
3095 sprintf (p
, this_format
, XINT (args
[n
]));
3097 sprintf (p
, this_format
, XFLOAT_DATA (args
[n
]));
3101 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3102 && !CHAR_HEAD_P (*((unsigned char *) p
)))
3103 maybe_combine_byte
= 1;
3104 this_nchars
= strlen (p
);
3106 nchars
+= this_nchars
;
3109 else if (STRING_MULTIBYTE (args
[0]))
3111 /* Copy a whole multibyte character. */
3114 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3115 && !CHAR_HEAD_P (*format
))
3116 maybe_combine_byte
= 1;
3118 while (! CHAR_HEAD_P (*format
)) *p
++ = *format
++;
3123 /* Convert a single-byte character to multibyte. */
3124 int len
= copy_text (format
, p
, 1, 0, 1);
3131 *p
++ = *format
++, nchars
++;
3134 if (maybe_combine_byte
)
3135 nchars
= multibyte_chars_in_text (buf
, p
- buf
);
3136 val
= make_specified_string (buf
, nchars
, p
- buf
, multibyte
);
3138 /* If we allocated BUF with malloc, free it too. */
3142 /* If the format string has text properties, or any of the string
3143 arguments has text properties, set up text properties of the
3146 if (XSTRING (args
[0])->intervals
|| info
)
3148 Lisp_Object len
, new_len
, props
;
3149 struct gcpro gcpro1
;
3151 /* Add text properties from the format string. */
3152 len
= make_number (XSTRING (args
[0])->size
);
3153 props
= text_property_list (args
[0], make_number (0), len
, Qnil
);
3158 new_len
= make_number (XSTRING (val
)->size
);
3159 extend_property_ranges (props
, len
, new_len
);
3160 add_text_properties_from_list (val
, props
, make_number (0));
3163 /* Add text properties from arguments. */
3165 for (n
= 1; n
< nargs
; ++n
)
3168 len
= make_number (XSTRING (args
[n
])->size
);
3169 new_len
= make_number (info
[n
].end
- info
[n
].start
);
3170 props
= text_property_list (args
[n
], make_number (0), len
, Qnil
);
3171 extend_property_ranges (props
, len
, new_len
);
3172 add_text_properties_from_list (val
, props
,
3173 make_number (info
[n
].start
));
3186 format1 (string1
, arg0
, arg1
, arg2
, arg3
, arg4
)
3187 EMACS_INT arg0
, arg1
, arg2
, arg3
, arg4
;
3201 doprnt (buf
, sizeof buf
, string1
, (char *)0, 5, (char **) args
);
3203 doprnt (buf
, sizeof buf
, string1
, (char *)0, 5, &string1
+ 1);
3205 return build_string (buf
);
3208 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
3209 "Return t if two characters match, optionally ignoring case.\n\
3210 Both arguments must be characters (i.e. integers).\n\
3211 Case is ignored if `case-fold-search' is non-nil in the current buffer.")
3213 register Lisp_Object c1
, c2
;
3216 CHECK_NUMBER (c1
, 0);
3217 CHECK_NUMBER (c2
, 1);
3219 if (XINT (c1
) == XINT (c2
))
3221 if (NILP (current_buffer
->case_fold_search
))
3224 /* Do these in separate statements,
3225 then compare the variables.
3226 because of the way DOWNCASE uses temp variables. */
3227 i1
= DOWNCASE (XFASTINT (c1
));
3228 i2
= DOWNCASE (XFASTINT (c2
));
3229 return (i1
== i2
? Qt
: Qnil
);
3232 /* Transpose the markers in two regions of the current buffer, and
3233 adjust the ones between them if necessary (i.e.: if the regions
3236 START1, END1 are the character positions of the first region.
3237 START1_BYTE, END1_BYTE are the byte positions.
3238 START2, END2 are the character positions of the second region.
3239 START2_BYTE, END2_BYTE are the byte positions.
3241 Traverses the entire marker list of the buffer to do so, adding an
3242 appropriate amount to some, subtracting from some, and leaving the
3243 rest untouched. Most of this is copied from adjust_markers in insdel.c.
3245 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
3248 transpose_markers (start1
, end1
, start2
, end2
,
3249 start1_byte
, end1_byte
, start2_byte
, end2_byte
)
3250 register int start1
, end1
, start2
, end2
;
3251 register int start1_byte
, end1_byte
, start2_byte
, end2_byte
;
3253 register int amt1
, amt1_byte
, amt2
, amt2_byte
, diff
, diff_byte
, mpos
;
3254 register Lisp_Object marker
;
3256 /* Update point as if it were a marker. */
3260 TEMP_SET_PT_BOTH (PT
+ (end2
- end1
),
3261 PT_BYTE
+ (end2_byte
- end1_byte
));
3262 else if (PT
< start2
)
3263 TEMP_SET_PT_BOTH (PT
+ (end2
- start2
) - (end1
- start1
),
3264 (PT_BYTE
+ (end2_byte
- start2_byte
)
3265 - (end1_byte
- start1_byte
)));
3267 TEMP_SET_PT_BOTH (PT
- (start2
- start1
),
3268 PT_BYTE
- (start2_byte
- start1_byte
));
3270 /* We used to adjust the endpoints here to account for the gap, but that
3271 isn't good enough. Even if we assume the caller has tried to move the
3272 gap out of our way, it might still be at start1 exactly, for example;
3273 and that places it `inside' the interval, for our purposes. The amount
3274 of adjustment is nontrivial if there's a `denormalized' marker whose
3275 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
3276 the dirty work to Fmarker_position, below. */
3278 /* The difference between the region's lengths */
3279 diff
= (end2
- start2
) - (end1
- start1
);
3280 diff_byte
= (end2_byte
- start2_byte
) - (end1_byte
- start1_byte
);
3282 /* For shifting each marker in a region by the length of the other
3283 region plus the distance between the regions. */
3284 amt1
= (end2
- start2
) + (start2
- end1
);
3285 amt2
= (end1
- start1
) + (start2
- end1
);
3286 amt1_byte
= (end2_byte
- start2_byte
) + (start2_byte
- end1_byte
);
3287 amt2_byte
= (end1_byte
- start1_byte
) + (start2_byte
- end1_byte
);
3289 for (marker
= BUF_MARKERS (current_buffer
); !NILP (marker
);
3290 marker
= XMARKER (marker
)->chain
)
3292 mpos
= marker_byte_position (marker
);
3293 if (mpos
>= start1_byte
&& mpos
< end2_byte
)
3295 if (mpos
< end1_byte
)
3297 else if (mpos
< start2_byte
)
3301 XMARKER (marker
)->bytepos
= mpos
;
3303 mpos
= XMARKER (marker
)->charpos
;
3304 if (mpos
>= start1
&& mpos
< end2
)
3308 else if (mpos
< start2
)
3313 XMARKER (marker
)->charpos
= mpos
;
3317 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
3318 "Transpose region START1 to END1 with START2 to END2.\n\
3319 The regions may not be overlapping, because the size of the buffer is\n\
3320 never changed in a transposition.\n\
3322 Optional fifth arg LEAVE_MARKERS, if non-nil, means don't update\n\
3323 any markers that happen to be located in the regions.\n\
3325 Transposing beyond buffer boundaries is an error.")
3326 (startr1
, endr1
, startr2
, endr2
, leave_markers
)
3327 Lisp_Object startr1
, endr1
, startr2
, endr2
, leave_markers
;
3329 register int start1
, end1
, start2
, end2
;
3330 int start1_byte
, start2_byte
, len1_byte
, len2_byte
;
3331 int gap
, len1
, len_mid
, len2
;
3332 unsigned char *start1_addr
, *start2_addr
, *temp
;
3333 int combined_before_bytes_1
, combined_after_bytes_1
;
3334 int combined_before_bytes_2
, combined_after_bytes_2
;
3335 struct gcpro gcpro1
, gcpro2
;
3337 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
;
3338 cur_intv
= BUF_INTERVALS (current_buffer
);
3340 validate_region (&startr1
, &endr1
);
3341 validate_region (&startr2
, &endr2
);
3343 start1
= XFASTINT (startr1
);
3344 end1
= XFASTINT (endr1
);
3345 start2
= XFASTINT (startr2
);
3346 end2
= XFASTINT (endr2
);
3349 /* Swap the regions if they're reversed. */
3352 register int glumph
= start1
;
3360 len1
= end1
- start1
;
3361 len2
= end2
- start2
;
3364 error ("Transposed regions overlap");
3365 else if (start1
== end1
|| start2
== end2
)
3366 error ("Transposed region has length 0");
3368 /* The possibilities are:
3369 1. Adjacent (contiguous) regions, or separate but equal regions
3370 (no, really equal, in this case!), or
3371 2. Separate regions of unequal size.
3373 The worst case is usually No. 2. It means that (aside from
3374 potential need for getting the gap out of the way), there also
3375 needs to be a shifting of the text between the two regions. So
3376 if they are spread far apart, we are that much slower... sigh. */
3378 /* It must be pointed out that the really studly thing to do would
3379 be not to move the gap at all, but to leave it in place and work
3380 around it if necessary. This would be extremely efficient,
3381 especially considering that people are likely to do
3382 transpositions near where they are working interactively, which
3383 is exactly where the gap would be found. However, such code
3384 would be much harder to write and to read. So, if you are
3385 reading this comment and are feeling squirrely, by all means have
3386 a go! I just didn't feel like doing it, so I will simply move
3387 the gap the minimum distance to get it out of the way, and then
3388 deal with an unbroken array. */
3390 /* Make sure the gap won't interfere, by moving it out of the text
3391 we will operate on. */
3392 if (start1
< gap
&& gap
< end2
)
3394 if (gap
- start1
< end2
- gap
)
3400 start1_byte
= CHAR_TO_BYTE (start1
);
3401 start2_byte
= CHAR_TO_BYTE (start2
);
3402 len1_byte
= CHAR_TO_BYTE (end1
) - start1_byte
;
3403 len2_byte
= CHAR_TO_BYTE (end2
) - start2_byte
;
3407 combined_before_bytes_2
3408 = count_combining_before (BYTE_POS_ADDR (start2_byte
),
3409 len2_byte
, start1
, start1_byte
);
3410 combined_before_bytes_1
3411 = count_combining_before (BYTE_POS_ADDR (start1_byte
),
3412 len1_byte
, end2
, start2_byte
+ len2_byte
);
3413 combined_after_bytes_1
3414 = count_combining_after (BYTE_POS_ADDR (start1_byte
),
3415 len1_byte
, end2
, start2_byte
+ len2_byte
);
3416 combined_after_bytes_2
= 0;
3420 combined_before_bytes_2
3421 = count_combining_before (BYTE_POS_ADDR (start2_byte
),
3422 len2_byte
, start1
, start1_byte
);
3423 combined_before_bytes_1
3424 = count_combining_before (BYTE_POS_ADDR (start1_byte
),
3425 len1_byte
, start2
, start2_byte
);
3426 combined_after_bytes_2
3427 = count_combining_after (BYTE_POS_ADDR (start2_byte
),
3428 len2_byte
, end1
, start1_byte
+ len1_byte
);
3429 combined_after_bytes_1
3430 = count_combining_after (BYTE_POS_ADDR (start1_byte
),
3431 len1_byte
, end2
, start2_byte
+ len2_byte
);
3434 /* If any combining is going to happen, do this the stupid way,
3435 because replace handles combining properly. */
3436 if (combined_before_bytes_1
|| combined_before_bytes_2
3437 || combined_after_bytes_1
|| combined_after_bytes_2
)
3439 Lisp_Object text1
, text2
;
3441 text1
= text2
= Qnil
;
3442 GCPRO2 (text1
, text2
);
3444 text1
= make_buffer_string_both (start1
, start1_byte
,
3445 end1
, start1_byte
+ len1_byte
, 1);
3446 text2
= make_buffer_string_both (start2
, start2_byte
,
3447 end2
, start2_byte
+ len2_byte
, 1);
3449 transpose_markers (start1
, end1
, start2
, end2
,
3450 start1_byte
, start1_byte
+ len1_byte
,
3451 start2_byte
, start2_byte
+ len2_byte
);
3453 replace_range (start2
, end2
, text1
, 1, 0, 0);
3454 replace_range (start1
, end1
, text2
, 1, 0, 0);
3460 /* Hmmm... how about checking to see if the gap is large
3461 enough to use as the temporary storage? That would avoid an
3462 allocation... interesting. Later, don't fool with it now. */
3464 /* Working without memmove, for portability (sigh), so must be
3465 careful of overlapping subsections of the array... */
3467 if (end1
== start2
) /* adjacent regions */
3469 modify_region (current_buffer
, start1
, end2
);
3470 record_change (start1
, len1
+ len2
);
3472 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
3473 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
3474 Fset_text_properties (make_number (start1
), make_number (end2
),
3477 /* First region smaller than second. */
3478 if (len1_byte
< len2_byte
)
3480 /* We use alloca only if it is small,
3481 because we want to avoid stack overflow. */
3482 if (len2_byte
> 20000)
3483 temp
= (unsigned char *) xmalloc (len2_byte
);
3485 temp
= (unsigned char *) alloca (len2_byte
);
3487 /* Don't precompute these addresses. We have to compute them
3488 at the last minute, because the relocating allocator might
3489 have moved the buffer around during the xmalloc. */
3490 start1_addr
= BYTE_POS_ADDR (start1_byte
);
3491 start2_addr
= BYTE_POS_ADDR (start2_byte
);
3493 bcopy (start2_addr
, temp
, len2_byte
);
3494 bcopy (start1_addr
, start1_addr
+ len2_byte
, len1_byte
);
3495 bcopy (temp
, start1_addr
, len2_byte
);
3496 if (len2_byte
> 20000)
3500 /* First region not smaller than second. */
3502 if (len1_byte
> 20000)
3503 temp
= (unsigned char *) xmalloc (len1_byte
);
3505 temp
= (unsigned char *) alloca (len1_byte
);
3506 start1_addr
= BYTE_POS_ADDR (start1_byte
);
3507 start2_addr
= BYTE_POS_ADDR (start2_byte
);
3508 bcopy (start1_addr
, temp
, len1_byte
);
3509 bcopy (start2_addr
, start1_addr
, len2_byte
);
3510 bcopy (temp
, start1_addr
+ len2_byte
, len1_byte
);
3511 if (len1_byte
> 20000)
3514 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
3515 len1
, current_buffer
, 0);
3516 graft_intervals_into_buffer (tmp_interval2
, start1
,
3517 len2
, current_buffer
, 0);
3519 /* Non-adjacent regions, because end1 != start2, bleagh... */
3522 len_mid
= start2_byte
- (start1_byte
+ len1_byte
);
3524 if (len1_byte
== len2_byte
)
3525 /* Regions are same size, though, how nice. */
3527 modify_region (current_buffer
, start1
, end1
);
3528 modify_region (current_buffer
, start2
, end2
);
3529 record_change (start1
, len1
);
3530 record_change (start2
, len2
);
3531 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
3532 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
3533 Fset_text_properties (make_number (start1
), make_number (end1
),
3535 Fset_text_properties (make_number (start2
), make_number (end2
),
3538 if (len1_byte
> 20000)
3539 temp
= (unsigned char *) xmalloc (len1_byte
);
3541 temp
= (unsigned char *) alloca (len1_byte
);
3542 start1_addr
= BYTE_POS_ADDR (start1_byte
);
3543 start2_addr
= BYTE_POS_ADDR (start2_byte
);
3544 bcopy (start1_addr
, temp
, len1_byte
);
3545 bcopy (start2_addr
, start1_addr
, len2_byte
);
3546 bcopy (temp
, start2_addr
, len1_byte
);
3547 if (len1_byte
> 20000)
3549 graft_intervals_into_buffer (tmp_interval1
, start2
,
3550 len1
, current_buffer
, 0);
3551 graft_intervals_into_buffer (tmp_interval2
, start1
,
3552 len2
, current_buffer
, 0);
3555 else if (len1_byte
< len2_byte
) /* Second region larger than first */
3556 /* Non-adjacent & unequal size, area between must also be shifted. */
3558 modify_region (current_buffer
, start1
, end2
);
3559 record_change (start1
, (end2
- start1
));
3560 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
3561 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
3562 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
3563 Fset_text_properties (make_number (start1
), make_number (end2
),
3566 /* holds region 2 */
3567 if (len2_byte
> 20000)
3568 temp
= (unsigned char *) xmalloc (len2_byte
);
3570 temp
= (unsigned char *) alloca (len2_byte
);
3571 start1_addr
= BYTE_POS_ADDR (start1_byte
);
3572 start2_addr
= BYTE_POS_ADDR (start2_byte
);
3573 bcopy (start2_addr
, temp
, len2_byte
);
3574 bcopy (start1_addr
, start1_addr
+ len_mid
+ len2_byte
, len1_byte
);
3575 safe_bcopy (start1_addr
+ len1_byte
, start1_addr
+ len2_byte
, len_mid
);
3576 bcopy (temp
, start1_addr
, len2_byte
);
3577 if (len2_byte
> 20000)
3579 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
3580 len1
, current_buffer
, 0);
3581 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
3582 len_mid
, current_buffer
, 0);
3583 graft_intervals_into_buffer (tmp_interval2
, start1
,
3584 len2
, current_buffer
, 0);
3587 /* Second region smaller than first. */
3589 record_change (start1
, (end2
- start1
));
3590 modify_region (current_buffer
, start1
, end2
);
3592 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
3593 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
3594 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
3595 Fset_text_properties (make_number (start1
), make_number (end2
),
3598 /* holds region 1 */
3599 if (len1_byte
> 20000)
3600 temp
= (unsigned char *) xmalloc (len1_byte
);
3602 temp
= (unsigned char *) alloca (len1_byte
);
3603 start1_addr
= BYTE_POS_ADDR (start1_byte
);
3604 start2_addr
= BYTE_POS_ADDR (start2_byte
);
3605 bcopy (start1_addr
, temp
, len1_byte
);
3606 bcopy (start2_addr
, start1_addr
, len2_byte
);
3607 bcopy (start1_addr
+ len1_byte
, start1_addr
+ len2_byte
, len_mid
);
3608 bcopy (temp
, start1_addr
+ len2_byte
+ len_mid
, len1_byte
);
3609 if (len1_byte
> 20000)
3611 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
3612 len1
, current_buffer
, 0);
3613 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
3614 len_mid
, current_buffer
, 0);
3615 graft_intervals_into_buffer (tmp_interval2
, start1
,
3616 len2
, current_buffer
, 0);
3620 /* When doing multiple transpositions, it might be nice
3621 to optimize this. Perhaps the markers in any one buffer
3622 should be organized in some sorted data tree. */
3623 if (NILP (leave_markers
))
3625 transpose_markers (start1
, end1
, start2
, end2
,
3626 start1_byte
, start1_byte
+ len1_byte
,
3627 start2_byte
, start2_byte
+ len2_byte
);
3628 fix_overlays_in_range (start1
, end2
);
3640 Qbuffer_access_fontify_functions
3641 = intern ("buffer-access-fontify-functions");
3642 staticpro (&Qbuffer_access_fontify_functions
);
3644 DEFVAR_LISP ("buffer-access-fontify-functions",
3645 &Vbuffer_access_fontify_functions
,
3646 "List of functions called by `buffer-substring' to fontify if necessary.\n\
3647 Each function is called with two arguments which specify the range\n\
3648 of the buffer being accessed.");
3649 Vbuffer_access_fontify_functions
= Qnil
;
3653 extern Lisp_Object Vprin1_to_string_buffer
;
3654 obuf
= Fcurrent_buffer ();
3655 /* Do this here, because init_buffer_once is too early--it won't work. */
3656 Fset_buffer (Vprin1_to_string_buffer
);
3657 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
3658 Fset (Fmake_local_variable (intern ("buffer-access-fontify-functions")),
3663 DEFVAR_LISP ("buffer-access-fontified-property",
3664 &Vbuffer_access_fontified_property
,
3665 "Property which (if non-nil) indicates text has been fontified.\n\
3666 `buffer-substring' need not call the `buffer-access-fontify-functions'\n\
3667 functions if all the text being accessed has this property.");
3668 Vbuffer_access_fontified_property
= Qnil
;
3670 DEFVAR_LISP ("system-name", &Vsystem_name
,
3671 "The name of the machine Emacs is running on.");
3673 DEFVAR_LISP ("user-full-name", &Vuser_full_name
,
3674 "The full name of the user logged in.");
3676 DEFVAR_LISP ("user-login-name", &Vuser_login_name
,
3677 "The user's name, taken from environment variables if possible.");
3679 DEFVAR_LISP ("user-real-login-name", &Vuser_real_login_name
,
3680 "The user's name, based upon the real uid only.");
3682 defsubr (&Spropertize
);
3683 defsubr (&Schar_equal
);
3684 defsubr (&Sgoto_char
);
3685 defsubr (&Sstring_to_char
);
3686 defsubr (&Schar_to_string
);
3687 defsubr (&Sbuffer_substring
);
3688 defsubr (&Sbuffer_substring_no_properties
);
3689 defsubr (&Sbuffer_string
);
3691 defsubr (&Spoint_marker
);
3692 defsubr (&Smark_marker
);
3694 defsubr (&Sregion_beginning
);
3695 defsubr (&Sregion_end
);
3697 staticpro (&Qfield
);
3698 Qfield
= intern ("field");
3699 defsubr (&Sfield_beginning
);
3700 defsubr (&Sfield_end
);
3701 defsubr (&Sfield_string
);
3702 defsubr (&Sfield_string_no_properties
);
3703 defsubr (&Sdelete_field
);
3704 defsubr (&Sconstrain_to_field
);
3706 defsubr (&Sline_beginning_position
);
3707 defsubr (&Sline_end_position
);
3709 /* defsubr (&Smark); */
3710 /* defsubr (&Sset_mark); */
3711 defsubr (&Ssave_excursion
);
3712 defsubr (&Ssave_current_buffer
);
3714 defsubr (&Sbufsize
);
3715 defsubr (&Spoint_max
);
3716 defsubr (&Spoint_min
);
3717 defsubr (&Spoint_min_marker
);
3718 defsubr (&Spoint_max_marker
);
3719 defsubr (&Sgap_position
);
3720 defsubr (&Sgap_size
);
3721 defsubr (&Sposition_bytes
);
3722 defsubr (&Sbyte_to_position
);
3728 defsubr (&Sfollowing_char
);
3729 defsubr (&Sprevious_char
);
3730 defsubr (&Schar_after
);
3731 defsubr (&Schar_before
);
3733 defsubr (&Sinsert_before_markers
);
3734 defsubr (&Sinsert_and_inherit
);
3735 defsubr (&Sinsert_and_inherit_before_markers
);
3736 defsubr (&Sinsert_char
);
3738 defsubr (&Suser_login_name
);
3739 defsubr (&Suser_real_login_name
);
3740 defsubr (&Suser_uid
);
3741 defsubr (&Suser_real_uid
);
3742 defsubr (&Suser_full_name
);
3743 defsubr (&Semacs_pid
);
3744 defsubr (&Scurrent_time
);
3745 defsubr (&Sformat_time_string
);
3746 defsubr (&Sdecode_time
);
3747 defsubr (&Sencode_time
);
3748 defsubr (&Scurrent_time_string
);
3749 defsubr (&Scurrent_time_zone
);
3750 defsubr (&Sset_time_zone_rule
);
3751 defsubr (&Ssystem_name
);
3752 defsubr (&Smessage
);
3753 defsubr (&Smessage_box
);
3754 defsubr (&Smessage_or_box
);
3755 defsubr (&Scurrent_message
);
3758 defsubr (&Sinsert_buffer_substring
);
3759 defsubr (&Scompare_buffer_substrings
);
3760 defsubr (&Ssubst_char_in_region
);
3761 defsubr (&Stranslate_region
);
3762 defsubr (&Sdelete_region
);
3764 defsubr (&Snarrow_to_region
);
3765 defsubr (&Ssave_restriction
);
3766 defsubr (&Stranspose_regions
);