Drop support for deprecated (since 23.1) forms of diary-display-function
[emacs.git] / src / editfns.c
blobe7c960dfffe22b75ae141c7c48acd3d44d51e392
1 /* Lisp functions pertaining to editing.
3 Copyright (C) 1985-1987, 1989, 1993-2014 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software: you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation, either version 3 of the License, or
10 (at your option) any later version.
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
21 #include <config.h>
22 #include <sys/types.h>
23 #include <stdio.h>
25 #ifdef HAVE_PWD_H
26 #include <pwd.h>
27 #include <grp.h>
28 #endif
30 #include <unistd.h>
32 #ifdef HAVE_SYS_UTSNAME_H
33 #include <sys/utsname.h>
34 #endif
36 #include "lisp.h"
38 /* systime.h includes <sys/time.h> which, on some systems, is required
39 for <sys/resource.h>; thus systime.h must be included before
40 <sys/resource.h> */
41 #include "systime.h"
43 #if defined HAVE_SYS_RESOURCE_H
44 #include <sys/resource.h>
45 #endif
47 #include <float.h>
48 #include <limits.h>
49 #include <intprops.h>
50 #include <strftime.h>
51 #include <verify.h>
53 #include "intervals.h"
54 #include "character.h"
55 #include "buffer.h"
56 #include "coding.h"
57 #include "frame.h"
58 #include "window.h"
59 #include "blockinput.h"
61 #define TM_YEAR_BASE 1900
63 #ifdef WINDOWSNT
64 extern Lisp_Object w32_get_internal_run_time (void);
65 #endif
67 static Lisp_Object format_time_string (char const *, ptrdiff_t, struct timespec,
68 bool, struct tm *);
69 static int tm_diff (struct tm *, struct tm *);
70 static void update_buffer_properties (ptrdiff_t, ptrdiff_t);
72 static Lisp_Object Qbuffer_access_fontify_functions;
74 /* Symbol for the text property used to mark fields. */
76 Lisp_Object Qfield;
78 /* A special value for Qfield properties. */
80 static Lisp_Object Qboundary;
82 /* The startup value of the TZ environment variable so it can be
83 restored if the user calls set-time-zone-rule with a nil
84 argument. If null, the TZ environment variable was unset. */
85 static char const *initial_tz;
87 /* True if the static variable tzvalbuf (defined in
88 set_time_zone_rule) is part of 'environ'. */
89 static bool tzvalbuf_in_environ;
92 void
93 init_editfns (void)
95 const char *user_name;
96 register char *p;
97 struct passwd *pw; /* password entry for the current user */
98 Lisp_Object tem;
100 /* Set up system_name even when dumping. */
101 init_system_name ();
103 #ifndef CANNOT_DUMP
104 /* Don't bother with this on initial start when just dumping out */
105 if (!initialized)
106 return;
107 #endif /* not CANNOT_DUMP */
109 initial_tz = getenv ("TZ");
110 tzvalbuf_in_environ = 0;
112 pw = getpwuid (getuid ());
113 #ifdef MSDOS
114 /* We let the real user name default to "root" because that's quite
115 accurate on MS-DOS and because it lets Emacs find the init file.
116 (The DVX libraries override the Djgpp libraries here.) */
117 Vuser_real_login_name = build_string (pw ? pw->pw_name : "root");
118 #else
119 Vuser_real_login_name = build_string (pw ? pw->pw_name : "unknown");
120 #endif
122 /* Get the effective user name, by consulting environment variables,
123 or the effective uid if those are unset. */
124 user_name = getenv ("LOGNAME");
125 if (!user_name)
126 #ifdef WINDOWSNT
127 user_name = getenv ("USERNAME"); /* it's USERNAME on NT */
128 #else /* WINDOWSNT */
129 user_name = getenv ("USER");
130 #endif /* WINDOWSNT */
131 if (!user_name)
133 pw = getpwuid (geteuid ());
134 user_name = pw ? pw->pw_name : "unknown";
136 Vuser_login_name = build_string (user_name);
138 /* If the user name claimed in the environment vars differs from
139 the real uid, use the claimed name to find the full name. */
140 tem = Fstring_equal (Vuser_login_name, Vuser_real_login_name);
141 if (! NILP (tem))
142 tem = Vuser_login_name;
143 else
145 uid_t euid = geteuid ();
146 tem = make_fixnum_or_float (euid);
148 Vuser_full_name = Fuser_full_name (tem);
150 p = getenv ("NAME");
151 if (p)
152 Vuser_full_name = build_string (p);
153 else if (NILP (Vuser_full_name))
154 Vuser_full_name = build_string ("unknown");
156 #ifdef HAVE_SYS_UTSNAME_H
158 struct utsname uts;
159 uname (&uts);
160 Voperating_system_release = build_string (uts.release);
162 #else
163 Voperating_system_release = Qnil;
164 #endif
167 DEFUN ("char-to-string", Fchar_to_string, Schar_to_string, 1, 1, 0,
168 doc: /* Convert arg CHAR to a string containing that character.
169 usage: (char-to-string CHAR) */)
170 (Lisp_Object character)
172 int c, len;
173 unsigned char str[MAX_MULTIBYTE_LENGTH];
175 CHECK_CHARACTER (character);
176 c = XFASTINT (character);
178 len = CHAR_STRING (c, str);
179 return make_string_from_bytes ((char *) str, 1, len);
182 DEFUN ("byte-to-string", Fbyte_to_string, Sbyte_to_string, 1, 1, 0,
183 doc: /* Convert arg BYTE to a unibyte string containing that byte. */)
184 (Lisp_Object byte)
186 unsigned char b;
187 CHECK_NUMBER (byte);
188 if (XINT (byte) < 0 || XINT (byte) > 255)
189 error ("Invalid byte");
190 b = XINT (byte);
191 return make_string_from_bytes ((char *) &b, 1, 1);
194 DEFUN ("string-to-char", Fstring_to_char, Sstring_to_char, 1, 1, 0,
195 doc: /* Return the first character in STRING. */)
196 (register Lisp_Object string)
198 register Lisp_Object val;
199 CHECK_STRING (string);
200 if (SCHARS (string))
202 if (STRING_MULTIBYTE (string))
203 XSETFASTINT (val, STRING_CHAR (SDATA (string)));
204 else
205 XSETFASTINT (val, SREF (string, 0));
207 else
208 XSETFASTINT (val, 0);
209 return val;
212 DEFUN ("point", Fpoint, Spoint, 0, 0, 0,
213 doc: /* Return value of point, as an integer.
214 Beginning of buffer is position (point-min). */)
215 (void)
217 Lisp_Object temp;
218 XSETFASTINT (temp, PT);
219 return temp;
222 DEFUN ("point-marker", Fpoint_marker, Spoint_marker, 0, 0, 0,
223 doc: /* Return value of point, as a marker object. */)
224 (void)
226 return build_marker (current_buffer, PT, PT_BYTE);
229 DEFUN ("goto-char", Fgoto_char, Sgoto_char, 1, 1, "NGoto char: ",
230 doc: /* Set point to POSITION, a number or marker.
231 Beginning of buffer is position (point-min), end is (point-max).
233 The return value is POSITION. */)
234 (register Lisp_Object position)
236 if (MARKERP (position))
237 set_point_from_marker (position);
238 else if (INTEGERP (position))
239 SET_PT (clip_to_bounds (BEGV, XINT (position), ZV));
240 else
241 wrong_type_argument (Qinteger_or_marker_p, position);
242 return position;
246 /* Return the start or end position of the region.
247 BEGINNINGP means return the start.
248 If there is no region active, signal an error. */
250 static Lisp_Object
251 region_limit (bool beginningp)
253 Lisp_Object m;
255 if (!NILP (Vtransient_mark_mode)
256 && NILP (Vmark_even_if_inactive)
257 && NILP (BVAR (current_buffer, mark_active)))
258 xsignal0 (Qmark_inactive);
260 m = Fmarker_position (BVAR (current_buffer, mark));
261 if (NILP (m))
262 error ("The mark is not set now, so there is no region");
264 /* Clip to the current narrowing (bug#11770). */
265 return make_number ((PT < XFASTINT (m)) == beginningp
266 ? PT
267 : clip_to_bounds (BEGV, XFASTINT (m), ZV));
270 DEFUN ("region-beginning", Fregion_beginning, Sregion_beginning, 0, 0, 0,
271 doc: /* Return the integer value of point or mark, whichever is smaller. */)
272 (void)
274 return region_limit (1);
277 DEFUN ("region-end", Fregion_end, Sregion_end, 0, 0, 0,
278 doc: /* Return the integer value of point or mark, whichever is larger. */)
279 (void)
281 return region_limit (0);
284 DEFUN ("mark-marker", Fmark_marker, Smark_marker, 0, 0, 0,
285 doc: /* Return this buffer's mark, as a marker object.
286 Watch out! Moving this marker changes the mark position.
287 If you set the marker not to point anywhere, the buffer will have no mark. */)
288 (void)
290 return BVAR (current_buffer, mark);
294 /* Find all the overlays in the current buffer that touch position POS.
295 Return the number found, and store them in a vector in VEC
296 of length LEN. */
298 static ptrdiff_t
299 overlays_around (EMACS_INT pos, Lisp_Object *vec, ptrdiff_t len)
301 Lisp_Object overlay, start, end;
302 struct Lisp_Overlay *tail;
303 ptrdiff_t startpos, endpos;
304 ptrdiff_t idx = 0;
306 for (tail = current_buffer->overlays_before; tail; tail = tail->next)
308 XSETMISC (overlay, tail);
310 end = OVERLAY_END (overlay);
311 endpos = OVERLAY_POSITION (end);
312 if (endpos < pos)
313 break;
314 start = OVERLAY_START (overlay);
315 startpos = OVERLAY_POSITION (start);
316 if (startpos <= pos)
318 if (idx < len)
319 vec[idx] = overlay;
320 /* Keep counting overlays even if we can't return them all. */
321 idx++;
325 for (tail = current_buffer->overlays_after; tail; tail = tail->next)
327 XSETMISC (overlay, tail);
329 start = OVERLAY_START (overlay);
330 startpos = OVERLAY_POSITION (start);
331 if (pos < startpos)
332 break;
333 end = OVERLAY_END (overlay);
334 endpos = OVERLAY_POSITION (end);
335 if (pos <= endpos)
337 if (idx < len)
338 vec[idx] = overlay;
339 idx++;
343 return idx;
346 DEFUN ("get-pos-property", Fget_pos_property, Sget_pos_property, 2, 3, 0,
347 doc: /* Return the value of POSITION's property PROP, in OBJECT.
348 Almost identical to `get-char-property' except for the following difference:
349 Whereas `get-char-property' returns the property of the char at (i.e. right
350 after) POSITION, this pays attention to properties's stickiness and overlays's
351 advancement settings, in order to find the property of POSITION itself,
352 i.e. the property that a char would inherit if it were inserted
353 at POSITION. */)
354 (Lisp_Object position, register Lisp_Object prop, Lisp_Object object)
356 CHECK_NUMBER_COERCE_MARKER (position);
358 if (NILP (object))
359 XSETBUFFER (object, current_buffer);
360 else if (WINDOWP (object))
361 object = XWINDOW (object)->contents;
363 if (!BUFFERP (object))
364 /* pos-property only makes sense in buffers right now, since strings
365 have no overlays and no notion of insertion for which stickiness
366 could be obeyed. */
367 return Fget_text_property (position, prop, object);
368 else
370 EMACS_INT posn = XINT (position);
371 ptrdiff_t noverlays;
372 Lisp_Object *overlay_vec, tem;
373 struct buffer *obuf = current_buffer;
374 USE_SAFE_ALLOCA;
376 set_buffer_temp (XBUFFER (object));
378 /* First try with room for 40 overlays. */
379 Lisp_Object overlay_vecbuf[40];
380 noverlays = ARRAYELTS (overlay_vecbuf);
381 overlay_vec = overlay_vecbuf;
382 noverlays = overlays_around (posn, overlay_vec, noverlays);
384 /* If there are more than 40,
385 make enough space for all, and try again. */
386 if (ARRAYELTS (overlay_vecbuf) < noverlays)
388 SAFE_ALLOCA_LISP (overlay_vec, noverlays);
389 noverlays = overlays_around (posn, overlay_vec, noverlays);
391 noverlays = sort_overlays (overlay_vec, noverlays, NULL);
393 set_buffer_temp (obuf);
395 /* Now check the overlays in order of decreasing priority. */
396 while (--noverlays >= 0)
398 Lisp_Object ol = overlay_vec[noverlays];
399 tem = Foverlay_get (ol, prop);
400 if (!NILP (tem))
402 /* Check the overlay is indeed active at point. */
403 Lisp_Object start = OVERLAY_START (ol), finish = OVERLAY_END (ol);
404 if ((OVERLAY_POSITION (start) == posn
405 && XMARKER (start)->insertion_type == 1)
406 || (OVERLAY_POSITION (finish) == posn
407 && XMARKER (finish)->insertion_type == 0))
408 ; /* The overlay will not cover a char inserted at point. */
409 else
411 SAFE_FREE ();
412 return tem;
416 SAFE_FREE ();
418 { /* Now check the text properties. */
419 int stickiness = text_property_stickiness (prop, position, object);
420 if (stickiness > 0)
421 return Fget_text_property (position, prop, object);
422 else if (stickiness < 0
423 && XINT (position) > BUF_BEGV (XBUFFER (object)))
424 return Fget_text_property (make_number (XINT (position) - 1),
425 prop, object);
426 else
427 return Qnil;
432 /* Find the field surrounding POS in *BEG and *END. If POS is nil,
433 the value of point is used instead. If BEG or END is null,
434 means don't store the beginning or end of the field.
436 BEG_LIMIT and END_LIMIT serve to limit the ranged of the returned
437 results; they do not effect boundary behavior.
439 If MERGE_AT_BOUNDARY is non-nil, then if POS is at the very first
440 position of a field, then the beginning of the previous field is
441 returned instead of the beginning of POS's field (since the end of a
442 field is actually also the beginning of the next input field, this
443 behavior is sometimes useful). Additionally in the MERGE_AT_BOUNDARY
444 non-nil case, if two fields are separated by a field with the special
445 value `boundary', and POS lies within it, then the two separated
446 fields are considered to be adjacent, and POS between them, when
447 finding the beginning and ending of the "merged" field.
449 Either BEG or END may be 0, in which case the corresponding value
450 is not stored. */
452 static void
453 find_field (Lisp_Object pos, Lisp_Object merge_at_boundary,
454 Lisp_Object beg_limit,
455 ptrdiff_t *beg, Lisp_Object end_limit, ptrdiff_t *end)
457 /* Fields right before and after the point. */
458 Lisp_Object before_field, after_field;
459 /* True if POS counts as the start of a field. */
460 bool at_field_start = 0;
461 /* True if POS counts as the end of a field. */
462 bool at_field_end = 0;
464 if (NILP (pos))
465 XSETFASTINT (pos, PT);
466 else
467 CHECK_NUMBER_COERCE_MARKER (pos);
469 after_field
470 = get_char_property_and_overlay (pos, Qfield, Qnil, NULL);
471 before_field
472 = (XFASTINT (pos) > BEGV
473 ? get_char_property_and_overlay (make_number (XINT (pos) - 1),
474 Qfield, Qnil, NULL)
475 /* Using nil here would be a more obvious choice, but it would
476 fail when the buffer starts with a non-sticky field. */
477 : after_field);
479 /* See if we need to handle the case where MERGE_AT_BOUNDARY is nil
480 and POS is at beginning of a field, which can also be interpreted
481 as the end of the previous field. Note that the case where if
482 MERGE_AT_BOUNDARY is non-nil (see function comment) is actually the
483 more natural one; then we avoid treating the beginning of a field
484 specially. */
485 if (NILP (merge_at_boundary))
487 Lisp_Object field = Fget_pos_property (pos, Qfield, Qnil);
488 if (!EQ (field, after_field))
489 at_field_end = 1;
490 if (!EQ (field, before_field))
491 at_field_start = 1;
492 if (NILP (field) && at_field_start && at_field_end)
493 /* If an inserted char would have a nil field while the surrounding
494 text is non-nil, we're probably not looking at a
495 zero-length field, but instead at a non-nil field that's
496 not intended for editing (such as comint's prompts). */
497 at_field_end = at_field_start = 0;
500 /* Note about special `boundary' fields:
502 Consider the case where the point (`.') is between the fields `x' and `y':
504 xxxx.yyyy
506 In this situation, if merge_at_boundary is non-nil, consider the
507 `x' and `y' fields as forming one big merged field, and so the end
508 of the field is the end of `y'.
510 However, if `x' and `y' are separated by a special `boundary' field
511 (a field with a `field' char-property of 'boundary), then ignore
512 this special field when merging adjacent fields. Here's the same
513 situation, but with a `boundary' field between the `x' and `y' fields:
515 xxx.BBBByyyy
517 Here, if point is at the end of `x', the beginning of `y', or
518 anywhere in-between (within the `boundary' field), merge all
519 three fields and consider the beginning as being the beginning of
520 the `x' field, and the end as being the end of the `y' field. */
522 if (beg)
524 if (at_field_start)
525 /* POS is at the edge of a field, and we should consider it as
526 the beginning of the following field. */
527 *beg = XFASTINT (pos);
528 else
529 /* Find the previous field boundary. */
531 Lisp_Object p = pos;
532 if (!NILP (merge_at_boundary) && EQ (before_field, Qboundary))
533 /* Skip a `boundary' field. */
534 p = Fprevious_single_char_property_change (p, Qfield, Qnil,
535 beg_limit);
537 p = Fprevious_single_char_property_change (p, Qfield, Qnil,
538 beg_limit);
539 *beg = NILP (p) ? BEGV : XFASTINT (p);
543 if (end)
545 if (at_field_end)
546 /* POS is at the edge of a field, and we should consider it as
547 the end of the previous field. */
548 *end = XFASTINT (pos);
549 else
550 /* Find the next field boundary. */
552 if (!NILP (merge_at_boundary) && EQ (after_field, Qboundary))
553 /* Skip a `boundary' field. */
554 pos = Fnext_single_char_property_change (pos, Qfield, Qnil,
555 end_limit);
557 pos = Fnext_single_char_property_change (pos, Qfield, Qnil,
558 end_limit);
559 *end = NILP (pos) ? ZV : XFASTINT (pos);
565 DEFUN ("delete-field", Fdelete_field, Sdelete_field, 0, 1, 0,
566 doc: /* Delete the field surrounding POS.
567 A field is a region of text with the same `field' property.
568 If POS is nil, the value of point is used for POS. */)
569 (Lisp_Object pos)
571 ptrdiff_t beg, end;
572 find_field (pos, Qnil, Qnil, &beg, Qnil, &end);
573 if (beg != end)
574 del_range (beg, end);
575 return Qnil;
578 DEFUN ("field-string", Ffield_string, Sfield_string, 0, 1, 0,
579 doc: /* Return the contents of the field surrounding POS as a string.
580 A field is a region of text with the same `field' property.
581 If POS is nil, the value of point is used for POS. */)
582 (Lisp_Object pos)
584 ptrdiff_t beg, end;
585 find_field (pos, Qnil, Qnil, &beg, Qnil, &end);
586 return make_buffer_string (beg, end, 1);
589 DEFUN ("field-string-no-properties", Ffield_string_no_properties, Sfield_string_no_properties, 0, 1, 0,
590 doc: /* Return the contents of the field around POS, without text properties.
591 A field is a region of text with the same `field' property.
592 If POS is nil, the value of point is used for POS. */)
593 (Lisp_Object pos)
595 ptrdiff_t beg, end;
596 find_field (pos, Qnil, Qnil, &beg, Qnil, &end);
597 return make_buffer_string (beg, end, 0);
600 DEFUN ("field-beginning", Ffield_beginning, Sfield_beginning, 0, 3, 0,
601 doc: /* Return the beginning of the field surrounding POS.
602 A field is a region of text with the same `field' property.
603 If POS is nil, the value of point is used for POS.
604 If ESCAPE-FROM-EDGE is non-nil and POS is at the beginning of its
605 field, then the beginning of the *previous* field is returned.
606 If LIMIT is non-nil, it is a buffer position; if the beginning of the field
607 is before LIMIT, then LIMIT will be returned instead. */)
608 (Lisp_Object pos, Lisp_Object escape_from_edge, Lisp_Object limit)
610 ptrdiff_t beg;
611 find_field (pos, escape_from_edge, limit, &beg, Qnil, 0);
612 return make_number (beg);
615 DEFUN ("field-end", Ffield_end, Sfield_end, 0, 3, 0,
616 doc: /* Return the end of the field surrounding POS.
617 A field is a region of text with the same `field' property.
618 If POS is nil, the value of point is used for POS.
619 If ESCAPE-FROM-EDGE is non-nil and POS is at the end of its field,
620 then the end of the *following* field is returned.
621 If LIMIT is non-nil, it is a buffer position; if the end of the field
622 is after LIMIT, then LIMIT will be returned instead. */)
623 (Lisp_Object pos, Lisp_Object escape_from_edge, Lisp_Object limit)
625 ptrdiff_t end;
626 find_field (pos, escape_from_edge, Qnil, 0, limit, &end);
627 return make_number (end);
630 DEFUN ("constrain-to-field", Fconstrain_to_field, Sconstrain_to_field, 2, 5, 0,
631 doc: /* Return the position closest to NEW-POS that is in the same field as OLD-POS.
632 A field is a region of text with the same `field' property.
634 If NEW-POS is nil, then use the current point instead, and move point
635 to the resulting constrained position, in addition to returning that
636 position.
638 If OLD-POS is at the boundary of two fields, then the allowable
639 positions for NEW-POS depends on the value of the optional argument
640 ESCAPE-FROM-EDGE: If ESCAPE-FROM-EDGE is nil, then NEW-POS is
641 constrained to the field that has the same `field' char-property
642 as any new characters inserted at OLD-POS, whereas if ESCAPE-FROM-EDGE
643 is non-nil, NEW-POS is constrained to the union of the two adjacent
644 fields. Additionally, if two fields are separated by another field with
645 the special value `boundary', then any point within this special field is
646 also considered to be `on the boundary'.
648 If the optional argument ONLY-IN-LINE is non-nil and constraining
649 NEW-POS would move it to a different line, NEW-POS is returned
650 unconstrained. This is useful for commands that move by line, like
651 \\[next-line] or \\[beginning-of-line], which should generally respect field boundaries
652 only in the case where they can still move to the right line.
654 If the optional argument INHIBIT-CAPTURE-PROPERTY is non-nil, and OLD-POS has
655 a non-nil property of that name, then any field boundaries are ignored.
657 Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */)
658 (Lisp_Object new_pos, Lisp_Object old_pos, Lisp_Object escape_from_edge,
659 Lisp_Object only_in_line, Lisp_Object inhibit_capture_property)
661 /* If non-zero, then the original point, before re-positioning. */
662 ptrdiff_t orig_point = 0;
663 bool fwd;
664 Lisp_Object prev_old, prev_new;
666 if (NILP (new_pos))
667 /* Use the current point, and afterwards, set it. */
669 orig_point = PT;
670 XSETFASTINT (new_pos, PT);
673 CHECK_NUMBER_COERCE_MARKER (new_pos);
674 CHECK_NUMBER_COERCE_MARKER (old_pos);
676 fwd = (XINT (new_pos) > XINT (old_pos));
678 prev_old = make_number (XINT (old_pos) - 1);
679 prev_new = make_number (XINT (new_pos) - 1);
681 if (NILP (Vinhibit_field_text_motion)
682 && !EQ (new_pos, old_pos)
683 && (!NILP (Fget_char_property (new_pos, Qfield, Qnil))
684 || !NILP (Fget_char_property (old_pos, Qfield, Qnil))
685 /* To recognize field boundaries, we must also look at the
686 previous positions; we could use `Fget_pos_property'
687 instead, but in itself that would fail inside non-sticky
688 fields (like comint prompts). */
689 || (XFASTINT (new_pos) > BEGV
690 && !NILP (Fget_char_property (prev_new, Qfield, Qnil)))
691 || (XFASTINT (old_pos) > BEGV
692 && !NILP (Fget_char_property (prev_old, Qfield, Qnil))))
693 && (NILP (inhibit_capture_property)
694 /* Field boundaries are again a problem; but now we must
695 decide the case exactly, so we need to call
696 `get_pos_property' as well. */
697 || (NILP (Fget_pos_property (old_pos, inhibit_capture_property, Qnil))
698 && (XFASTINT (old_pos) <= BEGV
699 || NILP (Fget_char_property
700 (old_pos, inhibit_capture_property, Qnil))
701 || NILP (Fget_char_property
702 (prev_old, inhibit_capture_property, Qnil))))))
703 /* It is possible that NEW_POS is not within the same field as
704 OLD_POS; try to move NEW_POS so that it is. */
706 ptrdiff_t shortage;
707 Lisp_Object field_bound;
709 if (fwd)
710 field_bound = Ffield_end (old_pos, escape_from_edge, new_pos);
711 else
712 field_bound = Ffield_beginning (old_pos, escape_from_edge, new_pos);
714 if (/* See if ESCAPE_FROM_EDGE caused FIELD_BOUND to jump to the
715 other side of NEW_POS, which would mean that NEW_POS is
716 already acceptable, and it's not necessary to constrain it
717 to FIELD_BOUND. */
718 ((XFASTINT (field_bound) < XFASTINT (new_pos)) ? fwd : !fwd)
719 /* NEW_POS should be constrained, but only if either
720 ONLY_IN_LINE is nil (in which case any constraint is OK),
721 or NEW_POS and FIELD_BOUND are on the same line (in which
722 case the constraint is OK even if ONLY_IN_LINE is non-nil). */
723 && (NILP (only_in_line)
724 /* This is the ONLY_IN_LINE case, check that NEW_POS and
725 FIELD_BOUND are on the same line by seeing whether
726 there's an intervening newline or not. */
727 || (find_newline (XFASTINT (new_pos), -1,
728 XFASTINT (field_bound), -1,
729 fwd ? -1 : 1, &shortage, NULL, 1),
730 shortage != 0)))
731 /* Constrain NEW_POS to FIELD_BOUND. */
732 new_pos = field_bound;
734 if (orig_point && XFASTINT (new_pos) != orig_point)
735 /* The NEW_POS argument was originally nil, so automatically set PT. */
736 SET_PT (XFASTINT (new_pos));
739 return new_pos;
743 DEFUN ("line-beginning-position",
744 Fline_beginning_position, Sline_beginning_position, 0, 1, 0,
745 doc: /* Return the character position of the first character on the current line.
746 With optional argument N, scan forward N - 1 lines first.
747 If the scan reaches the end of the buffer, return that position.
749 This function ignores text display directionality; it returns the
750 position of the first character in logical order, i.e. the smallest
751 character position on the line.
753 This function constrains the returned position to the current field
754 unless that position would be on a different line than the original,
755 unconstrained result. If N is nil or 1, and a front-sticky field
756 starts at point, the scan stops as soon as it starts. To ignore field
757 boundaries, bind `inhibit-field-text-motion' to t.
759 This function does not move point. */)
760 (Lisp_Object n)
762 ptrdiff_t orig, orig_byte, end;
763 ptrdiff_t count = SPECPDL_INDEX ();
764 specbind (Qinhibit_point_motion_hooks, Qt);
766 if (NILP (n))
767 XSETFASTINT (n, 1);
768 else
769 CHECK_NUMBER (n);
771 orig = PT;
772 orig_byte = PT_BYTE;
773 Fforward_line (make_number (XINT (n) - 1));
774 end = PT;
776 SET_PT_BOTH (orig, orig_byte);
778 unbind_to (count, Qnil);
780 /* Return END constrained to the current input field. */
781 return Fconstrain_to_field (make_number (end), make_number (orig),
782 XINT (n) != 1 ? Qt : Qnil,
783 Qt, Qnil);
786 DEFUN ("line-end-position", Fline_end_position, Sline_end_position, 0, 1, 0,
787 doc: /* Return the character position of the last character on the current line.
788 With argument N not nil or 1, move forward N - 1 lines first.
789 If scan reaches end of buffer, return that position.
791 This function ignores text display directionality; it returns the
792 position of the last character in logical order, i.e. the largest
793 character position on the line.
795 This function constrains the returned position to the current field
796 unless that would be on a different line than the original,
797 unconstrained result. If N is nil or 1, and a rear-sticky field ends
798 at point, the scan stops as soon as it starts. To ignore field
799 boundaries bind `inhibit-field-text-motion' to t.
801 This function does not move point. */)
802 (Lisp_Object n)
804 ptrdiff_t clipped_n;
805 ptrdiff_t end_pos;
806 ptrdiff_t orig = PT;
808 if (NILP (n))
809 XSETFASTINT (n, 1);
810 else
811 CHECK_NUMBER (n);
813 clipped_n = clip_to_bounds (PTRDIFF_MIN + 1, XINT (n), PTRDIFF_MAX);
814 end_pos = find_before_next_newline (orig, 0, clipped_n - (clipped_n <= 0),
815 NULL);
817 /* Return END_POS constrained to the current input field. */
818 return Fconstrain_to_field (make_number (end_pos), make_number (orig),
819 Qnil, Qt, Qnil);
822 /* Save current buffer state for `save-excursion' special form.
823 We (ab)use Lisp_Misc_Save_Value to allow explicit free and so
824 offload some work from GC. */
826 Lisp_Object
827 save_excursion_save (void)
829 return make_save_obj_obj_obj_obj
830 (Fpoint_marker (),
831 /* Do not copy the mark if it points to nowhere. */
832 (XMARKER (BVAR (current_buffer, mark))->buffer
833 ? Fcopy_marker (BVAR (current_buffer, mark), Qnil)
834 : Qnil),
835 /* Selected window if current buffer is shown in it, nil otherwise. */
836 (EQ (XWINDOW (selected_window)->contents, Fcurrent_buffer ())
837 ? selected_window : Qnil),
838 BVAR (current_buffer, mark_active));
841 /* Restore saved buffer before leaving `save-excursion' special form. */
843 void
844 save_excursion_restore (Lisp_Object info)
846 Lisp_Object tem, tem1, omark, nmark;
847 struct gcpro gcpro1, gcpro2, gcpro3;
849 tem = Fmarker_buffer (XSAVE_OBJECT (info, 0));
850 /* If we're unwinding to top level, saved buffer may be deleted. This
851 means that all of its markers are unchained and so tem is nil. */
852 if (NILP (tem))
853 goto out;
855 omark = nmark = Qnil;
856 GCPRO3 (info, omark, nmark);
858 Fset_buffer (tem);
860 /* Point marker. */
861 tem = XSAVE_OBJECT (info, 0);
862 Fgoto_char (tem);
863 unchain_marker (XMARKER (tem));
865 /* Mark marker. */
866 tem = XSAVE_OBJECT (info, 1);
867 omark = Fmarker_position (BVAR (current_buffer, mark));
868 if (NILP (tem))
869 unchain_marker (XMARKER (BVAR (current_buffer, mark)));
870 else
872 Fset_marker (BVAR (current_buffer, mark), tem, Fcurrent_buffer ());
873 nmark = Fmarker_position (tem);
874 unchain_marker (XMARKER (tem));
877 /* Mark active. */
878 tem = XSAVE_OBJECT (info, 3);
879 tem1 = BVAR (current_buffer, mark_active);
880 bset_mark_active (current_buffer, tem);
882 /* If mark is active now, and either was not active
883 or was at a different place, run the activate hook. */
884 if (! NILP (tem))
886 if (! EQ (omark, nmark))
888 tem = intern ("activate-mark-hook");
889 Frun_hooks (1, &tem);
892 /* If mark has ceased to be active, run deactivate hook. */
893 else if (! NILP (tem1))
895 tem = intern ("deactivate-mark-hook");
896 Frun_hooks (1, &tem);
899 /* If buffer was visible in a window, and a different window was
900 selected, and the old selected window is still showing this
901 buffer, restore point in that window. */
902 tem = XSAVE_OBJECT (info, 2);
903 if (WINDOWP (tem)
904 && !EQ (tem, selected_window)
905 && (tem1 = XWINDOW (tem)->contents,
906 (/* Window is live... */
907 BUFFERP (tem1)
908 /* ...and it shows the current buffer. */
909 && XBUFFER (tem1) == current_buffer)))
910 Fset_window_point (tem, make_number (PT));
912 UNGCPRO;
914 out:
916 free_misc (info);
919 DEFUN ("save-excursion", Fsave_excursion, Ssave_excursion, 0, UNEVALLED, 0,
920 doc: /* Save point, mark, and current buffer; execute BODY; restore those things.
921 Executes BODY just like `progn'.
922 The values of point, mark and the current buffer are restored
923 even in case of abnormal exit (throw or error).
924 The state of activation of the mark is also restored.
926 This construct does not save `deactivate-mark', and therefore
927 functions that change the buffer will still cause deactivation
928 of the mark at the end of the command. To prevent that, bind
929 `deactivate-mark' with `let'.
931 If you only want to save the current buffer but not point nor mark,
932 then just use `save-current-buffer', or even `with-current-buffer'.
934 usage: (save-excursion &rest BODY) */)
935 (Lisp_Object args)
937 register Lisp_Object val;
938 ptrdiff_t count = SPECPDL_INDEX ();
940 record_unwind_protect (save_excursion_restore, save_excursion_save ());
942 val = Fprogn (args);
943 return unbind_to (count, val);
946 DEFUN ("save-current-buffer", Fsave_current_buffer, Ssave_current_buffer, 0, UNEVALLED, 0,
947 doc: /* Record which buffer is current; execute BODY; make that buffer current.
948 BODY is executed just like `progn'.
949 usage: (save-current-buffer &rest BODY) */)
950 (Lisp_Object args)
952 ptrdiff_t count = SPECPDL_INDEX ();
954 record_unwind_current_buffer ();
955 return unbind_to (count, Fprogn (args));
958 DEFUN ("buffer-size", Fbuffer_size, Sbuffer_size, 0, 1, 0,
959 doc: /* Return the number of characters in the current buffer.
960 If BUFFER, return the number of characters in that buffer instead. */)
961 (Lisp_Object buffer)
963 if (NILP (buffer))
964 return make_number (Z - BEG);
965 else
967 CHECK_BUFFER (buffer);
968 return make_number (BUF_Z (XBUFFER (buffer))
969 - BUF_BEG (XBUFFER (buffer)));
973 DEFUN ("point-min", Fpoint_min, Spoint_min, 0, 0, 0,
974 doc: /* Return the minimum permissible value of point in the current buffer.
975 This is 1, unless narrowing (a buffer restriction) is in effect. */)
976 (void)
978 Lisp_Object temp;
979 XSETFASTINT (temp, BEGV);
980 return temp;
983 DEFUN ("point-min-marker", Fpoint_min_marker, Spoint_min_marker, 0, 0, 0,
984 doc: /* Return a marker to the minimum permissible value of point in this buffer.
985 This is the beginning, unless narrowing (a buffer restriction) is in effect. */)
986 (void)
988 return build_marker (current_buffer, BEGV, BEGV_BYTE);
991 DEFUN ("point-max", Fpoint_max, Spoint_max, 0, 0, 0,
992 doc: /* Return the maximum permissible value of point in the current buffer.
993 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
994 is in effect, in which case it is less. */)
995 (void)
997 Lisp_Object temp;
998 XSETFASTINT (temp, ZV);
999 return temp;
1002 DEFUN ("point-max-marker", Fpoint_max_marker, Spoint_max_marker, 0, 0, 0,
1003 doc: /* Return a marker to the maximum permissible value of point in this buffer.
1004 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1005 is in effect, in which case it is less. */)
1006 (void)
1008 return build_marker (current_buffer, ZV, ZV_BYTE);
1011 DEFUN ("gap-position", Fgap_position, Sgap_position, 0, 0, 0,
1012 doc: /* Return the position of the gap, in the current buffer.
1013 See also `gap-size'. */)
1014 (void)
1016 Lisp_Object temp;
1017 XSETFASTINT (temp, GPT);
1018 return temp;
1021 DEFUN ("gap-size", Fgap_size, Sgap_size, 0, 0, 0,
1022 doc: /* Return the size of the current buffer's gap.
1023 See also `gap-position'. */)
1024 (void)
1026 Lisp_Object temp;
1027 XSETFASTINT (temp, GAP_SIZE);
1028 return temp;
1031 DEFUN ("position-bytes", Fposition_bytes, Sposition_bytes, 1, 1, 0,
1032 doc: /* Return the byte position for character position POSITION.
1033 If POSITION is out of range, the value is nil. */)
1034 (Lisp_Object position)
1036 CHECK_NUMBER_COERCE_MARKER (position);
1037 if (XINT (position) < BEG || XINT (position) > Z)
1038 return Qnil;
1039 return make_number (CHAR_TO_BYTE (XINT (position)));
1042 DEFUN ("byte-to-position", Fbyte_to_position, Sbyte_to_position, 1, 1, 0,
1043 doc: /* Return the character position for byte position BYTEPOS.
1044 If BYTEPOS is out of range, the value is nil. */)
1045 (Lisp_Object bytepos)
1047 CHECK_NUMBER (bytepos);
1048 if (XINT (bytepos) < BEG_BYTE || XINT (bytepos) > Z_BYTE)
1049 return Qnil;
1050 return make_number (BYTE_TO_CHAR (XINT (bytepos)));
1053 DEFUN ("following-char", Ffollowing_char, Sfollowing_char, 0, 0, 0,
1054 doc: /* Return the character following point, as a number.
1055 At the end of the buffer or accessible region, return 0. */)
1056 (void)
1058 Lisp_Object temp;
1059 if (PT >= ZV)
1060 XSETFASTINT (temp, 0);
1061 else
1062 XSETFASTINT (temp, FETCH_CHAR (PT_BYTE));
1063 return temp;
1066 DEFUN ("preceding-char", Fprevious_char, Sprevious_char, 0, 0, 0,
1067 doc: /* Return the character preceding point, as a number.
1068 At the beginning of the buffer or accessible region, return 0. */)
1069 (void)
1071 Lisp_Object temp;
1072 if (PT <= BEGV)
1073 XSETFASTINT (temp, 0);
1074 else if (!NILP (BVAR (current_buffer, enable_multibyte_characters)))
1076 ptrdiff_t pos = PT_BYTE;
1077 DEC_POS (pos);
1078 XSETFASTINT (temp, FETCH_CHAR (pos));
1080 else
1081 XSETFASTINT (temp, FETCH_BYTE (PT_BYTE - 1));
1082 return temp;
1085 DEFUN ("bobp", Fbobp, Sbobp, 0, 0, 0,
1086 doc: /* Return t if point is at the beginning of the buffer.
1087 If the buffer is narrowed, this means the beginning of the narrowed part. */)
1088 (void)
1090 if (PT == BEGV)
1091 return Qt;
1092 return Qnil;
1095 DEFUN ("eobp", Feobp, Seobp, 0, 0, 0,
1096 doc: /* Return t if point is at the end of the buffer.
1097 If the buffer is narrowed, this means the end of the narrowed part. */)
1098 (void)
1100 if (PT == ZV)
1101 return Qt;
1102 return Qnil;
1105 DEFUN ("bolp", Fbolp, Sbolp, 0, 0, 0,
1106 doc: /* Return t if point is at the beginning of a line. */)
1107 (void)
1109 if (PT == BEGV || FETCH_BYTE (PT_BYTE - 1) == '\n')
1110 return Qt;
1111 return Qnil;
1114 DEFUN ("eolp", Feolp, Seolp, 0, 0, 0,
1115 doc: /* Return t if point is at the end of a line.
1116 `End of a line' includes point being at the end of the buffer. */)
1117 (void)
1119 if (PT == ZV || FETCH_BYTE (PT_BYTE) == '\n')
1120 return Qt;
1121 return Qnil;
1124 DEFUN ("char-after", Fchar_after, Schar_after, 0, 1, 0,
1125 doc: /* Return character in current buffer at position POS.
1126 POS is an integer or a marker and defaults to point.
1127 If POS is out of range, the value is nil. */)
1128 (Lisp_Object pos)
1130 register ptrdiff_t pos_byte;
1132 if (NILP (pos))
1134 pos_byte = PT_BYTE;
1135 XSETFASTINT (pos, PT);
1138 if (MARKERP (pos))
1140 pos_byte = marker_byte_position (pos);
1141 if (pos_byte < BEGV_BYTE || pos_byte >= ZV_BYTE)
1142 return Qnil;
1144 else
1146 CHECK_NUMBER_COERCE_MARKER (pos);
1147 if (XINT (pos) < BEGV || XINT (pos) >= ZV)
1148 return Qnil;
1150 pos_byte = CHAR_TO_BYTE (XINT (pos));
1153 return make_number (FETCH_CHAR (pos_byte));
1156 DEFUN ("char-before", Fchar_before, Schar_before, 0, 1, 0,
1157 doc: /* Return character in current buffer preceding position POS.
1158 POS is an integer or a marker and defaults to point.
1159 If POS is out of range, the value is nil. */)
1160 (Lisp_Object pos)
1162 register Lisp_Object val;
1163 register ptrdiff_t pos_byte;
1165 if (NILP (pos))
1167 pos_byte = PT_BYTE;
1168 XSETFASTINT (pos, PT);
1171 if (MARKERP (pos))
1173 pos_byte = marker_byte_position (pos);
1175 if (pos_byte <= BEGV_BYTE || pos_byte > ZV_BYTE)
1176 return Qnil;
1178 else
1180 CHECK_NUMBER_COERCE_MARKER (pos);
1182 if (XINT (pos) <= BEGV || XINT (pos) > ZV)
1183 return Qnil;
1185 pos_byte = CHAR_TO_BYTE (XINT (pos));
1188 if (!NILP (BVAR (current_buffer, enable_multibyte_characters)))
1190 DEC_POS (pos_byte);
1191 XSETFASTINT (val, FETCH_CHAR (pos_byte));
1193 else
1195 pos_byte--;
1196 XSETFASTINT (val, FETCH_BYTE (pos_byte));
1198 return val;
1201 DEFUN ("user-login-name", Fuser_login_name, Suser_login_name, 0, 1, 0,
1202 doc: /* Return the name under which the user logged in, as a string.
1203 This is based on the effective uid, not the real uid.
1204 Also, if the environment variables LOGNAME or USER are set,
1205 that determines the value of this function.
1207 If optional argument UID is an integer or a float, return the login name
1208 of the user with that uid, or nil if there is no such user. */)
1209 (Lisp_Object uid)
1211 struct passwd *pw;
1212 uid_t id;
1214 /* Set up the user name info if we didn't do it before.
1215 (That can happen if Emacs is dumpable
1216 but you decide to run `temacs -l loadup' and not dump. */
1217 if (INTEGERP (Vuser_login_name))
1218 init_editfns ();
1220 if (NILP (uid))
1221 return Vuser_login_name;
1223 CONS_TO_INTEGER (uid, uid_t, id);
1224 block_input ();
1225 pw = getpwuid (id);
1226 unblock_input ();
1227 return (pw ? build_string (pw->pw_name) : Qnil);
1230 DEFUN ("user-real-login-name", Fuser_real_login_name, Suser_real_login_name,
1231 0, 0, 0,
1232 doc: /* Return the name of the user's real uid, as a string.
1233 This ignores the environment variables LOGNAME and USER, so it differs from
1234 `user-login-name' when running under `su'. */)
1235 (void)
1237 /* Set up the user name info if we didn't do it before.
1238 (That can happen if Emacs is dumpable
1239 but you decide to run `temacs -l loadup' and not dump. */
1240 if (INTEGERP (Vuser_login_name))
1241 init_editfns ();
1242 return Vuser_real_login_name;
1245 DEFUN ("user-uid", Fuser_uid, Suser_uid, 0, 0, 0,
1246 doc: /* Return the effective uid of Emacs.
1247 Value is an integer or a float, depending on the value. */)
1248 (void)
1250 uid_t euid = geteuid ();
1251 return make_fixnum_or_float (euid);
1254 DEFUN ("user-real-uid", Fuser_real_uid, Suser_real_uid, 0, 0, 0,
1255 doc: /* Return the real uid of Emacs.
1256 Value is an integer or a float, depending on the value. */)
1257 (void)
1259 uid_t uid = getuid ();
1260 return make_fixnum_or_float (uid);
1263 DEFUN ("group-gid", Fgroup_gid, Sgroup_gid, 0, 0, 0,
1264 doc: /* Return the effective gid of Emacs.
1265 Value is an integer or a float, depending on the value. */)
1266 (void)
1268 gid_t egid = getegid ();
1269 return make_fixnum_or_float (egid);
1272 DEFUN ("group-real-gid", Fgroup_real_gid, Sgroup_real_gid, 0, 0, 0,
1273 doc: /* Return the real gid of Emacs.
1274 Value is an integer or a float, depending on the value. */)
1275 (void)
1277 gid_t gid = getgid ();
1278 return make_fixnum_or_float (gid);
1281 DEFUN ("user-full-name", Fuser_full_name, Suser_full_name, 0, 1, 0,
1282 doc: /* Return the full name of the user logged in, as a string.
1283 If the full name corresponding to Emacs's userid is not known,
1284 return "unknown".
1286 If optional argument UID is an integer or float, return the full name
1287 of the user with that uid, or nil if there is no such user.
1288 If UID is a string, return the full name of the user with that login
1289 name, or nil if there is no such user. */)
1290 (Lisp_Object uid)
1292 struct passwd *pw;
1293 register char *p, *q;
1294 Lisp_Object full;
1296 if (NILP (uid))
1297 return Vuser_full_name;
1298 else if (NUMBERP (uid))
1300 uid_t u;
1301 CONS_TO_INTEGER (uid, uid_t, u);
1302 block_input ();
1303 pw = getpwuid (u);
1304 unblock_input ();
1306 else if (STRINGP (uid))
1308 block_input ();
1309 pw = getpwnam (SSDATA (uid));
1310 unblock_input ();
1312 else
1313 error ("Invalid UID specification");
1315 if (!pw)
1316 return Qnil;
1318 p = USER_FULL_NAME;
1319 /* Chop off everything after the first comma. */
1320 q = strchr (p, ',');
1321 full = make_string (p, q ? q - p : strlen (p));
1323 #ifdef AMPERSAND_FULL_NAME
1324 p = SSDATA (full);
1325 q = strchr (p, '&');
1326 /* Substitute the login name for the &, upcasing the first character. */
1327 if (q)
1329 Lisp_Object login = Fuser_login_name (make_number (pw->pw_uid));
1330 USE_SAFE_ALLOCA;
1331 char *r = SAFE_ALLOCA (strlen (p) + SBYTES (login) + 1);
1332 memcpy (r, p, q - p);
1333 r[q - p] = 0;
1334 strcat (r, SSDATA (login));
1335 r[q - p] = upcase ((unsigned char) r[q - p]);
1336 strcat (r, q + 1);
1337 full = build_string (r);
1338 SAFE_FREE ();
1340 #endif /* AMPERSAND_FULL_NAME */
1342 return full;
1345 DEFUN ("system-name", Fsystem_name, Ssystem_name, 0, 0, 0,
1346 doc: /* Return the host name of the machine you are running on, as a string. */)
1347 (void)
1349 return Vsystem_name;
1352 DEFUN ("emacs-pid", Femacs_pid, Semacs_pid, 0, 0, 0,
1353 doc: /* Return the process ID of Emacs, as a number. */)
1354 (void)
1356 pid_t pid = getpid ();
1357 return make_fixnum_or_float (pid);
1362 #ifndef TIME_T_MIN
1363 # define TIME_T_MIN TYPE_MINIMUM (time_t)
1364 #endif
1365 #ifndef TIME_T_MAX
1366 # define TIME_T_MAX TYPE_MAXIMUM (time_t)
1367 #endif
1369 /* Report that a time value is out of range for Emacs. */
1370 void
1371 time_overflow (void)
1373 error ("Specified time is not representable");
1376 /* Return the upper part of the time T (everything but the bottom 16 bits). */
1377 static EMACS_INT
1378 hi_time (time_t t)
1380 time_t hi = t >> 16;
1382 /* Check for overflow, helping the compiler for common cases where
1383 no runtime check is needed, and taking care not to convert
1384 negative numbers to unsigned before comparing them. */
1385 if (! ((! TYPE_SIGNED (time_t)
1386 || MOST_NEGATIVE_FIXNUM <= TIME_T_MIN >> 16
1387 || MOST_NEGATIVE_FIXNUM <= hi)
1388 && (TIME_T_MAX >> 16 <= MOST_POSITIVE_FIXNUM
1389 || hi <= MOST_POSITIVE_FIXNUM)))
1390 time_overflow ();
1392 return hi;
1395 /* Return the bottom 16 bits of the time T. */
1396 static int
1397 lo_time (time_t t)
1399 return t & ((1 << 16) - 1);
1402 DEFUN ("current-time", Fcurrent_time, Scurrent_time, 0, 0, 0,
1403 doc: /* Return the current time, as the number of seconds since 1970-01-01 00:00:00.
1404 The time is returned as a list of integers (HIGH LOW USEC PSEC).
1405 HIGH has the most significant bits of the seconds, while LOW has the
1406 least significant 16 bits. USEC and PSEC are the microsecond and
1407 picosecond counts. */)
1408 (void)
1410 return make_lisp_time (current_timespec ());
1413 DEFUN ("get-internal-run-time", Fget_internal_run_time, Sget_internal_run_time,
1414 0, 0, 0,
1415 doc: /* Return the current run time used by Emacs.
1416 The time is returned as a list (HIGH LOW USEC PSEC), using the same
1417 style as (current-time).
1419 On systems that can't determine the run time, `get-internal-run-time'
1420 does the same thing as `current-time'. */)
1421 (void)
1423 #ifdef HAVE_GETRUSAGE
1424 struct rusage usage;
1425 time_t secs;
1426 int usecs;
1428 if (getrusage (RUSAGE_SELF, &usage) < 0)
1429 /* This shouldn't happen. What action is appropriate? */
1430 xsignal0 (Qerror);
1432 /* Sum up user time and system time. */
1433 secs = usage.ru_utime.tv_sec + usage.ru_stime.tv_sec;
1434 usecs = usage.ru_utime.tv_usec + usage.ru_stime.tv_usec;
1435 if (usecs >= 1000000)
1437 usecs -= 1000000;
1438 secs++;
1440 return make_lisp_time (make_timespec (secs, usecs * 1000));
1441 #else /* ! HAVE_GETRUSAGE */
1442 #ifdef WINDOWSNT
1443 return w32_get_internal_run_time ();
1444 #else /* ! WINDOWSNT */
1445 return Fcurrent_time ();
1446 #endif /* WINDOWSNT */
1447 #endif /* HAVE_GETRUSAGE */
1451 /* Make a Lisp list that represents the time T with fraction TAIL. */
1452 static Lisp_Object
1453 make_time_tail (time_t t, Lisp_Object tail)
1455 return Fcons (make_number (hi_time (t)),
1456 Fcons (make_number (lo_time (t)), tail));
1459 /* Make a Lisp list that represents the system time T. */
1460 static Lisp_Object
1461 make_time (time_t t)
1463 return make_time_tail (t, Qnil);
1466 /* Make a Lisp list that represents the Emacs time T. T may be an
1467 invalid time, with a slightly negative tv_nsec value such as
1468 UNKNOWN_MODTIME_NSECS; in that case, the Lisp list contains a
1469 correspondingly negative picosecond count. */
1470 Lisp_Object
1471 make_lisp_time (struct timespec t)
1473 int ns = t.tv_nsec;
1474 return make_time_tail (t.tv_sec, list2i (ns / 1000, ns % 1000 * 1000));
1477 /* Decode a Lisp list SPECIFIED_TIME that represents a time.
1478 Set *PHIGH, *PLOW, *PUSEC, *PPSEC to its parts; do not check their values.
1479 Return true if successful. */
1480 static bool
1481 disassemble_lisp_time (Lisp_Object specified_time, Lisp_Object *phigh,
1482 Lisp_Object *plow, Lisp_Object *pusec,
1483 Lisp_Object *ppsec)
1485 if (CONSP (specified_time))
1487 Lisp_Object low = XCDR (specified_time);
1488 Lisp_Object usec = make_number (0);
1489 Lisp_Object psec = make_number (0);
1490 if (CONSP (low))
1492 Lisp_Object low_tail = XCDR (low);
1493 low = XCAR (low);
1494 if (CONSP (low_tail))
1496 usec = XCAR (low_tail);
1497 low_tail = XCDR (low_tail);
1498 if (CONSP (low_tail))
1499 psec = XCAR (low_tail);
1501 else if (!NILP (low_tail))
1502 usec = low_tail;
1505 *phigh = XCAR (specified_time);
1506 *plow = low;
1507 *pusec = usec;
1508 *ppsec = psec;
1509 return 1;
1512 return 0;
1515 /* From the time components HIGH, LOW, USEC and PSEC taken from a Lisp
1516 list, generate the corresponding time value.
1518 If RESULT is not null, store into *RESULT the converted time;
1519 if the converted time does not fit into struct timespec,
1520 store an invalid timespec to indicate the overflow.
1521 If *DRESULT is not null, store into *DRESULT the number of
1522 seconds since the start of the POSIX Epoch.
1524 Return true if successful. */
1525 bool
1526 decode_time_components (Lisp_Object high, Lisp_Object low, Lisp_Object usec,
1527 Lisp_Object psec,
1528 struct timespec *result, double *dresult)
1530 EMACS_INT hi, lo, us, ps;
1531 if (! (INTEGERP (high) && INTEGERP (low)
1532 && INTEGERP (usec) && INTEGERP (psec)))
1533 return false;
1534 hi = XINT (high);
1535 lo = XINT (low);
1536 us = XINT (usec);
1537 ps = XINT (psec);
1539 /* Normalize out-of-range lower-order components by carrying
1540 each overflow into the next higher-order component. */
1541 us += ps / 1000000 - (ps % 1000000 < 0);
1542 lo += us / 1000000 - (us % 1000000 < 0);
1543 hi += lo >> 16;
1544 ps = ps % 1000000 + 1000000 * (ps % 1000000 < 0);
1545 us = us % 1000000 + 1000000 * (us % 1000000 < 0);
1546 lo &= (1 << 16) - 1;
1548 if (result)
1550 if ((TYPE_SIGNED (time_t) ? TIME_T_MIN >> 16 <= hi : 0 <= hi)
1551 && hi <= TIME_T_MAX >> 16)
1553 /* Return the greatest representable time that is not greater
1554 than the requested time. */
1555 time_t sec = hi;
1556 *result = make_timespec ((sec << 16) + lo, us * 1000 + ps / 1000);
1558 else
1559 *result = invalid_timespec ();
1562 if (dresult)
1563 *dresult = (us * 1e6 + ps) / 1e12 + lo + hi * 65536.0;
1565 return true;
1568 /* Decode a Lisp list SPECIFIED_TIME that represents a time.
1569 If SPECIFIED_TIME is nil, use the current time.
1571 Round the time down to the nearest struct timespec value.
1572 Return seconds since the Epoch.
1573 Signal an error if unsuccessful. */
1574 struct timespec
1575 lisp_time_argument (Lisp_Object specified_time)
1577 if (NILP (specified_time))
1578 return current_timespec ();
1579 else
1581 Lisp_Object high, low, usec, psec;
1582 struct timespec t;
1583 if (! (disassemble_lisp_time (specified_time, &high, &low, &usec, &psec)
1584 && decode_time_components (high, low, usec, psec, &t, 0)))
1585 error ("Invalid time specification");
1586 if (! timespec_valid_p (t))
1587 time_overflow ();
1588 return t;
1592 /* Like lisp_time_argument, except decode only the seconds part,
1593 and do not check the subseconds part. */
1594 static time_t
1595 lisp_seconds_argument (Lisp_Object specified_time)
1597 if (NILP (specified_time))
1598 return time (NULL);
1599 else
1601 Lisp_Object high, low, usec, psec;
1602 struct timespec t;
1603 if (! (disassemble_lisp_time (specified_time, &high, &low, &usec, &psec)
1604 && decode_time_components (high, low, make_number (0),
1605 make_number (0), &t, 0)))
1606 error ("Invalid time specification");
1607 if (! timespec_valid_p (t))
1608 time_overflow ();
1609 return t.tv_sec;
1613 DEFUN ("float-time", Ffloat_time, Sfloat_time, 0, 1, 0,
1614 doc: /* Return the current time, as a float number of seconds since the epoch.
1615 If SPECIFIED-TIME is given, it is the time to convert to float
1616 instead of the current time. The argument should have the form
1617 (HIGH LOW) or (HIGH LOW USEC) or (HIGH LOW USEC PSEC). Thus,
1618 you can use times from `current-time' and from `file-attributes'.
1619 SPECIFIED-TIME can also have the form (HIGH . LOW), but this is
1620 considered obsolete.
1622 WARNING: Since the result is floating point, it may not be exact.
1623 If precise time stamps are required, use either `current-time',
1624 or (if you need time as a string) `format-time-string'. */)
1625 (Lisp_Object specified_time)
1627 double t;
1628 if (NILP (specified_time))
1630 struct timespec now = current_timespec ();
1631 t = now.tv_sec + now.tv_nsec / 1e9;
1633 else
1635 Lisp_Object high, low, usec, psec;
1636 if (! (disassemble_lisp_time (specified_time, &high, &low, &usec, &psec)
1637 && decode_time_components (high, low, usec, psec, 0, &t)))
1638 error ("Invalid time specification");
1640 return make_float (t);
1643 /* Write information into buffer S of size MAXSIZE, according to the
1644 FORMAT of length FORMAT_LEN, using time information taken from *TP.
1645 Default to Universal Time if UT, local time otherwise.
1646 Use NS as the number of nanoseconds in the %N directive.
1647 Return the number of bytes written, not including the terminating
1648 '\0'. If S is NULL, nothing will be written anywhere; so to
1649 determine how many bytes would be written, use NULL for S and
1650 ((size_t) -1) for MAXSIZE.
1652 This function behaves like nstrftime, except it allows null
1653 bytes in FORMAT and it does not support nanoseconds. */
1654 static size_t
1655 emacs_nmemftime (char *s, size_t maxsize, const char *format,
1656 size_t format_len, const struct tm *tp, bool ut, int ns)
1658 size_t total = 0;
1660 /* Loop through all the null-terminated strings in the format
1661 argument. Normally there's just one null-terminated string, but
1662 there can be arbitrarily many, concatenated together, if the
1663 format contains '\0' bytes. nstrftime stops at the first
1664 '\0' byte so we must invoke it separately for each such string. */
1665 for (;;)
1667 size_t len;
1668 size_t result;
1670 if (s)
1671 s[0] = '\1';
1673 result = nstrftime (s, maxsize, format, tp, ut, ns);
1675 if (s)
1677 if (result == 0 && s[0] != '\0')
1678 return 0;
1679 s += result + 1;
1682 maxsize -= result + 1;
1683 total += result;
1684 len = strlen (format);
1685 if (len == format_len)
1686 return total;
1687 total++;
1688 format += len + 1;
1689 format_len -= len + 1;
1693 DEFUN ("format-time-string", Fformat_time_string, Sformat_time_string, 1, 3, 0,
1694 doc: /* Use FORMAT-STRING to format the time TIME, or now if omitted.
1695 TIME is specified as (HIGH LOW USEC PSEC), as returned by
1696 `current-time' or `file-attributes'. The obsolete form (HIGH . LOW)
1697 is also still accepted.
1698 The third, optional, argument UNIVERSAL, if non-nil, means describe TIME
1699 as Universal Time; nil means describe TIME in the local time zone.
1700 The value is a copy of FORMAT-STRING, but with certain constructs replaced
1701 by text that describes the specified date and time in TIME:
1703 %Y is the year, %y within the century, %C the century.
1704 %G is the year corresponding to the ISO week, %g within the century.
1705 %m is the numeric month.
1706 %b and %h are the locale's abbreviated month name, %B the full name.
1707 (%h is not supported on MS-Windows.)
1708 %d is the day of the month, zero-padded, %e is blank-padded.
1709 %u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.
1710 %a is the locale's abbreviated name of the day of week, %A the full name.
1711 %U is the week number starting on Sunday, %W starting on Monday,
1712 %V according to ISO 8601.
1713 %j is the day of the year.
1715 %H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H
1716 only blank-padded, %l is like %I blank-padded.
1717 %p is the locale's equivalent of either AM or PM.
1718 %M is the minute.
1719 %S is the second.
1720 %N is the nanosecond, %6N the microsecond, %3N the millisecond, etc.
1721 %Z is the time zone name, %z is the numeric form.
1722 %s is the number of seconds since 1970-01-01 00:00:00 +0000.
1724 %c is the locale's date and time format.
1725 %x is the locale's "preferred" date format.
1726 %D is like "%m/%d/%y".
1727 %F is the ISO 8601 date format (like "%Y-%m-%d").
1729 %R is like "%H:%M", %T is like "%H:%M:%S", %r is like "%I:%M:%S %p".
1730 %X is the locale's "preferred" time format.
1732 Finally, %n is a newline, %t is a tab, %% is a literal %.
1734 Certain flags and modifiers are available with some format controls.
1735 The flags are `_', `-', `^' and `#'. For certain characters X,
1736 %_X is like %X, but padded with blanks; %-X is like %X,
1737 but without padding. %^X is like %X, but with all textual
1738 characters up-cased; %#X is like %X, but with letter-case of
1739 all textual characters reversed.
1740 %NX (where N stands for an integer) is like %X,
1741 but takes up at least N (a number) positions.
1742 The modifiers are `E' and `O'. For certain characters X,
1743 %EX is a locale's alternative version of %X;
1744 %OX is like %X, but uses the locale's number symbols.
1746 For example, to produce full ISO 8601 format, use "%FT%T%z".
1748 usage: (format-time-string FORMAT-STRING &optional TIME UNIVERSAL) */)
1749 (Lisp_Object format_string, Lisp_Object timeval, Lisp_Object universal)
1751 struct timespec t = lisp_time_argument (timeval);
1752 struct tm tm;
1754 CHECK_STRING (format_string);
1755 format_string = code_convert_string_norecord (format_string,
1756 Vlocale_coding_system, 1);
1757 return format_time_string (SSDATA (format_string), SBYTES (format_string),
1758 t, ! NILP (universal), &tm);
1761 static Lisp_Object
1762 format_time_string (char const *format, ptrdiff_t formatlen,
1763 struct timespec t, bool ut, struct tm *tmp)
1765 char buffer[4000];
1766 char *buf = buffer;
1767 ptrdiff_t size = sizeof buffer;
1768 size_t len;
1769 Lisp_Object bufstring;
1770 int ns = t.tv_nsec;
1771 struct tm *tm;
1772 USE_SAFE_ALLOCA;
1774 while (1)
1776 time_t *taddr = &t.tv_sec;
1777 block_input ();
1779 synchronize_system_time_locale ();
1781 tm = ut ? gmtime (taddr) : localtime (taddr);
1782 if (! tm)
1784 unblock_input ();
1785 time_overflow ();
1787 *tmp = *tm;
1789 buf[0] = '\1';
1790 len = emacs_nmemftime (buf, size, format, formatlen, tm, ut, ns);
1791 if ((0 < len && len < size) || (len == 0 && buf[0] == '\0'))
1792 break;
1794 /* Buffer was too small, so make it bigger and try again. */
1795 len = emacs_nmemftime (NULL, SIZE_MAX, format, formatlen, tm, ut, ns);
1796 unblock_input ();
1797 if (STRING_BYTES_BOUND <= len)
1798 string_overflow ();
1799 size = len + 1;
1800 buf = SAFE_ALLOCA (size);
1803 unblock_input ();
1804 bufstring = make_unibyte_string (buf, len);
1805 SAFE_FREE ();
1806 return code_convert_string_norecord (bufstring, Vlocale_coding_system, 0);
1809 DEFUN ("decode-time", Fdecode_time, Sdecode_time, 0, 1, 0,
1810 doc: /* Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST ZONE).
1811 The optional SPECIFIED-TIME should be a list of (HIGH LOW . IGNORED),
1812 as from `current-time' and `file-attributes', or nil to use the
1813 current time. The obsolete form (HIGH . LOW) is also still accepted.
1814 The list has the following nine members: SEC is an integer between 0
1815 and 60; SEC is 60 for a leap second, which only some operating systems
1816 support. MINUTE is an integer between 0 and 59. HOUR is an integer
1817 between 0 and 23. DAY is an integer between 1 and 31. MONTH is an
1818 integer between 1 and 12. YEAR is an integer indicating the
1819 four-digit year. DOW is the day of week, an integer between 0 and 6,
1820 where 0 is Sunday. DST is t if daylight saving time is in effect,
1821 otherwise nil. ZONE is an integer indicating the number of seconds
1822 east of Greenwich. (Note that Common Lisp has different meanings for
1823 DOW and ZONE.) */)
1824 (Lisp_Object specified_time)
1826 time_t time_spec = lisp_seconds_argument (specified_time);
1827 struct tm save_tm;
1828 struct tm *decoded_time;
1829 Lisp_Object list_args[9];
1831 block_input ();
1832 decoded_time = localtime (&time_spec);
1833 if (decoded_time)
1834 save_tm = *decoded_time;
1835 unblock_input ();
1836 if (! (decoded_time
1837 && MOST_NEGATIVE_FIXNUM - TM_YEAR_BASE <= save_tm.tm_year
1838 && save_tm.tm_year <= MOST_POSITIVE_FIXNUM - TM_YEAR_BASE))
1839 time_overflow ();
1840 XSETFASTINT (list_args[0], save_tm.tm_sec);
1841 XSETFASTINT (list_args[1], save_tm.tm_min);
1842 XSETFASTINT (list_args[2], save_tm.tm_hour);
1843 XSETFASTINT (list_args[3], save_tm.tm_mday);
1844 XSETFASTINT (list_args[4], save_tm.tm_mon + 1);
1845 /* On 64-bit machines an int is narrower than EMACS_INT, thus the
1846 cast below avoids overflow in int arithmetics. */
1847 XSETINT (list_args[5], TM_YEAR_BASE + (EMACS_INT) save_tm.tm_year);
1848 XSETFASTINT (list_args[6], save_tm.tm_wday);
1849 list_args[7] = save_tm.tm_isdst ? Qt : Qnil;
1851 block_input ();
1852 decoded_time = gmtime (&time_spec);
1853 if (decoded_time == 0)
1854 list_args[8] = Qnil;
1855 else
1856 XSETINT (list_args[8], tm_diff (&save_tm, decoded_time));
1857 unblock_input ();
1858 return Flist (9, list_args);
1861 /* Return OBJ - OFFSET, checking that OBJ is a valid fixnum and that
1862 the result is representable as an int. Assume OFFSET is small and
1863 nonnegative. */
1864 static int
1865 check_tm_member (Lisp_Object obj, int offset)
1867 EMACS_INT n;
1868 CHECK_NUMBER (obj);
1869 n = XINT (obj);
1870 if (! (INT_MIN + offset <= n && n - offset <= INT_MAX))
1871 time_overflow ();
1872 return n - offset;
1875 DEFUN ("encode-time", Fencode_time, Sencode_time, 6, MANY, 0,
1876 doc: /* Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.
1877 This is the reverse operation of `decode-time', which see.
1878 ZONE defaults to the current time zone rule. This can
1879 be a string or t (as from `set-time-zone-rule'), or it can be a list
1880 \(as from `current-time-zone') or an integer (as from `decode-time')
1881 applied without consideration for daylight saving time.
1883 You can pass more than 7 arguments; then the first six arguments
1884 are used as SECOND through YEAR, and the *last* argument is used as ZONE.
1885 The intervening arguments are ignored.
1886 This feature lets (apply 'encode-time (decode-time ...)) work.
1888 Out-of-range values for SECOND, MINUTE, HOUR, DAY, or MONTH are allowed;
1889 for example, a DAY of 0 means the day preceding the given month.
1890 Year numbers less than 100 are treated just like other year numbers.
1891 If you want them to stand for years in this century, you must do that yourself.
1893 Years before 1970 are not guaranteed to work. On some systems,
1894 year values as low as 1901 do work.
1896 usage: (encode-time SECOND MINUTE HOUR DAY MONTH YEAR &optional ZONE) */)
1897 (ptrdiff_t nargs, Lisp_Object *args)
1899 time_t value;
1900 struct tm tm;
1901 Lisp_Object zone = (nargs > 6 ? args[nargs - 1] : Qnil);
1903 tm.tm_sec = check_tm_member (args[0], 0);
1904 tm.tm_min = check_tm_member (args[1], 0);
1905 tm.tm_hour = check_tm_member (args[2], 0);
1906 tm.tm_mday = check_tm_member (args[3], 0);
1907 tm.tm_mon = check_tm_member (args[4], 1);
1908 tm.tm_year = check_tm_member (args[5], TM_YEAR_BASE);
1909 tm.tm_isdst = -1;
1911 if (CONSP (zone))
1912 zone = XCAR (zone);
1913 if (NILP (zone))
1915 block_input ();
1916 value = mktime (&tm);
1917 unblock_input ();
1919 else
1921 static char const tzbuf_format[] = "XXX%s%"pI"d:%02d:%02d";
1922 char tzbuf[sizeof tzbuf_format + INT_STRLEN_BOUND (EMACS_INT)];
1923 char *old_tzstring;
1924 const char *tzstring;
1925 USE_SAFE_ALLOCA;
1927 if (EQ (zone, Qt))
1928 tzstring = "UTC0";
1929 else if (STRINGP (zone))
1930 tzstring = SSDATA (zone);
1931 else if (INTEGERP (zone))
1933 EMACS_INT abszone = eabs (XINT (zone));
1934 EMACS_INT zone_hr = abszone / (60*60);
1935 int zone_min = (abszone/60) % 60;
1936 int zone_sec = abszone % 60;
1937 sprintf (tzbuf, tzbuf_format, &"-"[XINT (zone) < 0],
1938 zone_hr, zone_min, zone_sec);
1939 tzstring = tzbuf;
1941 else
1942 error ("Invalid time zone specification");
1944 old_tzstring = getenv ("TZ");
1945 if (old_tzstring)
1947 char *buf = SAFE_ALLOCA (strlen (old_tzstring) + 1);
1948 old_tzstring = strcpy (buf, old_tzstring);
1951 block_input ();
1953 /* Set TZ before calling mktime; merely adjusting mktime's returned
1954 value doesn't suffice, since that would mishandle leap seconds. */
1955 set_time_zone_rule (tzstring);
1957 value = mktime (&tm);
1959 set_time_zone_rule (old_tzstring);
1960 #ifdef LOCALTIME_CACHE
1961 tzset ();
1962 #endif
1963 unblock_input ();
1964 SAFE_FREE ();
1967 if (value == (time_t) -1)
1968 time_overflow ();
1970 return make_time (value);
1973 DEFUN ("current-time-string", Fcurrent_time_string, Scurrent_time_string, 0, 1, 0,
1974 doc: /* Return the current local time, as a human-readable string.
1975 Programs can use this function to decode a time,
1976 since the number of columns in each field is fixed
1977 if the year is in the range 1000-9999.
1978 The format is `Sun Sep 16 01:03:52 1973'.
1979 However, see also the functions `decode-time' and `format-time-string'
1980 which provide a much more powerful and general facility.
1982 If SPECIFIED-TIME is given, it is a time to format instead of the
1983 current time. The argument should have the form (HIGH LOW . IGNORED).
1984 Thus, you can use times obtained from `current-time' and from
1985 `file-attributes'. SPECIFIED-TIME can also have the form (HIGH . LOW),
1986 but this is considered obsolete. */)
1987 (Lisp_Object specified_time)
1989 time_t value = lisp_seconds_argument (specified_time);
1990 struct tm *tm;
1991 char buf[sizeof "Mon Apr 30 12:49:17 " + INT_STRLEN_BOUND (int) + 1];
1992 int len IF_LINT (= 0);
1994 /* Convert to a string in ctime format, except without the trailing
1995 newline, and without the 4-digit year limit. Don't use asctime
1996 or ctime, as they might dump core if the year is outside the
1997 range -999 .. 9999. */
1998 block_input ();
1999 tm = localtime (&value);
2000 if (tm)
2002 static char const wday_name[][4] =
2003 { "Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat" };
2004 static char const mon_name[][4] =
2005 { "Jan", "Feb", "Mar", "Apr", "May", "Jun",
2006 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" };
2007 printmax_t year_base = TM_YEAR_BASE;
2009 len = sprintf (buf, "%s %s%3d %02d:%02d:%02d %"pMd,
2010 wday_name[tm->tm_wday], mon_name[tm->tm_mon], tm->tm_mday,
2011 tm->tm_hour, tm->tm_min, tm->tm_sec,
2012 tm->tm_year + year_base);
2014 unblock_input ();
2015 if (! tm)
2016 time_overflow ();
2018 return make_unibyte_string (buf, len);
2021 /* Yield A - B, measured in seconds.
2022 This function is copied from the GNU C Library. */
2023 static int
2024 tm_diff (struct tm *a, struct tm *b)
2026 /* Compute intervening leap days correctly even if year is negative.
2027 Take care to avoid int overflow in leap day calculations,
2028 but it's OK to assume that A and B are close to each other. */
2029 int a4 = (a->tm_year >> 2) + (TM_YEAR_BASE >> 2) - ! (a->tm_year & 3);
2030 int b4 = (b->tm_year >> 2) + (TM_YEAR_BASE >> 2) - ! (b->tm_year & 3);
2031 int a100 = a4 / 25 - (a4 % 25 < 0);
2032 int b100 = b4 / 25 - (b4 % 25 < 0);
2033 int a400 = a100 >> 2;
2034 int b400 = b100 >> 2;
2035 int intervening_leap_days = (a4 - b4) - (a100 - b100) + (a400 - b400);
2036 int years = a->tm_year - b->tm_year;
2037 int days = (365 * years + intervening_leap_days
2038 + (a->tm_yday - b->tm_yday));
2039 return (60 * (60 * (24 * days + (a->tm_hour - b->tm_hour))
2040 + (a->tm_min - b->tm_min))
2041 + (a->tm_sec - b->tm_sec));
2044 DEFUN ("current-time-zone", Fcurrent_time_zone, Scurrent_time_zone, 0, 1, 0,
2045 doc: /* Return the offset and name for the local time zone.
2046 This returns a list of the form (OFFSET NAME).
2047 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).
2048 A negative value means west of Greenwich.
2049 NAME is a string giving the name of the time zone.
2050 If SPECIFIED-TIME is given, the time zone offset is determined from it
2051 instead of using the current time. The argument should have the form
2052 (HIGH LOW . IGNORED). Thus, you can use times obtained from
2053 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
2054 have the form (HIGH . LOW), but this is considered obsolete.
2056 Some operating systems cannot provide all this information to Emacs;
2057 in this case, `current-time-zone' returns a list containing nil for
2058 the data it can't find. */)
2059 (Lisp_Object specified_time)
2061 struct timespec value;
2062 int offset;
2063 struct tm *t;
2064 struct tm localtm;
2065 Lisp_Object zone_offset, zone_name;
2067 zone_offset = Qnil;
2068 value = make_timespec (lisp_seconds_argument (specified_time), 0);
2069 zone_name = format_time_string ("%Z", sizeof "%Z" - 1, value, 0, &localtm);
2070 block_input ();
2071 t = gmtime (&value.tv_sec);
2072 if (t)
2073 offset = tm_diff (&localtm, t);
2074 unblock_input ();
2076 if (t)
2078 zone_offset = make_number (offset);
2079 if (SCHARS (zone_name) == 0)
2081 /* No local time zone name is available; use "+-NNNN" instead. */
2082 int m = offset / 60;
2083 int am = offset < 0 ? - m : m;
2084 char buf[sizeof "+00" + INT_STRLEN_BOUND (int)];
2085 zone_name = make_formatted_string (buf, "%c%02d%02d",
2086 (offset < 0 ? '-' : '+'),
2087 am / 60, am % 60);
2091 return list2 (zone_offset, zone_name);
2094 DEFUN ("set-time-zone-rule", Fset_time_zone_rule, Sset_time_zone_rule, 1, 1, 0,
2095 doc: /* Set the local time zone using TZ, a string specifying a time zone rule.
2096 If TZ is nil, use implementation-defined default time zone information.
2097 If TZ is t, use Universal Time.
2099 Instead of calling this function, you typically want (setenv "TZ" TZ).
2100 That changes both the environment of the Emacs process and the
2101 variable `process-environment', whereas `set-time-zone-rule' affects
2102 only the former. */)
2103 (Lisp_Object tz)
2105 const char *tzstring;
2107 if (! (NILP (tz) || EQ (tz, Qt)))
2108 CHECK_STRING (tz);
2110 if (NILP (tz))
2111 tzstring = initial_tz;
2112 else if (EQ (tz, Qt))
2113 tzstring = "UTC0";
2114 else
2115 tzstring = SSDATA (tz);
2117 block_input ();
2118 set_time_zone_rule (tzstring);
2119 unblock_input ();
2121 return Qnil;
2124 /* Set the local time zone rule to TZSTRING.
2126 This function is not thread-safe, partly because putenv, unsetenv
2127 and tzset are not, and partly because of the static storage it
2128 updates. Other threads that invoke localtime etc. may be adversely
2129 affected while this function is executing. */
2131 void
2132 set_time_zone_rule (const char *tzstring)
2134 /* A buffer holding a string of the form "TZ=value", intended
2135 to be part of the environment. */
2136 static char *tzvalbuf;
2137 static ptrdiff_t tzvalbufsize;
2139 int tzeqlen = sizeof "TZ=" - 1;
2141 #ifdef LOCALTIME_CACHE
2142 /* These two values are known to load tz files in buggy implementations,
2143 i.e., Solaris 1 executables running under either Solaris 1 or Solaris 2.
2144 Their values shouldn't matter in non-buggy implementations.
2145 We don't use string literals for these strings,
2146 since if a string in the environment is in readonly
2147 storage, it runs afoul of bugs in SVR4 and Solaris 2.3.
2148 See Sun bugs 1113095 and 1114114, ``Timezone routines
2149 improperly modify environment''. */
2151 static char set_time_zone_rule_tz[][sizeof "TZ=GMT+0"]
2152 = { "TZ=GMT+0", "TZ=GMT+1" };
2154 /* In SunOS 4.1.3_U1 and 4.1.4, if TZ has a value like
2155 "US/Pacific" that loads a tz file, then changes to a value like
2156 "XXX0" that does not load a tz file, and then changes back to
2157 its original value, the last change is (incorrectly) ignored.
2158 Also, if TZ changes twice in succession to values that do
2159 not load a tz file, tzset can dump core (see Sun bug#1225179).
2160 The following code works around these bugs. */
2162 if (tzstring)
2164 /* Temporarily set TZ to a value that loads a tz file
2165 and that differs from tzstring. */
2166 bool eq0 = strcmp (tzstring, set_time_zone_rule_tz[0] + tzeqlen) == 0;
2167 xputenv (set_time_zone_rule_tz[eq0]);
2169 else
2171 /* The implied tzstring is unknown, so temporarily set TZ to
2172 two different values that each load a tz file. */
2173 xputenv (set_time_zone_rule_tz[0]);
2174 tzset ();
2175 xputenv (set_time_zone_rule_tz[1]);
2177 tzset ();
2178 tzvalbuf_in_environ = 0;
2179 #endif
2181 if (!tzstring)
2183 unsetenv ("TZ");
2184 tzvalbuf_in_environ = 0;
2186 else
2188 ptrdiff_t tzstringlen = strlen (tzstring);
2190 if (tzvalbufsize <= tzeqlen + tzstringlen)
2192 unsetenv ("TZ");
2193 tzvalbuf_in_environ = 0;
2194 tzvalbuf = xpalloc (tzvalbuf, &tzvalbufsize,
2195 tzeqlen + tzstringlen - tzvalbufsize + 1, -1, 1);
2196 memcpy (tzvalbuf, "TZ=", tzeqlen);
2199 strcpy (tzvalbuf + tzeqlen, tzstring);
2201 if (!tzvalbuf_in_environ)
2203 xputenv (tzvalbuf);
2204 tzvalbuf_in_environ = 1;
2208 #ifdef LOCALTIME_CACHE
2209 tzset ();
2210 #endif
2213 /* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC
2214 (if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a
2215 type of object is Lisp_String). INHERIT is passed to
2216 INSERT_FROM_STRING_FUNC as the last argument. */
2218 static void
2219 general_insert_function (void (*insert_func)
2220 (const char *, ptrdiff_t),
2221 void (*insert_from_string_func)
2222 (Lisp_Object, ptrdiff_t, ptrdiff_t,
2223 ptrdiff_t, ptrdiff_t, bool),
2224 bool inherit, ptrdiff_t nargs, Lisp_Object *args)
2226 ptrdiff_t argnum;
2227 Lisp_Object val;
2229 for (argnum = 0; argnum < nargs; argnum++)
2231 val = args[argnum];
2232 if (CHARACTERP (val))
2234 int c = XFASTINT (val);
2235 unsigned char str[MAX_MULTIBYTE_LENGTH];
2236 int len;
2238 if (!NILP (BVAR (current_buffer, enable_multibyte_characters)))
2239 len = CHAR_STRING (c, str);
2240 else
2242 str[0] = CHAR_TO_BYTE8 (c);
2243 len = 1;
2245 (*insert_func) ((char *) str, len);
2247 else if (STRINGP (val))
2249 (*insert_from_string_func) (val, 0, 0,
2250 SCHARS (val),
2251 SBYTES (val),
2252 inherit);
2254 else
2255 wrong_type_argument (Qchar_or_string_p, val);
2259 void
2260 insert1 (Lisp_Object arg)
2262 Finsert (1, &arg);
2266 /* Callers passing one argument to Finsert need not gcpro the
2267 argument "array", since the only element of the array will
2268 not be used after calling insert or insert_from_string, so
2269 we don't care if it gets trashed. */
2271 DEFUN ("insert", Finsert, Sinsert, 0, MANY, 0,
2272 doc: /* Insert the arguments, either strings or characters, at point.
2273 Point and before-insertion markers move forward to end up
2274 after the inserted text.
2275 Any other markers at the point of insertion remain before the text.
2277 If the current buffer is multibyte, unibyte strings are converted
2278 to multibyte for insertion (see `string-make-multibyte').
2279 If the current buffer is unibyte, multibyte strings are converted
2280 to unibyte for insertion (see `string-make-unibyte').
2282 When operating on binary data, it may be necessary to preserve the
2283 original bytes of a unibyte string when inserting it into a multibyte
2284 buffer; to accomplish this, apply `string-as-multibyte' to the string
2285 and insert the result.
2287 usage: (insert &rest ARGS) */)
2288 (ptrdiff_t nargs, Lisp_Object *args)
2290 general_insert_function (insert, insert_from_string, 0, nargs, args);
2291 return Qnil;
2294 DEFUN ("insert-and-inherit", Finsert_and_inherit, Sinsert_and_inherit,
2295 0, MANY, 0,
2296 doc: /* Insert the arguments at point, inheriting properties from adjoining text.
2297 Point and before-insertion markers move forward to end up
2298 after the inserted text.
2299 Any other markers at the point of insertion remain before the text.
2301 If the current buffer is multibyte, unibyte strings are converted
2302 to multibyte for insertion (see `unibyte-char-to-multibyte').
2303 If the current buffer is unibyte, multibyte strings are converted
2304 to unibyte for insertion.
2306 usage: (insert-and-inherit &rest ARGS) */)
2307 (ptrdiff_t nargs, Lisp_Object *args)
2309 general_insert_function (insert_and_inherit, insert_from_string, 1,
2310 nargs, args);
2311 return Qnil;
2314 DEFUN ("insert-before-markers", Finsert_before_markers, Sinsert_before_markers, 0, MANY, 0,
2315 doc: /* Insert strings or characters at point, relocating markers after the text.
2316 Point and markers move forward to end up after the inserted text.
2318 If the current buffer is multibyte, unibyte strings are converted
2319 to multibyte for insertion (see `unibyte-char-to-multibyte').
2320 If the current buffer is unibyte, multibyte strings are converted
2321 to unibyte for insertion.
2323 If an overlay begins at the insertion point, the inserted text falls
2324 outside the overlay; if a nonempty overlay ends at the insertion
2325 point, the inserted text falls inside that overlay.
2327 usage: (insert-before-markers &rest ARGS) */)
2328 (ptrdiff_t nargs, Lisp_Object *args)
2330 general_insert_function (insert_before_markers,
2331 insert_from_string_before_markers, 0,
2332 nargs, args);
2333 return Qnil;
2336 DEFUN ("insert-before-markers-and-inherit", Finsert_and_inherit_before_markers,
2337 Sinsert_and_inherit_before_markers, 0, MANY, 0,
2338 doc: /* Insert text at point, relocating markers and inheriting properties.
2339 Point and markers move forward to end up after the inserted text.
2341 If the current buffer is multibyte, unibyte strings are converted
2342 to multibyte for insertion (see `unibyte-char-to-multibyte').
2343 If the current buffer is unibyte, multibyte strings are converted
2344 to unibyte for insertion.
2346 usage: (insert-before-markers-and-inherit &rest ARGS) */)
2347 (ptrdiff_t nargs, Lisp_Object *args)
2349 general_insert_function (insert_before_markers_and_inherit,
2350 insert_from_string_before_markers, 1,
2351 nargs, args);
2352 return Qnil;
2355 DEFUN ("insert-char", Finsert_char, Sinsert_char, 1, 3,
2356 "(list (read-char-by-name \"Insert character (Unicode name or hex): \")\
2357 (prefix-numeric-value current-prefix-arg)\
2358 t))",
2359 doc: /* Insert COUNT copies of CHARACTER.
2360 Interactively, prompt for CHARACTER. You can specify CHARACTER in one
2361 of these ways:
2363 - As its Unicode character name, e.g. \"LATIN SMALL LETTER A\".
2364 Completion is available; if you type a substring of the name
2365 preceded by an asterisk `*', Emacs shows all names which include
2366 that substring, not necessarily at the beginning of the name.
2368 - As a hexadecimal code point, e.g. 263A. Note that code points in
2369 Emacs are equivalent to Unicode up to 10FFFF (which is the limit of
2370 the Unicode code space).
2372 - As a code point with a radix specified with #, e.g. #o21430
2373 (octal), #x2318 (hex), or #10r8984 (decimal).
2375 If called interactively, COUNT is given by the prefix argument. If
2376 omitted or nil, it defaults to 1.
2378 Inserting the character(s) relocates point and before-insertion
2379 markers in the same ways as the function `insert'.
2381 The optional third argument INHERIT, if non-nil, says to inherit text
2382 properties from adjoining text, if those properties are sticky. If
2383 called interactively, INHERIT is t. */)
2384 (Lisp_Object character, Lisp_Object count, Lisp_Object inherit)
2386 int i, stringlen;
2387 register ptrdiff_t n;
2388 int c, len;
2389 unsigned char str[MAX_MULTIBYTE_LENGTH];
2390 char string[4000];
2392 CHECK_CHARACTER (character);
2393 if (NILP (count))
2394 XSETFASTINT (count, 1);
2395 CHECK_NUMBER (count);
2396 c = XFASTINT (character);
2398 if (!NILP (BVAR (current_buffer, enable_multibyte_characters)))
2399 len = CHAR_STRING (c, str);
2400 else
2401 str[0] = c, len = 1;
2402 if (XINT (count) <= 0)
2403 return Qnil;
2404 if (BUF_BYTES_MAX / len < XINT (count))
2405 buffer_overflow ();
2406 n = XINT (count) * len;
2407 stringlen = min (n, sizeof string - sizeof string % len);
2408 for (i = 0; i < stringlen; i++)
2409 string[i] = str[i % len];
2410 while (n > stringlen)
2412 QUIT;
2413 if (!NILP (inherit))
2414 insert_and_inherit (string, stringlen);
2415 else
2416 insert (string, stringlen);
2417 n -= stringlen;
2419 if (!NILP (inherit))
2420 insert_and_inherit (string, n);
2421 else
2422 insert (string, n);
2423 return Qnil;
2426 DEFUN ("insert-byte", Finsert_byte, Sinsert_byte, 2, 3, 0,
2427 doc: /* Insert COUNT (second arg) copies of BYTE (first arg).
2428 Both arguments are required.
2429 BYTE is a number of the range 0..255.
2431 If BYTE is 128..255 and the current buffer is multibyte, the
2432 corresponding eight-bit character is inserted.
2434 Point, and before-insertion markers, are relocated as in the function `insert'.
2435 The optional third arg INHERIT, if non-nil, says to inherit text properties
2436 from adjoining text, if those properties are sticky. */)
2437 (Lisp_Object byte, Lisp_Object count, Lisp_Object inherit)
2439 CHECK_NUMBER (byte);
2440 if (XINT (byte) < 0 || XINT (byte) > 255)
2441 args_out_of_range_3 (byte, make_number (0), make_number (255));
2442 if (XINT (byte) >= 128
2443 && ! NILP (BVAR (current_buffer, enable_multibyte_characters)))
2444 XSETFASTINT (byte, BYTE8_TO_CHAR (XINT (byte)));
2445 return Finsert_char (byte, count, inherit);
2449 /* Making strings from buffer contents. */
2451 /* Return a Lisp_String containing the text of the current buffer from
2452 START to END. If text properties are in use and the current buffer
2453 has properties in the range specified, the resulting string will also
2454 have them, if PROPS is true.
2456 We don't want to use plain old make_string here, because it calls
2457 make_uninit_string, which can cause the buffer arena to be
2458 compacted. make_string has no way of knowing that the data has
2459 been moved, and thus copies the wrong data into the string. This
2460 doesn't effect most of the other users of make_string, so it should
2461 be left as is. But we should use this function when conjuring
2462 buffer substrings. */
2464 Lisp_Object
2465 make_buffer_string (ptrdiff_t start, ptrdiff_t end, bool props)
2467 ptrdiff_t start_byte = CHAR_TO_BYTE (start);
2468 ptrdiff_t end_byte = CHAR_TO_BYTE (end);
2470 return make_buffer_string_both (start, start_byte, end, end_byte, props);
2473 /* Return a Lisp_String containing the text of the current buffer from
2474 START / START_BYTE to END / END_BYTE.
2476 If text properties are in use and the current buffer
2477 has properties in the range specified, the resulting string will also
2478 have them, if PROPS is true.
2480 We don't want to use plain old make_string here, because it calls
2481 make_uninit_string, which can cause the buffer arena to be
2482 compacted. make_string has no way of knowing that the data has
2483 been moved, and thus copies the wrong data into the string. This
2484 doesn't effect most of the other users of make_string, so it should
2485 be left as is. But we should use this function when conjuring
2486 buffer substrings. */
2488 Lisp_Object
2489 make_buffer_string_both (ptrdiff_t start, ptrdiff_t start_byte,
2490 ptrdiff_t end, ptrdiff_t end_byte, bool props)
2492 Lisp_Object result, tem, tem1;
2494 if (start < GPT && GPT < end)
2495 move_gap_both (start, start_byte);
2497 if (! NILP (BVAR (current_buffer, enable_multibyte_characters)))
2498 result = make_uninit_multibyte_string (end - start, end_byte - start_byte);
2499 else
2500 result = make_uninit_string (end - start);
2501 memcpy (SDATA (result), BYTE_POS_ADDR (start_byte), end_byte - start_byte);
2503 /* If desired, update and copy the text properties. */
2504 if (props)
2506 update_buffer_properties (start, end);
2508 tem = Fnext_property_change (make_number (start), Qnil, make_number (end));
2509 tem1 = Ftext_properties_at (make_number (start), Qnil);
2511 if (XINT (tem) != end || !NILP (tem1))
2512 copy_intervals_to_string (result, current_buffer, start,
2513 end - start);
2516 return result;
2519 /* Call Vbuffer_access_fontify_functions for the range START ... END
2520 in the current buffer, if necessary. */
2522 static void
2523 update_buffer_properties (ptrdiff_t start, ptrdiff_t end)
2525 /* If this buffer has some access functions,
2526 call them, specifying the range of the buffer being accessed. */
2527 if (!NILP (Vbuffer_access_fontify_functions))
2529 Lisp_Object args[3];
2530 Lisp_Object tem;
2532 args[0] = Qbuffer_access_fontify_functions;
2533 XSETINT (args[1], start);
2534 XSETINT (args[2], end);
2536 /* But don't call them if we can tell that the work
2537 has already been done. */
2538 if (!NILP (Vbuffer_access_fontified_property))
2540 tem = Ftext_property_any (args[1], args[2],
2541 Vbuffer_access_fontified_property,
2542 Qnil, Qnil);
2543 if (! NILP (tem))
2544 Frun_hook_with_args (3, args);
2546 else
2547 Frun_hook_with_args (3, args);
2551 DEFUN ("buffer-substring", Fbuffer_substring, Sbuffer_substring, 2, 2, 0,
2552 doc: /* Return the contents of part of the current buffer as a string.
2553 The two arguments START and END are character positions;
2554 they can be in either order.
2555 The string returned is multibyte if the buffer is multibyte.
2557 This function copies the text properties of that part of the buffer
2558 into the result string; if you don't want the text properties,
2559 use `buffer-substring-no-properties' instead. */)
2560 (Lisp_Object start, Lisp_Object end)
2562 register ptrdiff_t b, e;
2564 validate_region (&start, &end);
2565 b = XINT (start);
2566 e = XINT (end);
2568 return make_buffer_string (b, e, 1);
2571 DEFUN ("buffer-substring-no-properties", Fbuffer_substring_no_properties,
2572 Sbuffer_substring_no_properties, 2, 2, 0,
2573 doc: /* Return the characters of part of the buffer, without the text properties.
2574 The two arguments START and END are character positions;
2575 they can be in either order. */)
2576 (Lisp_Object start, Lisp_Object end)
2578 register ptrdiff_t b, e;
2580 validate_region (&start, &end);
2581 b = XINT (start);
2582 e = XINT (end);
2584 return make_buffer_string (b, e, 0);
2587 DEFUN ("buffer-string", Fbuffer_string, Sbuffer_string, 0, 0, 0,
2588 doc: /* Return the contents of the current buffer as a string.
2589 If narrowing is in effect, this function returns only the visible part
2590 of the buffer. */)
2591 (void)
2593 return make_buffer_string_both (BEGV, BEGV_BYTE, ZV, ZV_BYTE, 1);
2596 DEFUN ("insert-buffer-substring", Finsert_buffer_substring, Sinsert_buffer_substring,
2597 1, 3, 0,
2598 doc: /* Insert before point a substring of the contents of BUFFER.
2599 BUFFER may be a buffer or a buffer name.
2600 Arguments START and END are character positions specifying the substring.
2601 They default to the values of (point-min) and (point-max) in BUFFER. */)
2602 (Lisp_Object buffer, Lisp_Object start, Lisp_Object end)
2604 register EMACS_INT b, e, temp;
2605 register struct buffer *bp, *obuf;
2606 Lisp_Object buf;
2608 buf = Fget_buffer (buffer);
2609 if (NILP (buf))
2610 nsberror (buffer);
2611 bp = XBUFFER (buf);
2612 if (!BUFFER_LIVE_P (bp))
2613 error ("Selecting deleted buffer");
2615 if (NILP (start))
2616 b = BUF_BEGV (bp);
2617 else
2619 CHECK_NUMBER_COERCE_MARKER (start);
2620 b = XINT (start);
2622 if (NILP (end))
2623 e = BUF_ZV (bp);
2624 else
2626 CHECK_NUMBER_COERCE_MARKER (end);
2627 e = XINT (end);
2630 if (b > e)
2631 temp = b, b = e, e = temp;
2633 if (!(BUF_BEGV (bp) <= b && e <= BUF_ZV (bp)))
2634 args_out_of_range (start, end);
2636 obuf = current_buffer;
2637 set_buffer_internal_1 (bp);
2638 update_buffer_properties (b, e);
2639 set_buffer_internal_1 (obuf);
2641 insert_from_buffer (bp, b, e - b, 0);
2642 return Qnil;
2645 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings, Scompare_buffer_substrings,
2646 6, 6, 0,
2647 doc: /* Compare two substrings of two buffers; return result as number.
2648 Return -N if first string is less after N-1 chars, +N if first string is
2649 greater after N-1 chars, or 0 if strings match. Each substring is
2650 represented as three arguments: BUFFER, START and END. That makes six
2651 args in all, three for each substring.
2653 The value of `case-fold-search' in the current buffer
2654 determines whether case is significant or ignored. */)
2655 (Lisp_Object buffer1, Lisp_Object start1, Lisp_Object end1, Lisp_Object buffer2, Lisp_Object start2, Lisp_Object end2)
2657 register EMACS_INT begp1, endp1, begp2, endp2, temp;
2658 register struct buffer *bp1, *bp2;
2659 register Lisp_Object trt
2660 = (!NILP (BVAR (current_buffer, case_fold_search))
2661 ? BVAR (current_buffer, case_canon_table) : Qnil);
2662 ptrdiff_t chars = 0;
2663 ptrdiff_t i1, i2, i1_byte, i2_byte;
2665 /* Find the first buffer and its substring. */
2667 if (NILP (buffer1))
2668 bp1 = current_buffer;
2669 else
2671 Lisp_Object buf1;
2672 buf1 = Fget_buffer (buffer1);
2673 if (NILP (buf1))
2674 nsberror (buffer1);
2675 bp1 = XBUFFER (buf1);
2676 if (!BUFFER_LIVE_P (bp1))
2677 error ("Selecting deleted buffer");
2680 if (NILP (start1))
2681 begp1 = BUF_BEGV (bp1);
2682 else
2684 CHECK_NUMBER_COERCE_MARKER (start1);
2685 begp1 = XINT (start1);
2687 if (NILP (end1))
2688 endp1 = BUF_ZV (bp1);
2689 else
2691 CHECK_NUMBER_COERCE_MARKER (end1);
2692 endp1 = XINT (end1);
2695 if (begp1 > endp1)
2696 temp = begp1, begp1 = endp1, endp1 = temp;
2698 if (!(BUF_BEGV (bp1) <= begp1
2699 && begp1 <= endp1
2700 && endp1 <= BUF_ZV (bp1)))
2701 args_out_of_range (start1, end1);
2703 /* Likewise for second substring. */
2705 if (NILP (buffer2))
2706 bp2 = current_buffer;
2707 else
2709 Lisp_Object buf2;
2710 buf2 = Fget_buffer (buffer2);
2711 if (NILP (buf2))
2712 nsberror (buffer2);
2713 bp2 = XBUFFER (buf2);
2714 if (!BUFFER_LIVE_P (bp2))
2715 error ("Selecting deleted buffer");
2718 if (NILP (start2))
2719 begp2 = BUF_BEGV (bp2);
2720 else
2722 CHECK_NUMBER_COERCE_MARKER (start2);
2723 begp2 = XINT (start2);
2725 if (NILP (end2))
2726 endp2 = BUF_ZV (bp2);
2727 else
2729 CHECK_NUMBER_COERCE_MARKER (end2);
2730 endp2 = XINT (end2);
2733 if (begp2 > endp2)
2734 temp = begp2, begp2 = endp2, endp2 = temp;
2736 if (!(BUF_BEGV (bp2) <= begp2
2737 && begp2 <= endp2
2738 && endp2 <= BUF_ZV (bp2)))
2739 args_out_of_range (start2, end2);
2741 i1 = begp1;
2742 i2 = begp2;
2743 i1_byte = buf_charpos_to_bytepos (bp1, i1);
2744 i2_byte = buf_charpos_to_bytepos (bp2, i2);
2746 while (i1 < endp1 && i2 < endp2)
2748 /* When we find a mismatch, we must compare the
2749 characters, not just the bytes. */
2750 int c1, c2;
2752 QUIT;
2754 if (! NILP (BVAR (bp1, enable_multibyte_characters)))
2756 c1 = BUF_FETCH_MULTIBYTE_CHAR (bp1, i1_byte);
2757 BUF_INC_POS (bp1, i1_byte);
2758 i1++;
2760 else
2762 c1 = BUF_FETCH_BYTE (bp1, i1);
2763 MAKE_CHAR_MULTIBYTE (c1);
2764 i1++;
2767 if (! NILP (BVAR (bp2, enable_multibyte_characters)))
2769 c2 = BUF_FETCH_MULTIBYTE_CHAR (bp2, i2_byte);
2770 BUF_INC_POS (bp2, i2_byte);
2771 i2++;
2773 else
2775 c2 = BUF_FETCH_BYTE (bp2, i2);
2776 MAKE_CHAR_MULTIBYTE (c2);
2777 i2++;
2780 if (!NILP (trt))
2782 c1 = char_table_translate (trt, c1);
2783 c2 = char_table_translate (trt, c2);
2785 if (c1 < c2)
2786 return make_number (- 1 - chars);
2787 if (c1 > c2)
2788 return make_number (chars + 1);
2790 chars++;
2793 /* The strings match as far as they go.
2794 If one is shorter, that one is less. */
2795 if (chars < endp1 - begp1)
2796 return make_number (chars + 1);
2797 else if (chars < endp2 - begp2)
2798 return make_number (- chars - 1);
2800 /* Same length too => they are equal. */
2801 return make_number (0);
2804 static void
2805 subst_char_in_region_unwind (Lisp_Object arg)
2807 bset_undo_list (current_buffer, arg);
2810 static void
2811 subst_char_in_region_unwind_1 (Lisp_Object arg)
2813 bset_filename (current_buffer, arg);
2816 DEFUN ("subst-char-in-region", Fsubst_char_in_region,
2817 Ssubst_char_in_region, 4, 5, 0,
2818 doc: /* From START to END, replace FROMCHAR with TOCHAR each time it occurs.
2819 If optional arg NOUNDO is non-nil, don't record this change for undo
2820 and don't mark the buffer as really changed.
2821 Both characters must have the same length of multi-byte form. */)
2822 (Lisp_Object start, Lisp_Object end, Lisp_Object fromchar, Lisp_Object tochar, Lisp_Object noundo)
2824 register ptrdiff_t pos, pos_byte, stop, i, len, end_byte;
2825 /* Keep track of the first change in the buffer:
2826 if 0 we haven't found it yet.
2827 if < 0 we've found it and we've run the before-change-function.
2828 if > 0 we've actually performed it and the value is its position. */
2829 ptrdiff_t changed = 0;
2830 unsigned char fromstr[MAX_MULTIBYTE_LENGTH], tostr[MAX_MULTIBYTE_LENGTH];
2831 unsigned char *p;
2832 ptrdiff_t count = SPECPDL_INDEX ();
2833 #define COMBINING_NO 0
2834 #define COMBINING_BEFORE 1
2835 #define COMBINING_AFTER 2
2836 #define COMBINING_BOTH (COMBINING_BEFORE | COMBINING_AFTER)
2837 int maybe_byte_combining = COMBINING_NO;
2838 ptrdiff_t last_changed = 0;
2839 bool multibyte_p
2840 = !NILP (BVAR (current_buffer, enable_multibyte_characters));
2841 int fromc, toc;
2843 restart:
2845 validate_region (&start, &end);
2846 CHECK_CHARACTER (fromchar);
2847 CHECK_CHARACTER (tochar);
2848 fromc = XFASTINT (fromchar);
2849 toc = XFASTINT (tochar);
2851 if (multibyte_p)
2853 len = CHAR_STRING (fromc, fromstr);
2854 if (CHAR_STRING (toc, tostr) != len)
2855 error ("Characters in `subst-char-in-region' have different byte-lengths");
2856 if (!ASCII_CHAR_P (*tostr))
2858 /* If *TOSTR is in the range 0x80..0x9F and TOCHAR is not a
2859 complete multibyte character, it may be combined with the
2860 after bytes. If it is in the range 0xA0..0xFF, it may be
2861 combined with the before and after bytes. */
2862 if (!CHAR_HEAD_P (*tostr))
2863 maybe_byte_combining = COMBINING_BOTH;
2864 else if (BYTES_BY_CHAR_HEAD (*tostr) > len)
2865 maybe_byte_combining = COMBINING_AFTER;
2868 else
2870 len = 1;
2871 fromstr[0] = fromc;
2872 tostr[0] = toc;
2875 pos = XINT (start);
2876 pos_byte = CHAR_TO_BYTE (pos);
2877 stop = CHAR_TO_BYTE (XINT (end));
2878 end_byte = stop;
2880 /* If we don't want undo, turn off putting stuff on the list.
2881 That's faster than getting rid of things,
2882 and it prevents even the entry for a first change.
2883 Also inhibit locking the file. */
2884 if (!changed && !NILP (noundo))
2886 record_unwind_protect (subst_char_in_region_unwind,
2887 BVAR (current_buffer, undo_list));
2888 bset_undo_list (current_buffer, Qt);
2889 /* Don't do file-locking. */
2890 record_unwind_protect (subst_char_in_region_unwind_1,
2891 BVAR (current_buffer, filename));
2892 bset_filename (current_buffer, Qnil);
2895 if (pos_byte < GPT_BYTE)
2896 stop = min (stop, GPT_BYTE);
2897 while (1)
2899 ptrdiff_t pos_byte_next = pos_byte;
2901 if (pos_byte >= stop)
2903 if (pos_byte >= end_byte) break;
2904 stop = end_byte;
2906 p = BYTE_POS_ADDR (pos_byte);
2907 if (multibyte_p)
2908 INC_POS (pos_byte_next);
2909 else
2910 ++pos_byte_next;
2911 if (pos_byte_next - pos_byte == len
2912 && p[0] == fromstr[0]
2913 && (len == 1
2914 || (p[1] == fromstr[1]
2915 && (len == 2 || (p[2] == fromstr[2]
2916 && (len == 3 || p[3] == fromstr[3]))))))
2918 if (changed < 0)
2919 /* We've already seen this and run the before-change-function;
2920 this time we only need to record the actual position. */
2921 changed = pos;
2922 else if (!changed)
2924 changed = -1;
2925 modify_text (pos, XINT (end));
2927 if (! NILP (noundo))
2929 if (MODIFF - 1 == SAVE_MODIFF)
2930 SAVE_MODIFF++;
2931 if (MODIFF - 1 == BUF_AUTOSAVE_MODIFF (current_buffer))
2932 BUF_AUTOSAVE_MODIFF (current_buffer)++;
2935 /* The before-change-function may have moved the gap
2936 or even modified the buffer so we should start over. */
2937 goto restart;
2940 /* Take care of the case where the new character
2941 combines with neighboring bytes. */
2942 if (maybe_byte_combining
2943 && (maybe_byte_combining == COMBINING_AFTER
2944 ? (pos_byte_next < Z_BYTE
2945 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next)))
2946 : ((pos_byte_next < Z_BYTE
2947 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next)))
2948 || (pos_byte > BEG_BYTE
2949 && ! ASCII_CHAR_P (FETCH_BYTE (pos_byte - 1))))))
2951 Lisp_Object tem, string;
2953 struct gcpro gcpro1;
2955 tem = BVAR (current_buffer, undo_list);
2956 GCPRO1 (tem);
2958 /* Make a multibyte string containing this single character. */
2959 string = make_multibyte_string ((char *) tostr, 1, len);
2960 /* replace_range is less efficient, because it moves the gap,
2961 but it handles combining correctly. */
2962 replace_range (pos, pos + 1, string,
2963 0, 0, 1);
2964 pos_byte_next = CHAR_TO_BYTE (pos);
2965 if (pos_byte_next > pos_byte)
2966 /* Before combining happened. We should not increment
2967 POS. So, to cancel the later increment of POS,
2968 decrease it now. */
2969 pos--;
2970 else
2971 INC_POS (pos_byte_next);
2973 if (! NILP (noundo))
2974 bset_undo_list (current_buffer, tem);
2976 UNGCPRO;
2978 else
2980 if (NILP (noundo))
2981 record_change (pos, 1);
2982 for (i = 0; i < len; i++) *p++ = tostr[i];
2984 last_changed = pos + 1;
2986 pos_byte = pos_byte_next;
2987 pos++;
2990 if (changed > 0)
2992 signal_after_change (changed,
2993 last_changed - changed, last_changed - changed);
2994 update_compositions (changed, last_changed, CHECK_ALL);
2997 unbind_to (count, Qnil);
2998 return Qnil;
3002 static Lisp_Object check_translation (ptrdiff_t, ptrdiff_t, ptrdiff_t,
3003 Lisp_Object);
3005 /* Helper function for Ftranslate_region_internal.
3007 Check if a character sequence at POS (POS_BYTE) matches an element
3008 of VAL. VAL is a list (([FROM-CHAR ...] . TO) ...). If a matching
3009 element is found, return it. Otherwise return Qnil. */
3011 static Lisp_Object
3012 check_translation (ptrdiff_t pos, ptrdiff_t pos_byte, ptrdiff_t end,
3013 Lisp_Object val)
3015 int initial_buf[16];
3016 int *buf = initial_buf;
3017 ptrdiff_t buf_size = ARRAYELTS (initial_buf);
3018 int *bufalloc = 0;
3019 ptrdiff_t buf_used = 0;
3020 Lisp_Object result = Qnil;
3022 for (; CONSP (val); val = XCDR (val))
3024 Lisp_Object elt;
3025 ptrdiff_t len, i;
3027 elt = XCAR (val);
3028 if (! CONSP (elt))
3029 continue;
3030 elt = XCAR (elt);
3031 if (! VECTORP (elt))
3032 continue;
3033 len = ASIZE (elt);
3034 if (len <= end - pos)
3036 for (i = 0; i < len; i++)
3038 if (buf_used <= i)
3040 unsigned char *p = BYTE_POS_ADDR (pos_byte);
3041 int len1;
3043 if (buf_used == buf_size)
3045 bufalloc = xpalloc (bufalloc, &buf_size, 1, -1,
3046 sizeof *bufalloc);
3047 if (buf == initial_buf)
3048 memcpy (bufalloc, buf, sizeof initial_buf);
3049 buf = bufalloc;
3051 buf[buf_used++] = STRING_CHAR_AND_LENGTH (p, len1);
3052 pos_byte += len1;
3054 if (XINT (AREF (elt, i)) != buf[i])
3055 break;
3057 if (i == len)
3059 result = XCAR (val);
3060 break;
3065 xfree (bufalloc);
3066 return result;
3070 DEFUN ("translate-region-internal", Ftranslate_region_internal,
3071 Stranslate_region_internal, 3, 3, 0,
3072 doc: /* Internal use only.
3073 From START to END, translate characters according to TABLE.
3074 TABLE is a string or a char-table; the Nth character in it is the
3075 mapping for the character with code N.
3076 It returns the number of characters changed. */)
3077 (Lisp_Object start, Lisp_Object end, register Lisp_Object table)
3079 register unsigned char *tt; /* Trans table. */
3080 register int nc; /* New character. */
3081 int cnt; /* Number of changes made. */
3082 ptrdiff_t size; /* Size of translate table. */
3083 ptrdiff_t pos, pos_byte, end_pos;
3084 bool multibyte = !NILP (BVAR (current_buffer, enable_multibyte_characters));
3085 bool string_multibyte IF_LINT (= 0);
3087 validate_region (&start, &end);
3088 if (CHAR_TABLE_P (table))
3090 if (! EQ (XCHAR_TABLE (table)->purpose, Qtranslation_table))
3091 error ("Not a translation table");
3092 size = MAX_CHAR;
3093 tt = NULL;
3095 else
3097 CHECK_STRING (table);
3099 if (! multibyte && (SCHARS (table) < SBYTES (table)))
3100 table = string_make_unibyte (table);
3101 string_multibyte = SCHARS (table) < SBYTES (table);
3102 size = SBYTES (table);
3103 tt = SDATA (table);
3106 pos = XINT (start);
3107 pos_byte = CHAR_TO_BYTE (pos);
3108 end_pos = XINT (end);
3109 modify_text (pos, end_pos);
3111 cnt = 0;
3112 for (; pos < end_pos; )
3114 register unsigned char *p = BYTE_POS_ADDR (pos_byte);
3115 unsigned char *str, buf[MAX_MULTIBYTE_LENGTH];
3116 int len, str_len;
3117 int oc;
3118 Lisp_Object val;
3120 if (multibyte)
3121 oc = STRING_CHAR_AND_LENGTH (p, len);
3122 else
3123 oc = *p, len = 1;
3124 if (oc < size)
3126 if (tt)
3128 /* Reload as signal_after_change in last iteration may GC. */
3129 tt = SDATA (table);
3130 if (string_multibyte)
3132 str = tt + string_char_to_byte (table, oc);
3133 nc = STRING_CHAR_AND_LENGTH (str, str_len);
3135 else
3137 nc = tt[oc];
3138 if (! ASCII_CHAR_P (nc) && multibyte)
3140 str_len = BYTE8_STRING (nc, buf);
3141 str = buf;
3143 else
3145 str_len = 1;
3146 str = tt + oc;
3150 else
3152 nc = oc;
3153 val = CHAR_TABLE_REF (table, oc);
3154 if (CHARACTERP (val))
3156 nc = XFASTINT (val);
3157 str_len = CHAR_STRING (nc, buf);
3158 str = buf;
3160 else if (VECTORP (val) || (CONSP (val)))
3162 /* VAL is [TO_CHAR ...] or (([FROM-CHAR ...] . TO) ...)
3163 where TO is TO-CHAR or [TO-CHAR ...]. */
3164 nc = -1;
3168 if (nc != oc && nc >= 0)
3170 /* Simple one char to one char translation. */
3171 if (len != str_len)
3173 Lisp_Object string;
3175 /* This is less efficient, because it moves the gap,
3176 but it should handle multibyte characters correctly. */
3177 string = make_multibyte_string ((char *) str, 1, str_len);
3178 replace_range (pos, pos + 1, string, 1, 0, 1);
3179 len = str_len;
3181 else
3183 record_change (pos, 1);
3184 while (str_len-- > 0)
3185 *p++ = *str++;
3186 signal_after_change (pos, 1, 1);
3187 update_compositions (pos, pos + 1, CHECK_BORDER);
3189 ++cnt;
3191 else if (nc < 0)
3193 Lisp_Object string;
3195 if (CONSP (val))
3197 val = check_translation (pos, pos_byte, end_pos, val);
3198 if (NILP (val))
3200 pos_byte += len;
3201 pos++;
3202 continue;
3204 /* VAL is ([FROM-CHAR ...] . TO). */
3205 len = ASIZE (XCAR (val));
3206 val = XCDR (val);
3208 else
3209 len = 1;
3211 if (VECTORP (val))
3213 string = Fconcat (1, &val);
3215 else
3217 string = Fmake_string (make_number (1), val);
3219 replace_range (pos, pos + len, string, 1, 0, 1);
3220 pos_byte += SBYTES (string);
3221 pos += SCHARS (string);
3222 cnt += SCHARS (string);
3223 end_pos += SCHARS (string) - len;
3224 continue;
3227 pos_byte += len;
3228 pos++;
3231 return make_number (cnt);
3234 DEFUN ("delete-region", Fdelete_region, Sdelete_region, 2, 2, "r",
3235 doc: /* Delete the text between START and END.
3236 If called interactively, delete the region between point and mark.
3237 This command deletes buffer text without modifying the kill ring. */)
3238 (Lisp_Object start, Lisp_Object end)
3240 validate_region (&start, &end);
3241 del_range (XINT (start), XINT (end));
3242 return Qnil;
3245 DEFUN ("delete-and-extract-region", Fdelete_and_extract_region,
3246 Sdelete_and_extract_region, 2, 2, 0,
3247 doc: /* Delete the text between START and END and return it. */)
3248 (Lisp_Object start, Lisp_Object end)
3250 validate_region (&start, &end);
3251 if (XINT (start) == XINT (end))
3252 return empty_unibyte_string;
3253 return del_range_1 (XINT (start), XINT (end), 1, 1);
3256 DEFUN ("widen", Fwiden, Swiden, 0, 0, "",
3257 doc: /* Remove restrictions (narrowing) from current buffer.
3258 This allows the buffer's full text to be seen and edited. */)
3259 (void)
3261 if (BEG != BEGV || Z != ZV)
3262 current_buffer->clip_changed = 1;
3263 BEGV = BEG;
3264 BEGV_BYTE = BEG_BYTE;
3265 SET_BUF_ZV_BOTH (current_buffer, Z, Z_BYTE);
3266 /* Changing the buffer bounds invalidates any recorded current column. */
3267 invalidate_current_column ();
3268 return Qnil;
3271 DEFUN ("narrow-to-region", Fnarrow_to_region, Snarrow_to_region, 2, 2, "r",
3272 doc: /* Restrict editing in this buffer to the current region.
3273 The rest of the text becomes temporarily invisible and untouchable
3274 but is not deleted; if you save the buffer in a file, the invisible
3275 text is included in the file. \\[widen] makes all visible again.
3276 See also `save-restriction'.
3278 When calling from a program, pass two arguments; positions (integers
3279 or markers) bounding the text that should remain visible. */)
3280 (register Lisp_Object start, Lisp_Object end)
3282 CHECK_NUMBER_COERCE_MARKER (start);
3283 CHECK_NUMBER_COERCE_MARKER (end);
3285 if (XINT (start) > XINT (end))
3287 Lisp_Object tem;
3288 tem = start; start = end; end = tem;
3291 if (!(BEG <= XINT (start) && XINT (start) <= XINT (end) && XINT (end) <= Z))
3292 args_out_of_range (start, end);
3294 if (BEGV != XFASTINT (start) || ZV != XFASTINT (end))
3295 current_buffer->clip_changed = 1;
3297 SET_BUF_BEGV (current_buffer, XFASTINT (start));
3298 SET_BUF_ZV (current_buffer, XFASTINT (end));
3299 if (PT < XFASTINT (start))
3300 SET_PT (XFASTINT (start));
3301 if (PT > XFASTINT (end))
3302 SET_PT (XFASTINT (end));
3303 /* Changing the buffer bounds invalidates any recorded current column. */
3304 invalidate_current_column ();
3305 return Qnil;
3308 Lisp_Object
3309 save_restriction_save (void)
3311 if (BEGV == BEG && ZV == Z)
3312 /* The common case that the buffer isn't narrowed.
3313 We return just the buffer object, which save_restriction_restore
3314 recognizes as meaning `no restriction'. */
3315 return Fcurrent_buffer ();
3316 else
3317 /* We have to save a restriction, so return a pair of markers, one
3318 for the beginning and one for the end. */
3320 Lisp_Object beg, end;
3322 beg = build_marker (current_buffer, BEGV, BEGV_BYTE);
3323 end = build_marker (current_buffer, ZV, ZV_BYTE);
3325 /* END must move forward if text is inserted at its exact location. */
3326 XMARKER (end)->insertion_type = 1;
3328 return Fcons (beg, end);
3332 void
3333 save_restriction_restore (Lisp_Object data)
3335 struct buffer *cur = NULL;
3336 struct buffer *buf = (CONSP (data)
3337 ? XMARKER (XCAR (data))->buffer
3338 : XBUFFER (data));
3340 if (buf && buf != current_buffer && !NILP (BVAR (buf, pt_marker)))
3341 { /* If `buf' uses markers to keep track of PT, BEGV, and ZV (as
3342 is the case if it is or has an indirect buffer), then make
3343 sure it is current before we update BEGV, so
3344 set_buffer_internal takes care of managing those markers. */
3345 cur = current_buffer;
3346 set_buffer_internal (buf);
3349 if (CONSP (data))
3350 /* A pair of marks bounding a saved restriction. */
3352 struct Lisp_Marker *beg = XMARKER (XCAR (data));
3353 struct Lisp_Marker *end = XMARKER (XCDR (data));
3354 eassert (buf == end->buffer);
3356 if (buf /* Verify marker still points to a buffer. */
3357 && (beg->charpos != BUF_BEGV (buf) || end->charpos != BUF_ZV (buf)))
3358 /* The restriction has changed from the saved one, so restore
3359 the saved restriction. */
3361 ptrdiff_t pt = BUF_PT (buf);
3363 SET_BUF_BEGV_BOTH (buf, beg->charpos, beg->bytepos);
3364 SET_BUF_ZV_BOTH (buf, end->charpos, end->bytepos);
3366 if (pt < beg->charpos || pt > end->charpos)
3367 /* The point is outside the new visible range, move it inside. */
3368 SET_BUF_PT_BOTH (buf,
3369 clip_to_bounds (beg->charpos, pt, end->charpos),
3370 clip_to_bounds (beg->bytepos, BUF_PT_BYTE (buf),
3371 end->bytepos));
3373 buf->clip_changed = 1; /* Remember that the narrowing changed. */
3375 /* These aren't needed anymore, so don't wait for GC. */
3376 free_marker (XCAR (data));
3377 free_marker (XCDR (data));
3378 free_cons (XCONS (data));
3380 else
3381 /* A buffer, which means that there was no old restriction. */
3383 if (buf /* Verify marker still points to a buffer. */
3384 && (BUF_BEGV (buf) != BUF_BEG (buf) || BUF_ZV (buf) != BUF_Z (buf)))
3385 /* The buffer has been narrowed, get rid of the narrowing. */
3387 SET_BUF_BEGV_BOTH (buf, BUF_BEG (buf), BUF_BEG_BYTE (buf));
3388 SET_BUF_ZV_BOTH (buf, BUF_Z (buf), BUF_Z_BYTE (buf));
3390 buf->clip_changed = 1; /* Remember that the narrowing changed. */
3394 /* Changing the buffer bounds invalidates any recorded current column. */
3395 invalidate_current_column ();
3397 if (cur)
3398 set_buffer_internal (cur);
3401 DEFUN ("save-restriction", Fsave_restriction, Ssave_restriction, 0, UNEVALLED, 0,
3402 doc: /* Execute BODY, saving and restoring current buffer's restrictions.
3403 The buffer's restrictions make parts of the beginning and end invisible.
3404 \(They are set up with `narrow-to-region' and eliminated with `widen'.)
3405 This special form, `save-restriction', saves the current buffer's restrictions
3406 when it is entered, and restores them when it is exited.
3407 So any `narrow-to-region' within BODY lasts only until the end of the form.
3408 The old restrictions settings are restored
3409 even in case of abnormal exit (throw or error).
3411 The value returned is the value of the last form in BODY.
3413 Note: if you are using both `save-excursion' and `save-restriction',
3414 use `save-excursion' outermost:
3415 (save-excursion (save-restriction ...))
3417 usage: (save-restriction &rest BODY) */)
3418 (Lisp_Object body)
3420 register Lisp_Object val;
3421 ptrdiff_t count = SPECPDL_INDEX ();
3423 record_unwind_protect (save_restriction_restore, save_restriction_save ());
3424 val = Fprogn (body);
3425 return unbind_to (count, val);
3428 DEFUN ("message", Fmessage, Smessage, 1, MANY, 0,
3429 doc: /* Display a message at the bottom of the screen.
3430 The message also goes into the `*Messages*' buffer, if `message-log-max'
3431 is non-nil. (In keyboard macros, that's all it does.)
3432 Return the message.
3434 In batch mode, the message is printed to the standard error stream,
3435 followed by a newline.
3437 The first argument is a format control string, and the rest are data
3438 to be formatted under control of the string. See `format' for details.
3440 Note: Use (message "%s" VALUE) to print the value of expressions and
3441 variables to avoid accidentally interpreting `%' as format specifiers.
3443 If the first argument is nil or the empty string, the function clears
3444 any existing message; this lets the minibuffer contents show. See
3445 also `current-message'.
3447 usage: (message FORMAT-STRING &rest ARGS) */)
3448 (ptrdiff_t nargs, Lisp_Object *args)
3450 if (NILP (args[0])
3451 || (STRINGP (args[0])
3452 && SBYTES (args[0]) == 0))
3454 message1 (0);
3455 return args[0];
3457 else
3459 register Lisp_Object val;
3460 val = Fformat (nargs, args);
3461 message3 (val);
3462 return val;
3466 DEFUN ("message-box", Fmessage_box, Smessage_box, 1, MANY, 0,
3467 doc: /* Display a message, in a dialog box if possible.
3468 If a dialog box is not available, use the echo area.
3469 The first argument is a format control string, and the rest are data
3470 to be formatted under control of the string. See `format' for details.
3472 If the first argument is nil or the empty string, clear any existing
3473 message; let the minibuffer contents show.
3475 usage: (message-box FORMAT-STRING &rest ARGS) */)
3476 (ptrdiff_t nargs, Lisp_Object *args)
3478 if (NILP (args[0]))
3480 message1 (0);
3481 return Qnil;
3483 else
3485 Lisp_Object val = Fformat (nargs, args);
3486 Lisp_Object pane, menu;
3487 struct gcpro gcpro1;
3489 pane = list1 (Fcons (build_string ("OK"), Qt));
3490 GCPRO1 (pane);
3491 menu = Fcons (val, pane);
3492 Fx_popup_dialog (Qt, menu, Qt);
3493 UNGCPRO;
3494 return val;
3498 DEFUN ("message-or-box", Fmessage_or_box, Smessage_or_box, 1, MANY, 0,
3499 doc: /* Display a message in a dialog box or in the echo area.
3500 If this command was invoked with the mouse, use a dialog box if
3501 `use-dialog-box' is non-nil.
3502 Otherwise, use the echo area.
3503 The first argument is a format control string, and the rest are data
3504 to be formatted under control of the string. See `format' for details.
3506 If the first argument is nil or the empty string, clear any existing
3507 message; let the minibuffer contents show.
3509 usage: (message-or-box FORMAT-STRING &rest ARGS) */)
3510 (ptrdiff_t nargs, Lisp_Object *args)
3512 if ((NILP (last_nonmenu_event) || CONSP (last_nonmenu_event))
3513 && use_dialog_box)
3514 return Fmessage_box (nargs, args);
3515 return Fmessage (nargs, args);
3518 DEFUN ("current-message", Fcurrent_message, Scurrent_message, 0, 0, 0,
3519 doc: /* Return the string currently displayed in the echo area, or nil if none. */)
3520 (void)
3522 return current_message ();
3526 DEFUN ("propertize", Fpropertize, Spropertize, 1, MANY, 0,
3527 doc: /* Return a copy of STRING with text properties added.
3528 First argument is the string to copy.
3529 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
3530 properties to add to the result.
3531 usage: (propertize STRING &rest PROPERTIES) */)
3532 (ptrdiff_t nargs, Lisp_Object *args)
3534 Lisp_Object properties, string;
3535 struct gcpro gcpro1, gcpro2;
3536 ptrdiff_t i;
3538 /* Number of args must be odd. */
3539 if ((nargs & 1) == 0)
3540 error ("Wrong number of arguments");
3542 properties = string = Qnil;
3543 GCPRO2 (properties, string);
3545 /* First argument must be a string. */
3546 CHECK_STRING (args[0]);
3547 string = Fcopy_sequence (args[0]);
3549 for (i = 1; i < nargs; i += 2)
3550 properties = Fcons (args[i], Fcons (args[i + 1], properties));
3552 Fadd_text_properties (make_number (0),
3553 make_number (SCHARS (string)),
3554 properties, string);
3555 RETURN_UNGCPRO (string);
3558 DEFUN ("format", Fformat, Sformat, 1, MANY, 0,
3559 doc: /* Format a string out of a format-string and arguments.
3560 The first argument is a format control string.
3561 The other arguments are substituted into it to make the result, a string.
3563 The format control string may contain %-sequences meaning to substitute
3564 the next available argument:
3566 %s means print a string argument. Actually, prints any object, with `princ'.
3567 %d means print as number in decimal (%o octal, %x hex).
3568 %X is like %x, but uses upper case.
3569 %e means print a number in exponential notation.
3570 %f means print a number in decimal-point notation.
3571 %g means print a number in exponential notation
3572 or decimal-point notation, whichever uses fewer characters.
3573 %c means print a number as a single character.
3574 %S means print any object as an s-expression (using `prin1').
3576 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.
3577 Use %% to put a single % into the output.
3579 A %-sequence may contain optional flag, width, and precision
3580 specifiers, as follows:
3582 %<flags><width><precision>character
3584 where flags is [+ #-0]+, width is [0-9]+, and precision is .[0-9]+
3586 The + flag character inserts a + before any positive number, while a
3587 space inserts a space before any positive number; these flags only
3588 affect %d, %e, %f, and %g sequences, and the + flag takes precedence.
3589 The - and 0 flags affect the width specifier, as described below.
3591 The # flag means to use an alternate display form for %o, %x, %X, %e,
3592 %f, and %g sequences: for %o, it ensures that the result begins with
3593 \"0\"; for %x and %X, it prefixes the result with \"0x\" or \"0X\";
3594 for %e, %f, and %g, it causes a decimal point to be included even if
3595 the precision is zero.
3597 The width specifier supplies a lower limit for the length of the
3598 printed representation. The padding, if any, normally goes on the
3599 left, but it goes on the right if the - flag is present. The padding
3600 character is normally a space, but it is 0 if the 0 flag is present.
3601 The 0 flag is ignored if the - flag is present, or the format sequence
3602 is something other than %d, %e, %f, and %g.
3604 For %e, %f, and %g sequences, the number after the "." in the
3605 precision specifier says how many decimal places to show; if zero, the
3606 decimal point itself is omitted. For %s and %S, the precision
3607 specifier truncates the string to the given width.
3609 usage: (format STRING &rest OBJECTS) */)
3610 (ptrdiff_t nargs, Lisp_Object *args)
3612 ptrdiff_t n; /* The number of the next arg to substitute. */
3613 char initial_buffer[4000];
3614 char *buf = initial_buffer;
3615 ptrdiff_t bufsize = sizeof initial_buffer;
3616 ptrdiff_t max_bufsize = STRING_BYTES_BOUND + 1;
3617 char *p;
3618 ptrdiff_t buf_save_value_index IF_LINT (= 0);
3619 char *format, *end, *format_start;
3620 ptrdiff_t formatlen, nchars;
3621 /* True if the format is multibyte. */
3622 bool multibyte_format = 0;
3623 /* True if the output should be a multibyte string,
3624 which is true if any of the inputs is one. */
3625 bool multibyte = 0;
3626 /* When we make a multibyte string, we must pay attention to the
3627 byte combining problem, i.e., a byte may be combined with a
3628 multibyte character of the previous string. This flag tells if we
3629 must consider such a situation or not. */
3630 bool maybe_combine_byte;
3631 Lisp_Object val;
3632 bool arg_intervals = 0;
3633 USE_SAFE_ALLOCA;
3635 /* discarded[I] is 1 if byte I of the format
3636 string was not copied into the output.
3637 It is 2 if byte I was not the first byte of its character. */
3638 char *discarded;
3640 /* Each element records, for one argument,
3641 the start and end bytepos in the output string,
3642 whether the argument has been converted to string (e.g., due to "%S"),
3643 and whether the argument is a string with intervals.
3644 info[0] is unused. Unused elements have -1 for start. */
3645 struct info
3647 ptrdiff_t start, end;
3648 bool_bf converted_to_string : 1;
3649 bool_bf intervals : 1;
3650 } *info = 0;
3652 /* It should not be necessary to GCPRO ARGS, because
3653 the caller in the interpreter should take care of that. */
3655 CHECK_STRING (args[0]);
3656 format_start = SSDATA (args[0]);
3657 formatlen = SBYTES (args[0]);
3659 /* Allocate the info and discarded tables. */
3661 ptrdiff_t i;
3662 if ((SIZE_MAX - formatlen) / sizeof (struct info) <= nargs)
3663 memory_full (SIZE_MAX);
3664 info = SAFE_ALLOCA ((nargs + 1) * sizeof *info + formatlen);
3665 discarded = (char *) &info[nargs + 1];
3666 for (i = 0; i < nargs + 1; i++)
3668 info[i].start = -1;
3669 info[i].intervals = info[i].converted_to_string = 0;
3671 memset (discarded, 0, formatlen);
3674 /* Try to determine whether the result should be multibyte.
3675 This is not always right; sometimes the result needs to be multibyte
3676 because of an object that we will pass through prin1,
3677 and in that case, we won't know it here. */
3678 multibyte_format = STRING_MULTIBYTE (args[0]);
3679 multibyte = multibyte_format;
3680 for (n = 1; !multibyte && n < nargs; n++)
3681 if (STRINGP (args[n]) && STRING_MULTIBYTE (args[n]))
3682 multibyte = 1;
3684 /* If we start out planning a unibyte result,
3685 then discover it has to be multibyte, we jump back to retry. */
3686 retry:
3688 p = buf;
3689 nchars = 0;
3690 n = 0;
3692 /* Scan the format and store result in BUF. */
3693 format = format_start;
3694 end = format + formatlen;
3695 maybe_combine_byte = 0;
3697 while (format != end)
3699 /* The values of N and FORMAT when the loop body is entered. */
3700 ptrdiff_t n0 = n;
3701 char *format0 = format;
3703 /* Bytes needed to represent the output of this conversion. */
3704 ptrdiff_t convbytes;
3706 if (*format == '%')
3708 /* General format specifications look like
3710 '%' [flags] [field-width] [precision] format
3712 where
3714 flags ::= [-+0# ]+
3715 field-width ::= [0-9]+
3716 precision ::= '.' [0-9]*
3718 If a field-width is specified, it specifies to which width
3719 the output should be padded with blanks, if the output
3720 string is shorter than field-width.
3722 If precision is specified, it specifies the number of
3723 digits to print after the '.' for floats, or the max.
3724 number of chars to print from a string. */
3726 bool minus_flag = 0;
3727 bool plus_flag = 0;
3728 bool space_flag = 0;
3729 bool sharp_flag = 0;
3730 bool zero_flag = 0;
3731 ptrdiff_t field_width;
3732 bool precision_given;
3733 uintmax_t precision = UINTMAX_MAX;
3734 char *num_end;
3735 char conversion;
3737 while (1)
3739 switch (*++format)
3741 case '-': minus_flag = 1; continue;
3742 case '+': plus_flag = 1; continue;
3743 case ' ': space_flag = 1; continue;
3744 case '#': sharp_flag = 1; continue;
3745 case '0': zero_flag = 1; continue;
3747 break;
3750 /* Ignore flags when sprintf ignores them. */
3751 space_flag &= ~ plus_flag;
3752 zero_flag &= ~ minus_flag;
3755 uintmax_t w = strtoumax (format, &num_end, 10);
3756 if (max_bufsize <= w)
3757 string_overflow ();
3758 field_width = w;
3760 precision_given = *num_end == '.';
3761 if (precision_given)
3762 precision = strtoumax (num_end + 1, &num_end, 10);
3763 format = num_end;
3765 if (format == end)
3766 error ("Format string ends in middle of format specifier");
3768 memset (&discarded[format0 - format_start], 1, format - format0);
3769 conversion = *format;
3770 if (conversion == '%')
3771 goto copy_char;
3772 discarded[format - format_start] = 1;
3773 format++;
3775 ++n;
3776 if (! (n < nargs))
3777 error ("Not enough arguments for format string");
3779 /* For 'S', prin1 the argument, and then treat like 's'.
3780 For 's', princ any argument that is not a string or
3781 symbol. But don't do this conversion twice, which might
3782 happen after retrying. */
3783 if ((conversion == 'S'
3784 || (conversion == 's'
3785 && ! STRINGP (args[n]) && ! SYMBOLP (args[n]))))
3787 if (! info[n].converted_to_string)
3789 Lisp_Object noescape = conversion == 'S' ? Qnil : Qt;
3790 args[n] = Fprin1_to_string (args[n], noescape);
3791 info[n].converted_to_string = 1;
3792 if (STRING_MULTIBYTE (args[n]) && ! multibyte)
3794 multibyte = 1;
3795 goto retry;
3798 conversion = 's';
3800 else if (conversion == 'c')
3802 if (FLOATP (args[n]))
3804 double d = XFLOAT_DATA (args[n]);
3805 args[n] = make_number (FIXNUM_OVERFLOW_P (d) ? -1 : d);
3808 if (INTEGERP (args[n]) && ! ASCII_CHAR_P (XINT (args[n])))
3810 if (!multibyte)
3812 multibyte = 1;
3813 goto retry;
3815 args[n] = Fchar_to_string (args[n]);
3816 info[n].converted_to_string = 1;
3819 if (info[n].converted_to_string)
3820 conversion = 's';
3821 zero_flag = 0;
3824 if (SYMBOLP (args[n]))
3826 args[n] = SYMBOL_NAME (args[n]);
3827 if (STRING_MULTIBYTE (args[n]) && ! multibyte)
3829 multibyte = 1;
3830 goto retry;
3834 if (conversion == 's')
3836 /* handle case (precision[n] >= 0) */
3838 ptrdiff_t width, padding, nbytes;
3839 ptrdiff_t nchars_string;
3841 ptrdiff_t prec = -1;
3842 if (precision_given && precision <= TYPE_MAXIMUM (ptrdiff_t))
3843 prec = precision;
3845 /* lisp_string_width ignores a precision of 0, but GNU
3846 libc functions print 0 characters when the precision
3847 is 0. Imitate libc behavior here. Changing
3848 lisp_string_width is the right thing, and will be
3849 done, but meanwhile we work with it. */
3851 if (prec == 0)
3852 width = nchars_string = nbytes = 0;
3853 else
3855 ptrdiff_t nch, nby;
3856 width = lisp_string_width (args[n], prec, &nch, &nby);
3857 if (prec < 0)
3859 nchars_string = SCHARS (args[n]);
3860 nbytes = SBYTES (args[n]);
3862 else
3864 nchars_string = nch;
3865 nbytes = nby;
3869 convbytes = nbytes;
3870 if (convbytes && multibyte && ! STRING_MULTIBYTE (args[n]))
3871 convbytes = count_size_as_multibyte (SDATA (args[n]), nbytes);
3873 padding = width < field_width ? field_width - width : 0;
3875 if (max_bufsize - padding <= convbytes)
3876 string_overflow ();
3877 convbytes += padding;
3878 if (convbytes <= buf + bufsize - p)
3880 if (! minus_flag)
3882 memset (p, ' ', padding);
3883 p += padding;
3884 nchars += padding;
3887 if (p > buf
3888 && multibyte
3889 && !ASCII_CHAR_P (*((unsigned char *) p - 1))
3890 && STRING_MULTIBYTE (args[n])
3891 && !CHAR_HEAD_P (SREF (args[n], 0)))
3892 maybe_combine_byte = 1;
3894 p += copy_text (SDATA (args[n]), (unsigned char *) p,
3895 nbytes,
3896 STRING_MULTIBYTE (args[n]), multibyte);
3898 info[n].start = nchars;
3899 nchars += nchars_string;
3900 info[n].end = nchars;
3902 if (minus_flag)
3904 memset (p, ' ', padding);
3905 p += padding;
3906 nchars += padding;
3909 /* If this argument has text properties, record where
3910 in the result string it appears. */
3911 if (string_intervals (args[n]))
3912 info[n].intervals = arg_intervals = 1;
3914 continue;
3917 else if (! (conversion == 'c' || conversion == 'd'
3918 || conversion == 'e' || conversion == 'f'
3919 || conversion == 'g' || conversion == 'i'
3920 || conversion == 'o' || conversion == 'x'
3921 || conversion == 'X'))
3922 error ("Invalid format operation %%%c",
3923 STRING_CHAR ((unsigned char *) format - 1));
3924 else if (! (INTEGERP (args[n]) || FLOATP (args[n])))
3925 error ("Format specifier doesn't match argument type");
3926 else
3928 enum
3930 /* Maximum precision for a %f conversion such that the
3931 trailing output digit might be nonzero. Any precision
3932 larger than this will not yield useful information. */
3933 USEFUL_PRECISION_MAX =
3934 ((1 - DBL_MIN_EXP)
3935 * (FLT_RADIX == 2 || FLT_RADIX == 10 ? 1
3936 : FLT_RADIX == 16 ? 4
3937 : -1)),
3939 /* Maximum number of bytes generated by any format, if
3940 precision is no more than USEFUL_PRECISION_MAX.
3941 On all practical hosts, %f is the worst case. */
3942 SPRINTF_BUFSIZE =
3943 sizeof "-." + (DBL_MAX_10_EXP + 1) + USEFUL_PRECISION_MAX,
3945 /* Length of pM (that is, of pMd without the
3946 trailing "d"). */
3947 pMlen = sizeof pMd - 2
3949 verify (USEFUL_PRECISION_MAX > 0);
3951 int prec;
3952 ptrdiff_t padding, sprintf_bytes;
3953 uintmax_t excess_precision, numwidth;
3954 uintmax_t leading_zeros = 0, trailing_zeros = 0;
3956 char sprintf_buf[SPRINTF_BUFSIZE];
3958 /* Copy of conversion specification, modified somewhat.
3959 At most three flags F can be specified at once. */
3960 char convspec[sizeof "%FFF.*d" + pMlen];
3962 /* Avoid undefined behavior in underlying sprintf. */
3963 if (conversion == 'd' || conversion == 'i')
3964 sharp_flag = 0;
3966 /* Create the copy of the conversion specification, with
3967 any width and precision removed, with ".*" inserted,
3968 and with pM inserted for integer formats. */
3970 char *f = convspec;
3971 *f++ = '%';
3972 *f = '-'; f += minus_flag;
3973 *f = '+'; f += plus_flag;
3974 *f = ' '; f += space_flag;
3975 *f = '#'; f += sharp_flag;
3976 *f = '0'; f += zero_flag;
3977 *f++ = '.';
3978 *f++ = '*';
3979 if (conversion == 'd' || conversion == 'i'
3980 || conversion == 'o' || conversion == 'x'
3981 || conversion == 'X')
3983 memcpy (f, pMd, pMlen);
3984 f += pMlen;
3985 zero_flag &= ~ precision_given;
3987 *f++ = conversion;
3988 *f = '\0';
3991 prec = -1;
3992 if (precision_given)
3993 prec = min (precision, USEFUL_PRECISION_MAX);
3995 /* Use sprintf to format this number into sprintf_buf. Omit
3996 padding and excess precision, though, because sprintf limits
3997 output length to INT_MAX.
3999 There are four types of conversion: double, unsigned
4000 char (passed as int), wide signed int, and wide
4001 unsigned int. Treat them separately because the
4002 sprintf ABI is sensitive to which type is passed. Be
4003 careful about integer overflow, NaNs, infinities, and
4004 conversions; for example, the min and max macros are
4005 not suitable here. */
4006 if (conversion == 'e' || conversion == 'f' || conversion == 'g')
4008 double x = (INTEGERP (args[n])
4009 ? XINT (args[n])
4010 : XFLOAT_DATA (args[n]));
4011 sprintf_bytes = sprintf (sprintf_buf, convspec, prec, x);
4013 else if (conversion == 'c')
4015 /* Don't use sprintf here, as it might mishandle prec. */
4016 sprintf_buf[0] = XINT (args[n]);
4017 sprintf_bytes = prec != 0;
4019 else if (conversion == 'd')
4021 /* For float, maybe we should use "%1.0f"
4022 instead so it also works for values outside
4023 the integer range. */
4024 printmax_t x;
4025 if (INTEGERP (args[n]))
4026 x = XINT (args[n]);
4027 else
4029 double d = XFLOAT_DATA (args[n]);
4030 if (d < 0)
4032 x = TYPE_MINIMUM (printmax_t);
4033 if (x < d)
4034 x = d;
4036 else
4038 x = TYPE_MAXIMUM (printmax_t);
4039 if (d < x)
4040 x = d;
4043 sprintf_bytes = sprintf (sprintf_buf, convspec, prec, x);
4045 else
4047 /* Don't sign-extend for octal or hex printing. */
4048 uprintmax_t x;
4049 if (INTEGERP (args[n]))
4050 x = XUINT (args[n]);
4051 else
4053 double d = XFLOAT_DATA (args[n]);
4054 if (d < 0)
4055 x = 0;
4056 else
4058 x = TYPE_MAXIMUM (uprintmax_t);
4059 if (d < x)
4060 x = d;
4063 sprintf_bytes = sprintf (sprintf_buf, convspec, prec, x);
4066 /* Now the length of the formatted item is known, except it omits
4067 padding and excess precision. Deal with excess precision
4068 first. This happens only when the format specifies
4069 ridiculously large precision. */
4070 excess_precision = precision - prec;
4071 if (excess_precision)
4073 if (conversion == 'e' || conversion == 'f'
4074 || conversion == 'g')
4076 if ((conversion == 'g' && ! sharp_flag)
4077 || ! ('0' <= sprintf_buf[sprintf_bytes - 1]
4078 && sprintf_buf[sprintf_bytes - 1] <= '9'))
4079 excess_precision = 0;
4080 else
4082 if (conversion == 'g')
4084 char *dot = strchr (sprintf_buf, '.');
4085 if (!dot)
4086 excess_precision = 0;
4089 trailing_zeros = excess_precision;
4091 else
4092 leading_zeros = excess_precision;
4095 /* Compute the total bytes needed for this item, including
4096 excess precision and padding. */
4097 numwidth = sprintf_bytes + excess_precision;
4098 padding = numwidth < field_width ? field_width - numwidth : 0;
4099 if (max_bufsize - sprintf_bytes <= excess_precision
4100 || max_bufsize - padding <= numwidth)
4101 string_overflow ();
4102 convbytes = numwidth + padding;
4104 if (convbytes <= buf + bufsize - p)
4106 /* Copy the formatted item from sprintf_buf into buf,
4107 inserting padding and excess-precision zeros. */
4109 char *src = sprintf_buf;
4110 char src0 = src[0];
4111 int exponent_bytes = 0;
4112 bool signedp = src0 == '-' || src0 == '+' || src0 == ' ';
4113 int significand_bytes;
4114 if (zero_flag
4115 && ((src[signedp] >= '0' && src[signedp] <= '9')
4116 || (src[signedp] >= 'a' && src[signedp] <= 'f')
4117 || (src[signedp] >= 'A' && src[signedp] <= 'F')))
4119 leading_zeros += padding;
4120 padding = 0;
4123 if (excess_precision
4124 && (conversion == 'e' || conversion == 'g'))
4126 char *e = strchr (src, 'e');
4127 if (e)
4128 exponent_bytes = src + sprintf_bytes - e;
4131 if (! minus_flag)
4133 memset (p, ' ', padding);
4134 p += padding;
4135 nchars += padding;
4138 *p = src0;
4139 src += signedp;
4140 p += signedp;
4141 memset (p, '0', leading_zeros);
4142 p += leading_zeros;
4143 significand_bytes = sprintf_bytes - signedp - exponent_bytes;
4144 memcpy (p, src, significand_bytes);
4145 p += significand_bytes;
4146 src += significand_bytes;
4147 memset (p, '0', trailing_zeros);
4148 p += trailing_zeros;
4149 memcpy (p, src, exponent_bytes);
4150 p += exponent_bytes;
4152 info[n].start = nchars;
4153 nchars += leading_zeros + sprintf_bytes + trailing_zeros;
4154 info[n].end = nchars;
4156 if (minus_flag)
4158 memset (p, ' ', padding);
4159 p += padding;
4160 nchars += padding;
4163 continue;
4167 else
4168 copy_char:
4170 /* Copy a single character from format to buf. */
4172 char *src = format;
4173 unsigned char str[MAX_MULTIBYTE_LENGTH];
4175 if (multibyte_format)
4177 /* Copy a whole multibyte character. */
4178 if (p > buf
4179 && !ASCII_CHAR_P (*((unsigned char *) p - 1))
4180 && !CHAR_HEAD_P (*format))
4181 maybe_combine_byte = 1;
4184 format++;
4185 while (! CHAR_HEAD_P (*format));
4187 convbytes = format - src;
4188 memset (&discarded[src + 1 - format_start], 2, convbytes - 1);
4190 else
4192 unsigned char uc = *format++;
4193 if (! multibyte || ASCII_CHAR_P (uc))
4194 convbytes = 1;
4195 else
4197 int c = BYTE8_TO_CHAR (uc);
4198 convbytes = CHAR_STRING (c, str);
4199 src = (char *) str;
4203 if (convbytes <= buf + bufsize - p)
4205 memcpy (p, src, convbytes);
4206 p += convbytes;
4207 nchars++;
4208 continue;
4212 /* There wasn't enough room to store this conversion or single
4213 character. CONVBYTES says how much room is needed. Allocate
4214 enough room (and then some) and do it again. */
4216 ptrdiff_t used = p - buf;
4218 if (max_bufsize - used < convbytes)
4219 string_overflow ();
4220 bufsize = used + convbytes;
4221 bufsize = bufsize < max_bufsize / 2 ? bufsize * 2 : max_bufsize;
4223 if (buf == initial_buffer)
4225 buf = xmalloc (bufsize);
4226 sa_must_free = true;
4227 buf_save_value_index = SPECPDL_INDEX ();
4228 record_unwind_protect_ptr (xfree, buf);
4229 memcpy (buf, initial_buffer, used);
4231 else
4233 buf = xrealloc (buf, bufsize);
4234 set_unwind_protect_ptr (buf_save_value_index, xfree, buf);
4237 p = buf + used;
4240 format = format0;
4241 n = n0;
4244 if (bufsize < p - buf)
4245 emacs_abort ();
4247 if (maybe_combine_byte)
4248 nchars = multibyte_chars_in_text ((unsigned char *) buf, p - buf);
4249 val = make_specified_string (buf, nchars, p - buf, multibyte);
4251 /* If we allocated BUF with malloc, free it too. */
4252 SAFE_FREE ();
4254 /* If the format string has text properties, or any of the string
4255 arguments has text properties, set up text properties of the
4256 result string. */
4258 if (string_intervals (args[0]) || arg_intervals)
4260 Lisp_Object len, new_len, props;
4261 struct gcpro gcpro1;
4263 /* Add text properties from the format string. */
4264 len = make_number (SCHARS (args[0]));
4265 props = text_property_list (args[0], make_number (0), len, Qnil);
4266 GCPRO1 (props);
4268 if (CONSP (props))
4270 ptrdiff_t bytepos = 0, position = 0, translated = 0;
4271 ptrdiff_t argn = 1;
4272 Lisp_Object list;
4274 /* Adjust the bounds of each text property
4275 to the proper start and end in the output string. */
4277 /* Put the positions in PROPS in increasing order, so that
4278 we can do (effectively) one scan through the position
4279 space of the format string. */
4280 props = Fnreverse (props);
4282 /* BYTEPOS is the byte position in the format string,
4283 POSITION is the untranslated char position in it,
4284 TRANSLATED is the translated char position in BUF,
4285 and ARGN is the number of the next arg we will come to. */
4286 for (list = props; CONSP (list); list = XCDR (list))
4288 Lisp_Object item;
4289 ptrdiff_t pos;
4291 item = XCAR (list);
4293 /* First adjust the property start position. */
4294 pos = XINT (XCAR (item));
4296 /* Advance BYTEPOS, POSITION, TRANSLATED and ARGN
4297 up to this position. */
4298 for (; position < pos; bytepos++)
4300 if (! discarded[bytepos])
4301 position++, translated++;
4302 else if (discarded[bytepos] == 1)
4304 position++;
4305 if (translated == info[argn].start)
4307 translated += info[argn].end - info[argn].start;
4308 argn++;
4313 XSETCAR (item, make_number (translated));
4315 /* Likewise adjust the property end position. */
4316 pos = XINT (XCAR (XCDR (item)));
4318 for (; position < pos; bytepos++)
4320 if (! discarded[bytepos])
4321 position++, translated++;
4322 else if (discarded[bytepos] == 1)
4324 position++;
4325 if (translated == info[argn].start)
4327 translated += info[argn].end - info[argn].start;
4328 argn++;
4333 XSETCAR (XCDR (item), make_number (translated));
4336 add_text_properties_from_list (val, props, make_number (0));
4339 /* Add text properties from arguments. */
4340 if (arg_intervals)
4341 for (n = 1; n < nargs; ++n)
4342 if (info[n].intervals)
4344 len = make_number (SCHARS (args[n]));
4345 new_len = make_number (info[n].end - info[n].start);
4346 props = text_property_list (args[n], make_number (0), len, Qnil);
4347 props = extend_property_ranges (props, new_len);
4348 /* If successive arguments have properties, be sure that
4349 the value of `composition' property be the copy. */
4350 if (n > 1 && info[n - 1].end)
4351 make_composition_value_copy (props);
4352 add_text_properties_from_list (val, props,
4353 make_number (info[n].start));
4356 UNGCPRO;
4359 return val;
4362 Lisp_Object
4363 format2 (const char *string1, Lisp_Object arg0, Lisp_Object arg1)
4365 AUTO_STRING (format, string1);
4366 return Fformat (3, (Lisp_Object []) {format, arg0, arg1});
4369 DEFUN ("char-equal", Fchar_equal, Schar_equal, 2, 2, 0,
4370 doc: /* Return t if two characters match, optionally ignoring case.
4371 Both arguments must be characters (i.e. integers).
4372 Case is ignored if `case-fold-search' is non-nil in the current buffer. */)
4373 (register Lisp_Object c1, Lisp_Object c2)
4375 int i1, i2;
4376 /* Check they're chars, not just integers, otherwise we could get array
4377 bounds violations in downcase. */
4378 CHECK_CHARACTER (c1);
4379 CHECK_CHARACTER (c2);
4381 if (XINT (c1) == XINT (c2))
4382 return Qt;
4383 if (NILP (BVAR (current_buffer, case_fold_search)))
4384 return Qnil;
4386 i1 = XFASTINT (c1);
4387 i2 = XFASTINT (c2);
4389 /* FIXME: It is possible to compare multibyte characters even when
4390 the current buffer is unibyte. Unfortunately this is ambiguous
4391 for characters between 128 and 255, as they could be either
4392 eight-bit raw bytes or Latin-1 characters. Assume the former for
4393 now. See Bug#17011, and also see casefiddle.c's casify_object,
4394 which has a similar problem. */
4395 if (NILP (BVAR (current_buffer, enable_multibyte_characters)))
4397 if (SINGLE_BYTE_CHAR_P (i1))
4398 i1 = UNIBYTE_TO_CHAR (i1);
4399 if (SINGLE_BYTE_CHAR_P (i2))
4400 i2 = UNIBYTE_TO_CHAR (i2);
4403 return (downcase (i1) == downcase (i2) ? Qt : Qnil);
4406 /* Transpose the markers in two regions of the current buffer, and
4407 adjust the ones between them if necessary (i.e.: if the regions
4408 differ in size).
4410 START1, END1 are the character positions of the first region.
4411 START1_BYTE, END1_BYTE are the byte positions.
4412 START2, END2 are the character positions of the second region.
4413 START2_BYTE, END2_BYTE are the byte positions.
4415 Traverses the entire marker list of the buffer to do so, adding an
4416 appropriate amount to some, subtracting from some, and leaving the
4417 rest untouched. Most of this is copied from adjust_markers in insdel.c.
4419 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
4421 static void
4422 transpose_markers (ptrdiff_t start1, ptrdiff_t end1,
4423 ptrdiff_t start2, ptrdiff_t end2,
4424 ptrdiff_t start1_byte, ptrdiff_t end1_byte,
4425 ptrdiff_t start2_byte, ptrdiff_t end2_byte)
4427 register ptrdiff_t amt1, amt1_byte, amt2, amt2_byte, diff, diff_byte, mpos;
4428 register struct Lisp_Marker *marker;
4430 /* Update point as if it were a marker. */
4431 if (PT < start1)
4433 else if (PT < end1)
4434 TEMP_SET_PT_BOTH (PT + (end2 - end1),
4435 PT_BYTE + (end2_byte - end1_byte));
4436 else if (PT < start2)
4437 TEMP_SET_PT_BOTH (PT + (end2 - start2) - (end1 - start1),
4438 (PT_BYTE + (end2_byte - start2_byte)
4439 - (end1_byte - start1_byte)));
4440 else if (PT < end2)
4441 TEMP_SET_PT_BOTH (PT - (start2 - start1),
4442 PT_BYTE - (start2_byte - start1_byte));
4444 /* We used to adjust the endpoints here to account for the gap, but that
4445 isn't good enough. Even if we assume the caller has tried to move the
4446 gap out of our way, it might still be at start1 exactly, for example;
4447 and that places it `inside' the interval, for our purposes. The amount
4448 of adjustment is nontrivial if there's a `denormalized' marker whose
4449 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
4450 the dirty work to Fmarker_position, below. */
4452 /* The difference between the region's lengths */
4453 diff = (end2 - start2) - (end1 - start1);
4454 diff_byte = (end2_byte - start2_byte) - (end1_byte - start1_byte);
4456 /* For shifting each marker in a region by the length of the other
4457 region plus the distance between the regions. */
4458 amt1 = (end2 - start2) + (start2 - end1);
4459 amt2 = (end1 - start1) + (start2 - end1);
4460 amt1_byte = (end2_byte - start2_byte) + (start2_byte - end1_byte);
4461 amt2_byte = (end1_byte - start1_byte) + (start2_byte - end1_byte);
4463 for (marker = BUF_MARKERS (current_buffer); marker; marker = marker->next)
4465 mpos = marker->bytepos;
4466 if (mpos >= start1_byte && mpos < end2_byte)
4468 if (mpos < end1_byte)
4469 mpos += amt1_byte;
4470 else if (mpos < start2_byte)
4471 mpos += diff_byte;
4472 else
4473 mpos -= amt2_byte;
4474 marker->bytepos = mpos;
4476 mpos = marker->charpos;
4477 if (mpos >= start1 && mpos < end2)
4479 if (mpos < end1)
4480 mpos += amt1;
4481 else if (mpos < start2)
4482 mpos += diff;
4483 else
4484 mpos -= amt2;
4486 marker->charpos = mpos;
4490 DEFUN ("transpose-regions", Ftranspose_regions, Stranspose_regions, 4, 5, 0,
4491 doc: /* Transpose region STARTR1 to ENDR1 with STARTR2 to ENDR2.
4492 The regions should not be overlapping, because the size of the buffer is
4493 never changed in a transposition.
4495 Optional fifth arg LEAVE-MARKERS, if non-nil, means don't update
4496 any markers that happen to be located in the regions.
4498 Transposing beyond buffer boundaries is an error. */)
4499 (Lisp_Object startr1, Lisp_Object endr1, Lisp_Object startr2, Lisp_Object endr2, Lisp_Object leave_markers)
4501 register ptrdiff_t start1, end1, start2, end2;
4502 ptrdiff_t start1_byte, start2_byte, len1_byte, len2_byte, end2_byte;
4503 ptrdiff_t gap, len1, len_mid, len2;
4504 unsigned char *start1_addr, *start2_addr, *temp;
4506 INTERVAL cur_intv, tmp_interval1, tmp_interval_mid, tmp_interval2, tmp_interval3;
4507 Lisp_Object buf;
4509 XSETBUFFER (buf, current_buffer);
4510 cur_intv = buffer_intervals (current_buffer);
4512 validate_region (&startr1, &endr1);
4513 validate_region (&startr2, &endr2);
4515 start1 = XFASTINT (startr1);
4516 end1 = XFASTINT (endr1);
4517 start2 = XFASTINT (startr2);
4518 end2 = XFASTINT (endr2);
4519 gap = GPT;
4521 /* Swap the regions if they're reversed. */
4522 if (start2 < end1)
4524 register ptrdiff_t glumph = start1;
4525 start1 = start2;
4526 start2 = glumph;
4527 glumph = end1;
4528 end1 = end2;
4529 end2 = glumph;
4532 len1 = end1 - start1;
4533 len2 = end2 - start2;
4535 if (start2 < end1)
4536 error ("Transposed regions overlap");
4537 /* Nothing to change for adjacent regions with one being empty */
4538 else if ((start1 == end1 || start2 == end2) && end1 == start2)
4539 return Qnil;
4541 /* The possibilities are:
4542 1. Adjacent (contiguous) regions, or separate but equal regions
4543 (no, really equal, in this case!), or
4544 2. Separate regions of unequal size.
4546 The worst case is usually No. 2. It means that (aside from
4547 potential need for getting the gap out of the way), there also
4548 needs to be a shifting of the text between the two regions. So
4549 if they are spread far apart, we are that much slower... sigh. */
4551 /* It must be pointed out that the really studly thing to do would
4552 be not to move the gap at all, but to leave it in place and work
4553 around it if necessary. This would be extremely efficient,
4554 especially considering that people are likely to do
4555 transpositions near where they are working interactively, which
4556 is exactly where the gap would be found. However, such code
4557 would be much harder to write and to read. So, if you are
4558 reading this comment and are feeling squirrely, by all means have
4559 a go! I just didn't feel like doing it, so I will simply move
4560 the gap the minimum distance to get it out of the way, and then
4561 deal with an unbroken array. */
4563 start1_byte = CHAR_TO_BYTE (start1);
4564 end2_byte = CHAR_TO_BYTE (end2);
4566 /* Make sure the gap won't interfere, by moving it out of the text
4567 we will operate on. */
4568 if (start1 < gap && gap < end2)
4570 if (gap - start1 < end2 - gap)
4571 move_gap_both (start1, start1_byte);
4572 else
4573 move_gap_both (end2, end2_byte);
4576 start2_byte = CHAR_TO_BYTE (start2);
4577 len1_byte = CHAR_TO_BYTE (end1) - start1_byte;
4578 len2_byte = end2_byte - start2_byte;
4580 #ifdef BYTE_COMBINING_DEBUG
4581 if (end1 == start2)
4583 if (count_combining_before (BYTE_POS_ADDR (start2_byte),
4584 len2_byte, start1, start1_byte)
4585 || count_combining_before (BYTE_POS_ADDR (start1_byte),
4586 len1_byte, end2, start2_byte + len2_byte)
4587 || count_combining_after (BYTE_POS_ADDR (start1_byte),
4588 len1_byte, end2, start2_byte + len2_byte))
4589 emacs_abort ();
4591 else
4593 if (count_combining_before (BYTE_POS_ADDR (start2_byte),
4594 len2_byte, start1, start1_byte)
4595 || count_combining_before (BYTE_POS_ADDR (start1_byte),
4596 len1_byte, start2, start2_byte)
4597 || count_combining_after (BYTE_POS_ADDR (start2_byte),
4598 len2_byte, end1, start1_byte + len1_byte)
4599 || count_combining_after (BYTE_POS_ADDR (start1_byte),
4600 len1_byte, end2, start2_byte + len2_byte))
4601 emacs_abort ();
4603 #endif
4605 /* Hmmm... how about checking to see if the gap is large
4606 enough to use as the temporary storage? That would avoid an
4607 allocation... interesting. Later, don't fool with it now. */
4609 /* Working without memmove, for portability (sigh), so must be
4610 careful of overlapping subsections of the array... */
4612 if (end1 == start2) /* adjacent regions */
4614 modify_text (start1, end2);
4615 record_change (start1, len1 + len2);
4617 tmp_interval1 = copy_intervals (cur_intv, start1, len1);
4618 tmp_interval2 = copy_intervals (cur_intv, start2, len2);
4619 /* Don't use Fset_text_properties: that can cause GC, which can
4620 clobber objects stored in the tmp_intervals. */
4621 tmp_interval3 = validate_interval_range (buf, &startr1, &endr2, 0);
4622 if (tmp_interval3)
4623 set_text_properties_1 (startr1, endr2, Qnil, buf, tmp_interval3);
4625 USE_SAFE_ALLOCA;
4627 /* First region smaller than second. */
4628 if (len1_byte < len2_byte)
4630 temp = SAFE_ALLOCA (len2_byte);
4632 /* Don't precompute these addresses. We have to compute them
4633 at the last minute, because the relocating allocator might
4634 have moved the buffer around during the xmalloc. */
4635 start1_addr = BYTE_POS_ADDR (start1_byte);
4636 start2_addr = BYTE_POS_ADDR (start2_byte);
4638 memcpy (temp, start2_addr, len2_byte);
4639 memcpy (start1_addr + len2_byte, start1_addr, len1_byte);
4640 memcpy (start1_addr, temp, len2_byte);
4642 else
4643 /* First region not smaller than second. */
4645 temp = SAFE_ALLOCA (len1_byte);
4646 start1_addr = BYTE_POS_ADDR (start1_byte);
4647 start2_addr = BYTE_POS_ADDR (start2_byte);
4648 memcpy (temp, start1_addr, len1_byte);
4649 memcpy (start1_addr, start2_addr, len2_byte);
4650 memcpy (start1_addr + len2_byte, temp, len1_byte);
4653 SAFE_FREE ();
4654 graft_intervals_into_buffer (tmp_interval1, start1 + len2,
4655 len1, current_buffer, 0);
4656 graft_intervals_into_buffer (tmp_interval2, start1,
4657 len2, current_buffer, 0);
4658 update_compositions (start1, start1 + len2, CHECK_BORDER);
4659 update_compositions (start1 + len2, end2, CHECK_TAIL);
4661 /* Non-adjacent regions, because end1 != start2, bleagh... */
4662 else
4664 len_mid = start2_byte - (start1_byte + len1_byte);
4666 if (len1_byte == len2_byte)
4667 /* Regions are same size, though, how nice. */
4669 USE_SAFE_ALLOCA;
4671 modify_text (start1, end1);
4672 modify_text (start2, end2);
4673 record_change (start1, len1);
4674 record_change (start2, len2);
4675 tmp_interval1 = copy_intervals (cur_intv, start1, len1);
4676 tmp_interval2 = copy_intervals (cur_intv, start2, len2);
4678 tmp_interval3 = validate_interval_range (buf, &startr1, &endr1, 0);
4679 if (tmp_interval3)
4680 set_text_properties_1 (startr1, endr1, Qnil, buf, tmp_interval3);
4682 tmp_interval3 = validate_interval_range (buf, &startr2, &endr2, 0);
4683 if (tmp_interval3)
4684 set_text_properties_1 (startr2, endr2, Qnil, buf, tmp_interval3);
4686 temp = SAFE_ALLOCA (len1_byte);
4687 start1_addr = BYTE_POS_ADDR (start1_byte);
4688 start2_addr = BYTE_POS_ADDR (start2_byte);
4689 memcpy (temp, start1_addr, len1_byte);
4690 memcpy (start1_addr, start2_addr, len2_byte);
4691 memcpy (start2_addr, temp, len1_byte);
4692 SAFE_FREE ();
4694 graft_intervals_into_buffer (tmp_interval1, start2,
4695 len1, current_buffer, 0);
4696 graft_intervals_into_buffer (tmp_interval2, start1,
4697 len2, current_buffer, 0);
4700 else if (len1_byte < len2_byte) /* Second region larger than first */
4701 /* Non-adjacent & unequal size, area between must also be shifted. */
4703 USE_SAFE_ALLOCA;
4705 modify_text (start1, end2);
4706 record_change (start1, (end2 - start1));
4707 tmp_interval1 = copy_intervals (cur_intv, start1, len1);
4708 tmp_interval_mid = copy_intervals (cur_intv, end1, len_mid);
4709 tmp_interval2 = copy_intervals (cur_intv, start2, len2);
4711 tmp_interval3 = validate_interval_range (buf, &startr1, &endr2, 0);
4712 if (tmp_interval3)
4713 set_text_properties_1 (startr1, endr2, Qnil, buf, tmp_interval3);
4715 /* holds region 2 */
4716 temp = SAFE_ALLOCA (len2_byte);
4717 start1_addr = BYTE_POS_ADDR (start1_byte);
4718 start2_addr = BYTE_POS_ADDR (start2_byte);
4719 memcpy (temp, start2_addr, len2_byte);
4720 memcpy (start1_addr + len_mid + len2_byte, start1_addr, len1_byte);
4721 memmove (start1_addr + len2_byte, start1_addr + len1_byte, len_mid);
4722 memcpy (start1_addr, temp, len2_byte);
4723 SAFE_FREE ();
4725 graft_intervals_into_buffer (tmp_interval1, end2 - len1,
4726 len1, current_buffer, 0);
4727 graft_intervals_into_buffer (tmp_interval_mid, start1 + len2,
4728 len_mid, current_buffer, 0);
4729 graft_intervals_into_buffer (tmp_interval2, start1,
4730 len2, current_buffer, 0);
4732 else
4733 /* Second region smaller than first. */
4735 USE_SAFE_ALLOCA;
4737 record_change (start1, (end2 - start1));
4738 modify_text (start1, end2);
4740 tmp_interval1 = copy_intervals (cur_intv, start1, len1);
4741 tmp_interval_mid = copy_intervals (cur_intv, end1, len_mid);
4742 tmp_interval2 = copy_intervals (cur_intv, start2, len2);
4744 tmp_interval3 = validate_interval_range (buf, &startr1, &endr2, 0);
4745 if (tmp_interval3)
4746 set_text_properties_1 (startr1, endr2, Qnil, buf, tmp_interval3);
4748 /* holds region 1 */
4749 temp = SAFE_ALLOCA (len1_byte);
4750 start1_addr = BYTE_POS_ADDR (start1_byte);
4751 start2_addr = BYTE_POS_ADDR (start2_byte);
4752 memcpy (temp, start1_addr, len1_byte);
4753 memcpy (start1_addr, start2_addr, len2_byte);
4754 memcpy (start1_addr + len2_byte, start1_addr + len1_byte, len_mid);
4755 memcpy (start1_addr + len2_byte + len_mid, temp, len1_byte);
4756 SAFE_FREE ();
4758 graft_intervals_into_buffer (tmp_interval1, end2 - len1,
4759 len1, current_buffer, 0);
4760 graft_intervals_into_buffer (tmp_interval_mid, start1 + len2,
4761 len_mid, current_buffer, 0);
4762 graft_intervals_into_buffer (tmp_interval2, start1,
4763 len2, current_buffer, 0);
4766 update_compositions (start1, start1 + len2, CHECK_BORDER);
4767 update_compositions (end2 - len1, end2, CHECK_BORDER);
4770 /* When doing multiple transpositions, it might be nice
4771 to optimize this. Perhaps the markers in any one buffer
4772 should be organized in some sorted data tree. */
4773 if (NILP (leave_markers))
4775 transpose_markers (start1, end1, start2, end2,
4776 start1_byte, start1_byte + len1_byte,
4777 start2_byte, start2_byte + len2_byte);
4778 fix_start_end_in_overlays (start1, end2);
4781 signal_after_change (start1, end2 - start1, end2 - start1);
4782 return Qnil;
4786 void
4787 syms_of_editfns (void)
4789 DEFSYM (Qbuffer_access_fontify_functions, "buffer-access-fontify-functions");
4791 DEFVAR_LISP ("inhibit-field-text-motion", Vinhibit_field_text_motion,
4792 doc: /* Non-nil means text motion commands don't notice fields. */);
4793 Vinhibit_field_text_motion = Qnil;
4795 DEFVAR_LISP ("buffer-access-fontify-functions",
4796 Vbuffer_access_fontify_functions,
4797 doc: /* List of functions called by `buffer-substring' to fontify if necessary.
4798 Each function is called with two arguments which specify the range
4799 of the buffer being accessed. */);
4800 Vbuffer_access_fontify_functions = Qnil;
4803 Lisp_Object obuf;
4804 obuf = Fcurrent_buffer ();
4805 /* Do this here, because init_buffer_once is too early--it won't work. */
4806 Fset_buffer (Vprin1_to_string_buffer);
4807 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
4808 Fset (Fmake_local_variable (intern_c_string ("buffer-access-fontify-functions")),
4809 Qnil);
4810 Fset_buffer (obuf);
4813 DEFVAR_LISP ("buffer-access-fontified-property",
4814 Vbuffer_access_fontified_property,
4815 doc: /* Property which (if non-nil) indicates text has been fontified.
4816 `buffer-substring' need not call the `buffer-access-fontify-functions'
4817 functions if all the text being accessed has this property. */);
4818 Vbuffer_access_fontified_property = Qnil;
4820 DEFVAR_LISP ("system-name", Vsystem_name,
4821 doc: /* The host name of the machine Emacs is running on. */);
4823 DEFVAR_LISP ("user-full-name", Vuser_full_name,
4824 doc: /* The full name of the user logged in. */);
4826 DEFVAR_LISP ("user-login-name", Vuser_login_name,
4827 doc: /* The user's name, taken from environment variables if possible. */);
4829 DEFVAR_LISP ("user-real-login-name", Vuser_real_login_name,
4830 doc: /* The user's name, based upon the real uid only. */);
4832 DEFVAR_LISP ("operating-system-release", Voperating_system_release,
4833 doc: /* The release of the operating system Emacs is running on. */);
4835 defsubr (&Spropertize);
4836 defsubr (&Schar_equal);
4837 defsubr (&Sgoto_char);
4838 defsubr (&Sstring_to_char);
4839 defsubr (&Schar_to_string);
4840 defsubr (&Sbyte_to_string);
4841 defsubr (&Sbuffer_substring);
4842 defsubr (&Sbuffer_substring_no_properties);
4843 defsubr (&Sbuffer_string);
4844 defsubr (&Sget_pos_property);
4846 defsubr (&Spoint_marker);
4847 defsubr (&Smark_marker);
4848 defsubr (&Spoint);
4849 defsubr (&Sregion_beginning);
4850 defsubr (&Sregion_end);
4852 DEFSYM (Qfield, "field");
4853 DEFSYM (Qboundary, "boundary");
4854 defsubr (&Sfield_beginning);
4855 defsubr (&Sfield_end);
4856 defsubr (&Sfield_string);
4857 defsubr (&Sfield_string_no_properties);
4858 defsubr (&Sdelete_field);
4859 defsubr (&Sconstrain_to_field);
4861 defsubr (&Sline_beginning_position);
4862 defsubr (&Sline_end_position);
4864 defsubr (&Ssave_excursion);
4865 defsubr (&Ssave_current_buffer);
4867 defsubr (&Sbuffer_size);
4868 defsubr (&Spoint_max);
4869 defsubr (&Spoint_min);
4870 defsubr (&Spoint_min_marker);
4871 defsubr (&Spoint_max_marker);
4872 defsubr (&Sgap_position);
4873 defsubr (&Sgap_size);
4874 defsubr (&Sposition_bytes);
4875 defsubr (&Sbyte_to_position);
4877 defsubr (&Sbobp);
4878 defsubr (&Seobp);
4879 defsubr (&Sbolp);
4880 defsubr (&Seolp);
4881 defsubr (&Sfollowing_char);
4882 defsubr (&Sprevious_char);
4883 defsubr (&Schar_after);
4884 defsubr (&Schar_before);
4885 defsubr (&Sinsert);
4886 defsubr (&Sinsert_before_markers);
4887 defsubr (&Sinsert_and_inherit);
4888 defsubr (&Sinsert_and_inherit_before_markers);
4889 defsubr (&Sinsert_char);
4890 defsubr (&Sinsert_byte);
4892 defsubr (&Suser_login_name);
4893 defsubr (&Suser_real_login_name);
4894 defsubr (&Suser_uid);
4895 defsubr (&Suser_real_uid);
4896 defsubr (&Sgroup_gid);
4897 defsubr (&Sgroup_real_gid);
4898 defsubr (&Suser_full_name);
4899 defsubr (&Semacs_pid);
4900 defsubr (&Scurrent_time);
4901 defsubr (&Sget_internal_run_time);
4902 defsubr (&Sformat_time_string);
4903 defsubr (&Sfloat_time);
4904 defsubr (&Sdecode_time);
4905 defsubr (&Sencode_time);
4906 defsubr (&Scurrent_time_string);
4907 defsubr (&Scurrent_time_zone);
4908 defsubr (&Sset_time_zone_rule);
4909 defsubr (&Ssystem_name);
4910 defsubr (&Smessage);
4911 defsubr (&Smessage_box);
4912 defsubr (&Smessage_or_box);
4913 defsubr (&Scurrent_message);
4914 defsubr (&Sformat);
4916 defsubr (&Sinsert_buffer_substring);
4917 defsubr (&Scompare_buffer_substrings);
4918 defsubr (&Ssubst_char_in_region);
4919 defsubr (&Stranslate_region_internal);
4920 defsubr (&Sdelete_region);
4921 defsubr (&Sdelete_and_extract_region);
4922 defsubr (&Swiden);
4923 defsubr (&Snarrow_to_region);
4924 defsubr (&Ssave_restriction);
4925 defsubr (&Stranspose_regions);