]> code.delx.au - gnu-emacs/blob - src/editfns.c
7d70c0fee70692d40c8325b5244b7f9ad2e717c3
[gnu-emacs] / src / editfns.c
1 /* Lisp functions pertaining to editing.
2
3 Copyright (C) 1985, 1986, 1987, 1989, 1993, 1994, 1995, 1996, 1997,
4 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
5 2009, 2010, 2011 Free Software Foundation, Inc.
6
7 This file is part of GNU Emacs.
8
9 GNU Emacs is free software: you can redistribute it and/or modify
10 it under the terms of the GNU General Public License as published by
11 the Free Software Foundation, either version 3 of the License, or
12 (at your option) any later version.
13
14 GNU Emacs is distributed in the hope that it will be useful,
15 but WITHOUT ANY WARRANTY; without even the implied warranty of
16 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 GNU General Public License for more details.
18
19 You should have received a copy of the GNU General Public License
20 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
21
22
23 #include <config.h>
24 #include <sys/types.h>
25 #include <stdio.h>
26 #include <setjmp.h>
27
28 #ifdef HAVE_PWD_H
29 #include <pwd.h>
30 #endif
31
32 #include <unistd.h>
33
34 #ifdef HAVE_SYS_UTSNAME_H
35 #include <sys/utsname.h>
36 #endif
37
38 #include "lisp.h"
39
40 /* systime.h includes <sys/time.h> which, on some systems, is required
41 for <sys/resource.h>; thus systime.h must be included before
42 <sys/resource.h> */
43 #include "systime.h"
44
45 #if defined HAVE_SYS_RESOURCE_H
46 #include <sys/resource.h>
47 #endif
48
49 #include <ctype.h>
50
51 #include "intervals.h"
52 #include "buffer.h"
53 #include "character.h"
54 #include "coding.h"
55 #include "frame.h"
56 #include "window.h"
57 #include "blockinput.h"
58
59 #ifdef STDC_HEADERS
60 #include <float.h>
61 #define MAX_10_EXP DBL_MAX_10_EXP
62 #else
63 #define MAX_10_EXP 310
64 #endif
65
66 #ifndef NULL
67 #define NULL 0
68 #endif
69
70 #ifndef USER_FULL_NAME
71 #define USER_FULL_NAME pw->pw_gecos
72 #endif
73
74 #ifndef USE_CRT_DLL
75 extern char **environ;
76 #endif
77
78 #define TM_YEAR_BASE 1900
79
80 /* Nonzero if TM_YEAR is a struct tm's tm_year value that causes
81 asctime to have well-defined behavior. */
82 #ifndef TM_YEAR_IN_ASCTIME_RANGE
83 # define TM_YEAR_IN_ASCTIME_RANGE(tm_year) \
84 (1000 - TM_YEAR_BASE <= (tm_year) && (tm_year) <= 9999 - TM_YEAR_BASE)
85 #endif
86
87 extern size_t emacs_strftimeu (char *, size_t, const char *,
88 const struct tm *, int);
89
90 #ifdef WINDOWSNT
91 extern Lisp_Object w32_get_internal_run_time (void);
92 #endif
93
94 static int tm_diff (struct tm *, struct tm *);
95 static void find_field (Lisp_Object, Lisp_Object, Lisp_Object,
96 EMACS_INT *, Lisp_Object, EMACS_INT *);
97 static void update_buffer_properties (EMACS_INT, EMACS_INT);
98 static Lisp_Object region_limit (int);
99 static size_t emacs_memftimeu (char *, size_t, const char *,
100 size_t, const struct tm *, int);
101 static void general_insert_function (void (*) (const unsigned char *, EMACS_INT),
102 void (*) (Lisp_Object, EMACS_INT,
103 EMACS_INT, EMACS_INT,
104 EMACS_INT, int),
105 int, int, Lisp_Object *);
106 static Lisp_Object subst_char_in_region_unwind (Lisp_Object);
107 static Lisp_Object subst_char_in_region_unwind_1 (Lisp_Object);
108 static void transpose_markers (EMACS_INT, EMACS_INT, EMACS_INT, EMACS_INT,
109 EMACS_INT, EMACS_INT, EMACS_INT, EMACS_INT);
110
111 Lisp_Object Qbuffer_access_fontify_functions;
112 Lisp_Object Fuser_full_name (Lisp_Object);
113
114 /* Symbol for the text property used to mark fields. */
115
116 Lisp_Object Qfield;
117
118 /* A special value for Qfield properties. */
119
120 Lisp_Object Qboundary;
121
122
123 void
124 init_editfns (void)
125 {
126 char *user_name;
127 register unsigned char *p;
128 struct passwd *pw; /* password entry for the current user */
129 Lisp_Object tem;
130
131 /* Set up system_name even when dumping. */
132 init_system_name ();
133
134 #ifndef CANNOT_DUMP
135 /* Don't bother with this on initial start when just dumping out */
136 if (!initialized)
137 return;
138 #endif /* not CANNOT_DUMP */
139
140 pw = (struct passwd *) getpwuid (getuid ());
141 #ifdef MSDOS
142 /* We let the real user name default to "root" because that's quite
143 accurate on MSDOG and because it lets Emacs find the init file.
144 (The DVX libraries override the Djgpp libraries here.) */
145 Vuser_real_login_name = build_string (pw ? pw->pw_name : "root");
146 #else
147 Vuser_real_login_name = build_string (pw ? pw->pw_name : "unknown");
148 #endif
149
150 /* Get the effective user name, by consulting environment variables,
151 or the effective uid if those are unset. */
152 user_name = (char *) getenv ("LOGNAME");
153 if (!user_name)
154 #ifdef WINDOWSNT
155 user_name = (char *) getenv ("USERNAME"); /* it's USERNAME on NT */
156 #else /* WINDOWSNT */
157 user_name = (char *) getenv ("USER");
158 #endif /* WINDOWSNT */
159 if (!user_name)
160 {
161 pw = (struct passwd *) getpwuid (geteuid ());
162 user_name = (char *) (pw ? pw->pw_name : "unknown");
163 }
164 Vuser_login_name = build_string (user_name);
165
166 /* If the user name claimed in the environment vars differs from
167 the real uid, use the claimed name to find the full name. */
168 tem = Fstring_equal (Vuser_login_name, Vuser_real_login_name);
169 Vuser_full_name = Fuser_full_name (NILP (tem)? make_number (geteuid())
170 : Vuser_login_name);
171
172 p = (unsigned char *) getenv ("NAME");
173 if (p)
174 Vuser_full_name = build_string (p);
175 else if (NILP (Vuser_full_name))
176 Vuser_full_name = build_string ("unknown");
177
178 #ifdef HAVE_SYS_UTSNAME_H
179 {
180 struct utsname uts;
181 uname (&uts);
182 Voperating_system_release = build_string (uts.release);
183 }
184 #else
185 Voperating_system_release = Qnil;
186 #endif
187 }
188 \f
189 DEFUN ("char-to-string", Fchar_to_string, Schar_to_string, 1, 1, 0,
190 doc: /* Convert arg CHAR to a string containing that character.
191 usage: (char-to-string CHAR) */)
192 (Lisp_Object character)
193 {
194 int len;
195 unsigned char str[MAX_MULTIBYTE_LENGTH];
196
197 CHECK_CHARACTER (character);
198
199 len = CHAR_STRING (XFASTINT (character), str);
200 return make_string_from_bytes (str, 1, len);
201 }
202
203 DEFUN ("byte-to-string", Fbyte_to_string, Sbyte_to_string, 1, 1, 0,
204 doc: /* Convert arg BYTE to a unibyte string containing that byte. */)
205 (Lisp_Object byte)
206 {
207 unsigned char b;
208 CHECK_NUMBER (byte);
209 if (XINT (byte) < 0 || XINT (byte) > 255)
210 error ("Invalid byte");
211 b = XINT (byte);
212 return make_string_from_bytes (&b, 1, 1);
213 }
214
215 DEFUN ("string-to-char", Fstring_to_char, Sstring_to_char, 1, 1, 0,
216 doc: /* Convert arg STRING to a character, the first character of that string.
217 A multibyte character is handled correctly. */)
218 (register Lisp_Object string)
219 {
220 register Lisp_Object val;
221 CHECK_STRING (string);
222 if (SCHARS (string))
223 {
224 if (STRING_MULTIBYTE (string))
225 XSETFASTINT (val, STRING_CHAR (SDATA (string)));
226 else
227 XSETFASTINT (val, SREF (string, 0));
228 }
229 else
230 XSETFASTINT (val, 0);
231 return val;
232 }
233 \f
234 static Lisp_Object
235 buildmark (EMACS_INT charpos, EMACS_INT bytepos)
236 {
237 register Lisp_Object mark;
238 mark = Fmake_marker ();
239 set_marker_both (mark, Qnil, charpos, bytepos);
240 return mark;
241 }
242
243 DEFUN ("point", Fpoint, Spoint, 0, 0, 0,
244 doc: /* Return value of point, as an integer.
245 Beginning of buffer is position (point-min). */)
246 (void)
247 {
248 Lisp_Object temp;
249 XSETFASTINT (temp, PT);
250 return temp;
251 }
252
253 DEFUN ("point-marker", Fpoint_marker, Spoint_marker, 0, 0, 0,
254 doc: /* Return value of point, as a marker object. */)
255 (void)
256 {
257 return buildmark (PT, PT_BYTE);
258 }
259
260 EMACS_INT
261 clip_to_bounds (EMACS_INT lower, EMACS_INT num, EMACS_INT upper)
262 {
263 if (num < lower)
264 return lower;
265 else if (num > upper)
266 return upper;
267 else
268 return num;
269 }
270
271 DEFUN ("goto-char", Fgoto_char, Sgoto_char, 1, 1, "NGoto char: ",
272 doc: /* Set point to POSITION, a number or marker.
273 Beginning of buffer is position (point-min), end is (point-max).
274
275 The return value is POSITION. */)
276 (register Lisp_Object position)
277 {
278 EMACS_INT pos;
279
280 if (MARKERP (position)
281 && current_buffer == XMARKER (position)->buffer)
282 {
283 pos = marker_position (position);
284 if (pos < BEGV)
285 SET_PT_BOTH (BEGV, BEGV_BYTE);
286 else if (pos > ZV)
287 SET_PT_BOTH (ZV, ZV_BYTE);
288 else
289 SET_PT_BOTH (pos, marker_byte_position (position));
290
291 return position;
292 }
293
294 CHECK_NUMBER_COERCE_MARKER (position);
295
296 pos = clip_to_bounds (BEGV, XINT (position), ZV);
297 SET_PT (pos);
298 return position;
299 }
300
301
302 /* Return the start or end position of the region.
303 BEGINNINGP non-zero means return the start.
304 If there is no region active, signal an error. */
305
306 static Lisp_Object
307 region_limit (int beginningp)
308 {
309 Lisp_Object m;
310
311 if (!NILP (Vtransient_mark_mode)
312 && NILP (Vmark_even_if_inactive)
313 && NILP (current_buffer->mark_active))
314 xsignal0 (Qmark_inactive);
315
316 m = Fmarker_position (current_buffer->mark);
317 if (NILP (m))
318 error ("The mark is not set now, so there is no region");
319
320 if ((PT < XFASTINT (m)) == (beginningp != 0))
321 m = make_number (PT);
322 return m;
323 }
324
325 DEFUN ("region-beginning", Fregion_beginning, Sregion_beginning, 0, 0, 0,
326 doc: /* Return the integer value of point or mark, whichever is smaller. */)
327 (void)
328 {
329 return region_limit (1);
330 }
331
332 DEFUN ("region-end", Fregion_end, Sregion_end, 0, 0, 0,
333 doc: /* Return the integer value of point or mark, whichever is larger. */)
334 (void)
335 {
336 return region_limit (0);
337 }
338
339 DEFUN ("mark-marker", Fmark_marker, Smark_marker, 0, 0, 0,
340 doc: /* Return this buffer's mark, as a marker object.
341 Watch out! Moving this marker changes the mark position.
342 If you set the marker not to point anywhere, the buffer will have no mark. */)
343 (void)
344 {
345 return current_buffer->mark;
346 }
347
348 \f
349 /* Find all the overlays in the current buffer that touch position POS.
350 Return the number found, and store them in a vector in VEC
351 of length LEN. */
352
353 static int
354 overlays_around (EMACS_INT pos, Lisp_Object *vec, int len)
355 {
356 Lisp_Object overlay, start, end;
357 struct Lisp_Overlay *tail;
358 EMACS_INT startpos, endpos;
359 int idx = 0;
360
361 for (tail = current_buffer->overlays_before; tail; tail = tail->next)
362 {
363 XSETMISC (overlay, tail);
364
365 end = OVERLAY_END (overlay);
366 endpos = OVERLAY_POSITION (end);
367 if (endpos < pos)
368 break;
369 start = OVERLAY_START (overlay);
370 startpos = OVERLAY_POSITION (start);
371 if (startpos <= pos)
372 {
373 if (idx < len)
374 vec[idx] = overlay;
375 /* Keep counting overlays even if we can't return them all. */
376 idx++;
377 }
378 }
379
380 for (tail = current_buffer->overlays_after; tail; tail = tail->next)
381 {
382 XSETMISC (overlay, tail);
383
384 start = OVERLAY_START (overlay);
385 startpos = OVERLAY_POSITION (start);
386 if (pos < startpos)
387 break;
388 end = OVERLAY_END (overlay);
389 endpos = OVERLAY_POSITION (end);
390 if (pos <= endpos)
391 {
392 if (idx < len)
393 vec[idx] = overlay;
394 idx++;
395 }
396 }
397
398 return idx;
399 }
400
401 /* Return the value of property PROP, in OBJECT at POSITION.
402 It's the value of PROP that a char inserted at POSITION would get.
403 OBJECT is optional and defaults to the current buffer.
404 If OBJECT is a buffer, then overlay properties are considered as well as
405 text properties.
406 If OBJECT is a window, then that window's buffer is used, but
407 window-specific overlays are considered only if they are associated
408 with OBJECT. */
409 Lisp_Object
410 get_pos_property (Lisp_Object position, register Lisp_Object prop, Lisp_Object object)
411 {
412 CHECK_NUMBER_COERCE_MARKER (position);
413
414 if (NILP (object))
415 XSETBUFFER (object, current_buffer);
416 else if (WINDOWP (object))
417 object = XWINDOW (object)->buffer;
418
419 if (!BUFFERP (object))
420 /* pos-property only makes sense in buffers right now, since strings
421 have no overlays and no notion of insertion for which stickiness
422 could be obeyed. */
423 return Fget_text_property (position, prop, object);
424 else
425 {
426 EMACS_INT posn = XINT (position);
427 int noverlays;
428 Lisp_Object *overlay_vec, tem;
429 struct buffer *obuf = current_buffer;
430
431 set_buffer_temp (XBUFFER (object));
432
433 /* First try with room for 40 overlays. */
434 noverlays = 40;
435 overlay_vec = (Lisp_Object *) alloca (noverlays * sizeof (Lisp_Object));
436 noverlays = overlays_around (posn, overlay_vec, noverlays);
437
438 /* If there are more than 40,
439 make enough space for all, and try again. */
440 if (noverlays > 40)
441 {
442 overlay_vec = (Lisp_Object *) alloca (noverlays * sizeof (Lisp_Object));
443 noverlays = overlays_around (posn, overlay_vec, noverlays);
444 }
445 noverlays = sort_overlays (overlay_vec, noverlays, NULL);
446
447 set_buffer_temp (obuf);
448
449 /* Now check the overlays in order of decreasing priority. */
450 while (--noverlays >= 0)
451 {
452 Lisp_Object ol = overlay_vec[noverlays];
453 tem = Foverlay_get (ol, prop);
454 if (!NILP (tem))
455 {
456 /* Check the overlay is indeed active at point. */
457 Lisp_Object start = OVERLAY_START (ol), finish = OVERLAY_END (ol);
458 if ((OVERLAY_POSITION (start) == posn
459 && XMARKER (start)->insertion_type == 1)
460 || (OVERLAY_POSITION (finish) == posn
461 && XMARKER (finish)->insertion_type == 0))
462 ; /* The overlay will not cover a char inserted at point. */
463 else
464 {
465 return tem;
466 }
467 }
468 }
469
470 { /* Now check the text properties. */
471 int stickiness = text_property_stickiness (prop, position, object);
472 if (stickiness > 0)
473 return Fget_text_property (position, prop, object);
474 else if (stickiness < 0
475 && XINT (position) > BUF_BEGV (XBUFFER (object)))
476 return Fget_text_property (make_number (XINT (position) - 1),
477 prop, object);
478 else
479 return Qnil;
480 }
481 }
482 }
483
484 /* Find the field surrounding POS in *BEG and *END. If POS is nil,
485 the value of point is used instead. If BEG or END is null,
486 means don't store the beginning or end of the field.
487
488 BEG_LIMIT and END_LIMIT serve to limit the ranged of the returned
489 results; they do not effect boundary behavior.
490
491 If MERGE_AT_BOUNDARY is nonzero, then if POS is at the very first
492 position of a field, then the beginning of the previous field is
493 returned instead of the beginning of POS's field (since the end of a
494 field is actually also the beginning of the next input field, this
495 behavior is sometimes useful). Additionally in the MERGE_AT_BOUNDARY
496 true case, if two fields are separated by a field with the special
497 value `boundary', and POS lies within it, then the two separated
498 fields are considered to be adjacent, and POS between them, when
499 finding the beginning and ending of the "merged" field.
500
501 Either BEG or END may be 0, in which case the corresponding value
502 is not stored. */
503
504 static void
505 find_field (Lisp_Object pos, Lisp_Object merge_at_boundary,
506 Lisp_Object beg_limit,
507 EMACS_INT *beg, Lisp_Object end_limit, EMACS_INT *end)
508 {
509 /* Fields right before and after the point. */
510 Lisp_Object before_field, after_field;
511 /* 1 if POS counts as the start of a field. */
512 int at_field_start = 0;
513 /* 1 if POS counts as the end of a field. */
514 int at_field_end = 0;
515
516 if (NILP (pos))
517 XSETFASTINT (pos, PT);
518 else
519 CHECK_NUMBER_COERCE_MARKER (pos);
520
521 after_field
522 = get_char_property_and_overlay (pos, Qfield, Qnil, NULL);
523 before_field
524 = (XFASTINT (pos) > BEGV
525 ? get_char_property_and_overlay (make_number (XINT (pos) - 1),
526 Qfield, Qnil, NULL)
527 /* Using nil here would be a more obvious choice, but it would
528 fail when the buffer starts with a non-sticky field. */
529 : after_field);
530
531 /* See if we need to handle the case where MERGE_AT_BOUNDARY is nil
532 and POS is at beginning of a field, which can also be interpreted
533 as the end of the previous field. Note that the case where if
534 MERGE_AT_BOUNDARY is non-nil (see function comment) is actually the
535 more natural one; then we avoid treating the beginning of a field
536 specially. */
537 if (NILP (merge_at_boundary))
538 {
539 Lisp_Object field = get_pos_property (pos, Qfield, Qnil);
540 if (!EQ (field, after_field))
541 at_field_end = 1;
542 if (!EQ (field, before_field))
543 at_field_start = 1;
544 if (NILP (field) && at_field_start && at_field_end)
545 /* If an inserted char would have a nil field while the surrounding
546 text is non-nil, we're probably not looking at a
547 zero-length field, but instead at a non-nil field that's
548 not intended for editing (such as comint's prompts). */
549 at_field_end = at_field_start = 0;
550 }
551
552 /* Note about special `boundary' fields:
553
554 Consider the case where the point (`.') is between the fields `x' and `y':
555
556 xxxx.yyyy
557
558 In this situation, if merge_at_boundary is true, we consider the
559 `x' and `y' fields as forming one big merged field, and so the end
560 of the field is the end of `y'.
561
562 However, if `x' and `y' are separated by a special `boundary' field
563 (a field with a `field' char-property of 'boundary), then we ignore
564 this special field when merging adjacent fields. Here's the same
565 situation, but with a `boundary' field between the `x' and `y' fields:
566
567 xxx.BBBByyyy
568
569 Here, if point is at the end of `x', the beginning of `y', or
570 anywhere in-between (within the `boundary' field), we merge all
571 three fields and consider the beginning as being the beginning of
572 the `x' field, and the end as being the end of the `y' field. */
573
574 if (beg)
575 {
576 if (at_field_start)
577 /* POS is at the edge of a field, and we should consider it as
578 the beginning of the following field. */
579 *beg = XFASTINT (pos);
580 else
581 /* Find the previous field boundary. */
582 {
583 Lisp_Object p = pos;
584 if (!NILP (merge_at_boundary) && EQ (before_field, Qboundary))
585 /* Skip a `boundary' field. */
586 p = Fprevious_single_char_property_change (p, Qfield, Qnil,
587 beg_limit);
588
589 p = Fprevious_single_char_property_change (p, Qfield, Qnil,
590 beg_limit);
591 *beg = NILP (p) ? BEGV : XFASTINT (p);
592 }
593 }
594
595 if (end)
596 {
597 if (at_field_end)
598 /* POS is at the edge of a field, and we should consider it as
599 the end of the previous field. */
600 *end = XFASTINT (pos);
601 else
602 /* Find the next field boundary. */
603 {
604 if (!NILP (merge_at_boundary) && EQ (after_field, Qboundary))
605 /* Skip a `boundary' field. */
606 pos = Fnext_single_char_property_change (pos, Qfield, Qnil,
607 end_limit);
608
609 pos = Fnext_single_char_property_change (pos, Qfield, Qnil,
610 end_limit);
611 *end = NILP (pos) ? ZV : XFASTINT (pos);
612 }
613 }
614 }
615
616 \f
617 DEFUN ("delete-field", Fdelete_field, Sdelete_field, 0, 1, 0,
618 doc: /* Delete the field surrounding POS.
619 A field is a region of text with the same `field' property.
620 If POS is nil, the value of point is used for POS. */)
621 (Lisp_Object pos)
622 {
623 EMACS_INT beg, end;
624 find_field (pos, Qnil, Qnil, &beg, Qnil, &end);
625 if (beg != end)
626 del_range (beg, end);
627 return Qnil;
628 }
629
630 DEFUN ("field-string", Ffield_string, Sfield_string, 0, 1, 0,
631 doc: /* Return the contents of the field surrounding POS as a string.
632 A field is a region of text with the same `field' property.
633 If POS is nil, the value of point is used for POS. */)
634 (Lisp_Object pos)
635 {
636 EMACS_INT beg, end;
637 find_field (pos, Qnil, Qnil, &beg, Qnil, &end);
638 return make_buffer_string (beg, end, 1);
639 }
640
641 DEFUN ("field-string-no-properties", Ffield_string_no_properties, Sfield_string_no_properties, 0, 1, 0,
642 doc: /* Return the contents of the field around POS, without text properties.
643 A field is a region of text with the same `field' property.
644 If POS is nil, the value of point is used for POS. */)
645 (Lisp_Object pos)
646 {
647 EMACS_INT beg, end;
648 find_field (pos, Qnil, Qnil, &beg, Qnil, &end);
649 return make_buffer_string (beg, end, 0);
650 }
651
652 DEFUN ("field-beginning", Ffield_beginning, Sfield_beginning, 0, 3, 0,
653 doc: /* Return the beginning of the field surrounding POS.
654 A field is a region of text with the same `field' property.
655 If POS is nil, the value of point is used for POS.
656 If ESCAPE-FROM-EDGE is non-nil and POS is at the beginning of its
657 field, then the beginning of the *previous* field is returned.
658 If LIMIT is non-nil, it is a buffer position; if the beginning of the field
659 is before LIMIT, then LIMIT will be returned instead. */)
660 (Lisp_Object pos, Lisp_Object escape_from_edge, Lisp_Object limit)
661 {
662 EMACS_INT beg;
663 find_field (pos, escape_from_edge, limit, &beg, Qnil, 0);
664 return make_number (beg);
665 }
666
667 DEFUN ("field-end", Ffield_end, Sfield_end, 0, 3, 0,
668 doc: /* Return the end of the field surrounding POS.
669 A field is a region of text with the same `field' property.
670 If POS is nil, the value of point is used for POS.
671 If ESCAPE-FROM-EDGE is non-nil and POS is at the end of its field,
672 then the end of the *following* field is returned.
673 If LIMIT is non-nil, it is a buffer position; if the end of the field
674 is after LIMIT, then LIMIT will be returned instead. */)
675 (Lisp_Object pos, Lisp_Object escape_from_edge, Lisp_Object limit)
676 {
677 EMACS_INT end;
678 find_field (pos, escape_from_edge, Qnil, 0, limit, &end);
679 return make_number (end);
680 }
681
682 DEFUN ("constrain-to-field", Fconstrain_to_field, Sconstrain_to_field, 2, 5, 0,
683 doc: /* Return the position closest to NEW-POS that is in the same field as OLD-POS.
684
685 A field is a region of text with the same `field' property.
686 If NEW-POS is nil, then the current point is used instead, and set to the
687 constrained position if that is different.
688
689 If OLD-POS is at the boundary of two fields, then the allowable
690 positions for NEW-POS depends on the value of the optional argument
691 ESCAPE-FROM-EDGE: If ESCAPE-FROM-EDGE is nil, then NEW-POS is
692 constrained to the field that has the same `field' char-property
693 as any new characters inserted at OLD-POS, whereas if ESCAPE-FROM-EDGE
694 is non-nil, NEW-POS is constrained to the union of the two adjacent
695 fields. Additionally, if two fields are separated by another field with
696 the special value `boundary', then any point within this special field is
697 also considered to be `on the boundary'.
698
699 If the optional argument ONLY-IN-LINE is non-nil and constraining
700 NEW-POS would move it to a different line, NEW-POS is returned
701 unconstrained. This useful for commands that move by line, like
702 \\[next-line] or \\[beginning-of-line], which should generally respect field boundaries
703 only in the case where they can still move to the right line.
704
705 If the optional argument INHIBIT-CAPTURE-PROPERTY is non-nil, and OLD-POS has
706 a non-nil property of that name, then any field boundaries are ignored.
707
708 Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */)
709 (Lisp_Object new_pos, Lisp_Object old_pos, Lisp_Object escape_from_edge, Lisp_Object only_in_line, Lisp_Object inhibit_capture_property)
710 {
711 /* If non-zero, then the original point, before re-positioning. */
712 EMACS_INT orig_point = 0;
713 int fwd;
714 Lisp_Object prev_old, prev_new;
715
716 if (NILP (new_pos))
717 /* Use the current point, and afterwards, set it. */
718 {
719 orig_point = PT;
720 XSETFASTINT (new_pos, PT);
721 }
722
723 CHECK_NUMBER_COERCE_MARKER (new_pos);
724 CHECK_NUMBER_COERCE_MARKER (old_pos);
725
726 fwd = (XFASTINT (new_pos) > XFASTINT (old_pos));
727
728 prev_old = make_number (XFASTINT (old_pos) - 1);
729 prev_new = make_number (XFASTINT (new_pos) - 1);
730
731 if (NILP (Vinhibit_field_text_motion)
732 && !EQ (new_pos, old_pos)
733 && (!NILP (Fget_char_property (new_pos, Qfield, Qnil))
734 || !NILP (Fget_char_property (old_pos, Qfield, Qnil))
735 /* To recognize field boundaries, we must also look at the
736 previous positions; we could use `get_pos_property'
737 instead, but in itself that would fail inside non-sticky
738 fields (like comint prompts). */
739 || (XFASTINT (new_pos) > BEGV
740 && !NILP (Fget_char_property (prev_new, Qfield, Qnil)))
741 || (XFASTINT (old_pos) > BEGV
742 && !NILP (Fget_char_property (prev_old, Qfield, Qnil))))
743 && (NILP (inhibit_capture_property)
744 /* Field boundaries are again a problem; but now we must
745 decide the case exactly, so we need to call
746 `get_pos_property' as well. */
747 || (NILP (get_pos_property (old_pos, inhibit_capture_property, Qnil))
748 && (XFASTINT (old_pos) <= BEGV
749 || NILP (Fget_char_property (old_pos, inhibit_capture_property, Qnil))
750 || NILP (Fget_char_property (prev_old, inhibit_capture_property, Qnil))))))
751 /* It is possible that NEW_POS is not within the same field as
752 OLD_POS; try to move NEW_POS so that it is. */
753 {
754 int shortage;
755 Lisp_Object field_bound;
756
757 if (fwd)
758 field_bound = Ffield_end (old_pos, escape_from_edge, new_pos);
759 else
760 field_bound = Ffield_beginning (old_pos, escape_from_edge, new_pos);
761
762 if (/* See if ESCAPE_FROM_EDGE caused FIELD_BOUND to jump to the
763 other side of NEW_POS, which would mean that NEW_POS is
764 already acceptable, and it's not necessary to constrain it
765 to FIELD_BOUND. */
766 ((XFASTINT (field_bound) < XFASTINT (new_pos)) ? fwd : !fwd)
767 /* NEW_POS should be constrained, but only if either
768 ONLY_IN_LINE is nil (in which case any constraint is OK),
769 or NEW_POS and FIELD_BOUND are on the same line (in which
770 case the constraint is OK even if ONLY_IN_LINE is non-nil). */
771 && (NILP (only_in_line)
772 /* This is the ONLY_IN_LINE case, check that NEW_POS and
773 FIELD_BOUND are on the same line by seeing whether
774 there's an intervening newline or not. */
775 || (scan_buffer ('\n',
776 XFASTINT (new_pos), XFASTINT (field_bound),
777 fwd ? -1 : 1, &shortage, 1),
778 shortage != 0)))
779 /* Constrain NEW_POS to FIELD_BOUND. */
780 new_pos = field_bound;
781
782 if (orig_point && XFASTINT (new_pos) != orig_point)
783 /* The NEW_POS argument was originally nil, so automatically set PT. */
784 SET_PT (XFASTINT (new_pos));
785 }
786
787 return new_pos;
788 }
789
790 \f
791 DEFUN ("line-beginning-position",
792 Fline_beginning_position, Sline_beginning_position, 0, 1, 0,
793 doc: /* Return the character position of the first character on the current line.
794 With argument N not nil or 1, move forward N - 1 lines first.
795 If scan reaches end of buffer, return that position.
796
797 The returned position is of the first character in the logical order,
798 i.e. the one that has the smallest character position.
799
800 This function constrains the returned position to the current field
801 unless that would be on a different line than the original,
802 unconstrained result. If N is nil or 1, and a front-sticky field
803 starts at point, the scan stops as soon as it starts. To ignore field
804 boundaries bind `inhibit-field-text-motion' to t.
805
806 This function does not move point. */)
807 (Lisp_Object n)
808 {
809 EMACS_INT orig, orig_byte, end;
810 int count = SPECPDL_INDEX ();
811 specbind (Qinhibit_point_motion_hooks, Qt);
812
813 if (NILP (n))
814 XSETFASTINT (n, 1);
815 else
816 CHECK_NUMBER (n);
817
818 orig = PT;
819 orig_byte = PT_BYTE;
820 Fforward_line (make_number (XINT (n) - 1));
821 end = PT;
822
823 SET_PT_BOTH (orig, orig_byte);
824
825 unbind_to (count, Qnil);
826
827 /* Return END constrained to the current input field. */
828 return Fconstrain_to_field (make_number (end), make_number (orig),
829 XINT (n) != 1 ? Qt : Qnil,
830 Qt, Qnil);
831 }
832
833 DEFUN ("line-end-position", Fline_end_position, Sline_end_position, 0, 1, 0,
834 doc: /* Return the character position of the last character on the current line.
835 With argument N not nil or 1, move forward N - 1 lines first.
836 If scan reaches end of buffer, return that position.
837
838 The returned position is of the last character in the logical order,
839 i.e. the character whose buffer position is the largest one.
840
841 This function constrains the returned position to the current field
842 unless that would be on a different line than the original,
843 unconstrained result. If N is nil or 1, and a rear-sticky field ends
844 at point, the scan stops as soon as it starts. To ignore field
845 boundaries bind `inhibit-field-text-motion' to t.
846
847 This function does not move point. */)
848 (Lisp_Object n)
849 {
850 EMACS_INT end_pos;
851 EMACS_INT orig = PT;
852
853 if (NILP (n))
854 XSETFASTINT (n, 1);
855 else
856 CHECK_NUMBER (n);
857
858 end_pos = find_before_next_newline (orig, 0, XINT (n) - (XINT (n) <= 0));
859
860 /* Return END_POS constrained to the current input field. */
861 return Fconstrain_to_field (make_number (end_pos), make_number (orig),
862 Qnil, Qt, Qnil);
863 }
864
865 \f
866 Lisp_Object
867 save_excursion_save (void)
868 {
869 int visible = (XBUFFER (XWINDOW (selected_window)->buffer)
870 == current_buffer);
871
872 return Fcons (Fpoint_marker (),
873 Fcons (Fcopy_marker (current_buffer->mark, Qnil),
874 Fcons (visible ? Qt : Qnil,
875 Fcons (current_buffer->mark_active,
876 selected_window))));
877 }
878
879 Lisp_Object
880 save_excursion_restore (Lisp_Object info)
881 {
882 Lisp_Object tem, tem1, omark, nmark;
883 struct gcpro gcpro1, gcpro2, gcpro3;
884 int visible_p;
885
886 tem = Fmarker_buffer (XCAR (info));
887 /* If buffer being returned to is now deleted, avoid error */
888 /* Otherwise could get error here while unwinding to top level
889 and crash */
890 /* In that case, Fmarker_buffer returns nil now. */
891 if (NILP (tem))
892 return Qnil;
893
894 omark = nmark = Qnil;
895 GCPRO3 (info, omark, nmark);
896
897 Fset_buffer (tem);
898
899 /* Point marker. */
900 tem = XCAR (info);
901 Fgoto_char (tem);
902 unchain_marker (XMARKER (tem));
903
904 /* Mark marker. */
905 info = XCDR (info);
906 tem = XCAR (info);
907 omark = Fmarker_position (current_buffer->mark);
908 Fset_marker (current_buffer->mark, tem, Fcurrent_buffer ());
909 nmark = Fmarker_position (tem);
910 unchain_marker (XMARKER (tem));
911
912 /* visible */
913 info = XCDR (info);
914 visible_p = !NILP (XCAR (info));
915
916 #if 0 /* We used to make the current buffer visible in the selected window
917 if that was true previously. That avoids some anomalies.
918 But it creates others, and it wasn't documented, and it is simpler
919 and cleaner never to alter the window/buffer connections. */
920 tem1 = Fcar (tem);
921 if (!NILP (tem1)
922 && current_buffer != XBUFFER (XWINDOW (selected_window)->buffer))
923 Fswitch_to_buffer (Fcurrent_buffer (), Qnil);
924 #endif /* 0 */
925
926 /* Mark active */
927 info = XCDR (info);
928 tem = XCAR (info);
929 tem1 = current_buffer->mark_active;
930 current_buffer->mark_active = tem;
931
932 if (!NILP (Vrun_hooks))
933 {
934 /* If mark is active now, and either was not active
935 or was at a different place, run the activate hook. */
936 if (! NILP (current_buffer->mark_active))
937 {
938 if (! EQ (omark, nmark))
939 call1 (Vrun_hooks, intern ("activate-mark-hook"));
940 }
941 /* If mark has ceased to be active, run deactivate hook. */
942 else if (! NILP (tem1))
943 call1 (Vrun_hooks, intern ("deactivate-mark-hook"));
944 }
945
946 /* If buffer was visible in a window, and a different window was
947 selected, and the old selected window is still showing this
948 buffer, restore point in that window. */
949 tem = XCDR (info);
950 if (visible_p
951 && !EQ (tem, selected_window)
952 && (tem1 = XWINDOW (tem)->buffer,
953 (/* Window is live... */
954 BUFFERP (tem1)
955 /* ...and it shows the current buffer. */
956 && XBUFFER (tem1) == current_buffer)))
957 Fset_window_point (tem, make_number (PT));
958
959 UNGCPRO;
960 return Qnil;
961 }
962
963 DEFUN ("save-excursion", Fsave_excursion, Ssave_excursion, 0, UNEVALLED, 0,
964 doc: /* Save point, mark, and current buffer; execute BODY; restore those things.
965 Executes BODY just like `progn'.
966 The values of point, mark and the current buffer are restored
967 even in case of abnormal exit (throw or error).
968 The state of activation of the mark is also restored.
969
970 This construct does not save `deactivate-mark', and therefore
971 functions that change the buffer will still cause deactivation
972 of the mark at the end of the command. To prevent that, bind
973 `deactivate-mark' with `let'.
974
975 If you only want to save the current buffer but not point nor mark,
976 then just use `save-current-buffer', or even `with-current-buffer'.
977
978 usage: (save-excursion &rest BODY) */)
979 (Lisp_Object args)
980 {
981 register Lisp_Object val;
982 int count = SPECPDL_INDEX ();
983
984 record_unwind_protect (save_excursion_restore, save_excursion_save ());
985
986 val = Fprogn (args);
987 return unbind_to (count, val);
988 }
989
990 DEFUN ("save-current-buffer", Fsave_current_buffer, Ssave_current_buffer, 0, UNEVALLED, 0,
991 doc: /* Save the current buffer; execute BODY; restore the current buffer.
992 Executes BODY just like `progn'.
993 usage: (save-current-buffer &rest BODY) */)
994 (Lisp_Object args)
995 {
996 Lisp_Object val;
997 int count = SPECPDL_INDEX ();
998
999 record_unwind_protect (set_buffer_if_live, Fcurrent_buffer ());
1000
1001 val = Fprogn (args);
1002 return unbind_to (count, val);
1003 }
1004 \f
1005 DEFUN ("buffer-size", Fbufsize, Sbufsize, 0, 1, 0,
1006 doc: /* Return the number of characters in the current buffer.
1007 If BUFFER, return the number of characters in that buffer instead. */)
1008 (Lisp_Object buffer)
1009 {
1010 if (NILP (buffer))
1011 return make_number (Z - BEG);
1012 else
1013 {
1014 CHECK_BUFFER (buffer);
1015 return make_number (BUF_Z (XBUFFER (buffer))
1016 - BUF_BEG (XBUFFER (buffer)));
1017 }
1018 }
1019
1020 DEFUN ("point-min", Fpoint_min, Spoint_min, 0, 0, 0,
1021 doc: /* Return the minimum permissible value of point in the current buffer.
1022 This is 1, unless narrowing (a buffer restriction) is in effect. */)
1023 (void)
1024 {
1025 Lisp_Object temp;
1026 XSETFASTINT (temp, BEGV);
1027 return temp;
1028 }
1029
1030 DEFUN ("point-min-marker", Fpoint_min_marker, Spoint_min_marker, 0, 0, 0,
1031 doc: /* Return a marker to the minimum permissible value of point in this buffer.
1032 This is the beginning, unless narrowing (a buffer restriction) is in effect. */)
1033 (void)
1034 {
1035 return buildmark (BEGV, BEGV_BYTE);
1036 }
1037
1038 DEFUN ("point-max", Fpoint_max, Spoint_max, 0, 0, 0,
1039 doc: /* Return the maximum permissible value of point in the current buffer.
1040 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1041 is in effect, in which case it is less. */)
1042 (void)
1043 {
1044 Lisp_Object temp;
1045 XSETFASTINT (temp, ZV);
1046 return temp;
1047 }
1048
1049 DEFUN ("point-max-marker", Fpoint_max_marker, Spoint_max_marker, 0, 0, 0,
1050 doc: /* Return a marker to the maximum permissible value of point in this buffer.
1051 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1052 is in effect, in which case it is less. */)
1053 (void)
1054 {
1055 return buildmark (ZV, ZV_BYTE);
1056 }
1057
1058 DEFUN ("gap-position", Fgap_position, Sgap_position, 0, 0, 0,
1059 doc: /* Return the position of the gap, in the current buffer.
1060 See also `gap-size'. */)
1061 (void)
1062 {
1063 Lisp_Object temp;
1064 XSETFASTINT (temp, GPT);
1065 return temp;
1066 }
1067
1068 DEFUN ("gap-size", Fgap_size, Sgap_size, 0, 0, 0,
1069 doc: /* Return the size of the current buffer's gap.
1070 See also `gap-position'. */)
1071 (void)
1072 {
1073 Lisp_Object temp;
1074 XSETFASTINT (temp, GAP_SIZE);
1075 return temp;
1076 }
1077
1078 DEFUN ("position-bytes", Fposition_bytes, Sposition_bytes, 1, 1, 0,
1079 doc: /* Return the byte position for character position POSITION.
1080 If POSITION is out of range, the value is nil. */)
1081 (Lisp_Object position)
1082 {
1083 CHECK_NUMBER_COERCE_MARKER (position);
1084 if (XINT (position) < BEG || XINT (position) > Z)
1085 return Qnil;
1086 return make_number (CHAR_TO_BYTE (XINT (position)));
1087 }
1088
1089 DEFUN ("byte-to-position", Fbyte_to_position, Sbyte_to_position, 1, 1, 0,
1090 doc: /* Return the character position for byte position BYTEPOS.
1091 If BYTEPOS is out of range, the value is nil. */)
1092 (Lisp_Object bytepos)
1093 {
1094 CHECK_NUMBER (bytepos);
1095 if (XINT (bytepos) < BEG_BYTE || XINT (bytepos) > Z_BYTE)
1096 return Qnil;
1097 return make_number (BYTE_TO_CHAR (XINT (bytepos)));
1098 }
1099 \f
1100 DEFUN ("following-char", Ffollowing_char, Sfollowing_char, 0, 0, 0,
1101 doc: /* Return the character following point, as a number.
1102 At the end of the buffer or accessible region, return 0. */)
1103 (void)
1104 {
1105 Lisp_Object temp;
1106 if (PT >= ZV)
1107 XSETFASTINT (temp, 0);
1108 else
1109 XSETFASTINT (temp, FETCH_CHAR (PT_BYTE));
1110 return temp;
1111 }
1112
1113 DEFUN ("preceding-char", Fprevious_char, Sprevious_char, 0, 0, 0,
1114 doc: /* Return the character preceding point, as a number.
1115 At the beginning of the buffer or accessible region, return 0. */)
1116 (void)
1117 {
1118 Lisp_Object temp;
1119 if (PT <= BEGV)
1120 XSETFASTINT (temp, 0);
1121 else if (!NILP (current_buffer->enable_multibyte_characters))
1122 {
1123 EMACS_INT pos = PT_BYTE;
1124 DEC_POS (pos);
1125 XSETFASTINT (temp, FETCH_CHAR (pos));
1126 }
1127 else
1128 XSETFASTINT (temp, FETCH_BYTE (PT_BYTE - 1));
1129 return temp;
1130 }
1131
1132 DEFUN ("bobp", Fbobp, Sbobp, 0, 0, 0,
1133 doc: /* Return t if point is at the beginning of the buffer.
1134 If the buffer is narrowed, this means the beginning of the narrowed part. */)
1135 (void)
1136 {
1137 if (PT == BEGV)
1138 return Qt;
1139 return Qnil;
1140 }
1141
1142 DEFUN ("eobp", Feobp, Seobp, 0, 0, 0,
1143 doc: /* Return t if point is at the end of the buffer.
1144 If the buffer is narrowed, this means the end of the narrowed part. */)
1145 (void)
1146 {
1147 if (PT == ZV)
1148 return Qt;
1149 return Qnil;
1150 }
1151
1152 DEFUN ("bolp", Fbolp, Sbolp, 0, 0, 0,
1153 doc: /* Return t if point is at the beginning of a line. */)
1154 (void)
1155 {
1156 if (PT == BEGV || FETCH_BYTE (PT_BYTE - 1) == '\n')
1157 return Qt;
1158 return Qnil;
1159 }
1160
1161 DEFUN ("eolp", Feolp, Seolp, 0, 0, 0,
1162 doc: /* Return t if point is at the end of a line.
1163 `End of a line' includes point being at the end of the buffer. */)
1164 (void)
1165 {
1166 if (PT == ZV || FETCH_BYTE (PT_BYTE) == '\n')
1167 return Qt;
1168 return Qnil;
1169 }
1170
1171 DEFUN ("char-after", Fchar_after, Schar_after, 0, 1, 0,
1172 doc: /* Return character in current buffer at position POS.
1173 POS is an integer or a marker and defaults to point.
1174 If POS is out of range, the value is nil. */)
1175 (Lisp_Object pos)
1176 {
1177 register EMACS_INT pos_byte;
1178
1179 if (NILP (pos))
1180 {
1181 pos_byte = PT_BYTE;
1182 XSETFASTINT (pos, PT);
1183 }
1184
1185 if (MARKERP (pos))
1186 {
1187 pos_byte = marker_byte_position (pos);
1188 if (pos_byte < BEGV_BYTE || pos_byte >= ZV_BYTE)
1189 return Qnil;
1190 }
1191 else
1192 {
1193 CHECK_NUMBER_COERCE_MARKER (pos);
1194 if (XINT (pos) < BEGV || XINT (pos) >= ZV)
1195 return Qnil;
1196
1197 pos_byte = CHAR_TO_BYTE (XINT (pos));
1198 }
1199
1200 return make_number (FETCH_CHAR (pos_byte));
1201 }
1202
1203 DEFUN ("char-before", Fchar_before, Schar_before, 0, 1, 0,
1204 doc: /* Return character in current buffer preceding position POS.
1205 POS is an integer or a marker and defaults to point.
1206 If POS is out of range, the value is nil. */)
1207 (Lisp_Object pos)
1208 {
1209 register Lisp_Object val;
1210 register EMACS_INT pos_byte;
1211
1212 if (NILP (pos))
1213 {
1214 pos_byte = PT_BYTE;
1215 XSETFASTINT (pos, PT);
1216 }
1217
1218 if (MARKERP (pos))
1219 {
1220 pos_byte = marker_byte_position (pos);
1221
1222 if (pos_byte <= BEGV_BYTE || pos_byte > ZV_BYTE)
1223 return Qnil;
1224 }
1225 else
1226 {
1227 CHECK_NUMBER_COERCE_MARKER (pos);
1228
1229 if (XINT (pos) <= BEGV || XINT (pos) > ZV)
1230 return Qnil;
1231
1232 pos_byte = CHAR_TO_BYTE (XINT (pos));
1233 }
1234
1235 if (!NILP (current_buffer->enable_multibyte_characters))
1236 {
1237 DEC_POS (pos_byte);
1238 XSETFASTINT (val, FETCH_CHAR (pos_byte));
1239 }
1240 else
1241 {
1242 pos_byte--;
1243 XSETFASTINT (val, FETCH_BYTE (pos_byte));
1244 }
1245 return val;
1246 }
1247 \f
1248 DEFUN ("user-login-name", Fuser_login_name, Suser_login_name, 0, 1, 0,
1249 doc: /* Return the name under which the user logged in, as a string.
1250 This is based on the effective uid, not the real uid.
1251 Also, if the environment variables LOGNAME or USER are set,
1252 that determines the value of this function.
1253
1254 If optional argument UID is an integer or a float, return the login name
1255 of the user with that uid, or nil if there is no such user. */)
1256 (Lisp_Object uid)
1257 {
1258 struct passwd *pw;
1259 uid_t id;
1260
1261 /* Set up the user name info if we didn't do it before.
1262 (That can happen if Emacs is dumpable
1263 but you decide to run `temacs -l loadup' and not dump. */
1264 if (INTEGERP (Vuser_login_name))
1265 init_editfns ();
1266
1267 if (NILP (uid))
1268 return Vuser_login_name;
1269
1270 id = (uid_t)XFLOATINT (uid);
1271 BLOCK_INPUT;
1272 pw = (struct passwd *) getpwuid (id);
1273 UNBLOCK_INPUT;
1274 return (pw ? build_string (pw->pw_name) : Qnil);
1275 }
1276
1277 DEFUN ("user-real-login-name", Fuser_real_login_name, Suser_real_login_name,
1278 0, 0, 0,
1279 doc: /* Return the name of the user's real uid, as a string.
1280 This ignores the environment variables LOGNAME and USER, so it differs from
1281 `user-login-name' when running under `su'. */)
1282 (void)
1283 {
1284 /* Set up the user name info if we didn't do it before.
1285 (That can happen if Emacs is dumpable
1286 but you decide to run `temacs -l loadup' and not dump. */
1287 if (INTEGERP (Vuser_login_name))
1288 init_editfns ();
1289 return Vuser_real_login_name;
1290 }
1291
1292 DEFUN ("user-uid", Fuser_uid, Suser_uid, 0, 0, 0,
1293 doc: /* Return the effective uid of Emacs.
1294 Value is an integer or a float, depending on the value. */)
1295 (void)
1296 {
1297 /* Assignment to EMACS_INT stops GCC whining about limited range of
1298 data type. */
1299 EMACS_INT euid = geteuid ();
1300
1301 /* Make sure we don't produce a negative UID due to signed integer
1302 overflow. */
1303 if (euid < 0)
1304 return make_float ((double)geteuid ());
1305 return make_fixnum_or_float (euid);
1306 }
1307
1308 DEFUN ("user-real-uid", Fuser_real_uid, Suser_real_uid, 0, 0, 0,
1309 doc: /* Return the real uid of Emacs.
1310 Value is an integer or a float, depending on the value. */)
1311 (void)
1312 {
1313 /* Assignment to EMACS_INT stops GCC whining about limited range of
1314 data type. */
1315 EMACS_INT uid = getuid ();
1316
1317 /* Make sure we don't produce a negative UID due to signed integer
1318 overflow. */
1319 if (uid < 0)
1320 return make_float ((double)getuid ());
1321 return make_fixnum_or_float (uid);
1322 }
1323
1324 DEFUN ("user-full-name", Fuser_full_name, Suser_full_name, 0, 1, 0,
1325 doc: /* Return the full name of the user logged in, as a string.
1326 If the full name corresponding to Emacs's userid is not known,
1327 return "unknown".
1328
1329 If optional argument UID is an integer or float, return the full name
1330 of the user with that uid, or nil if there is no such user.
1331 If UID is a string, return the full name of the user with that login
1332 name, or nil if there is no such user. */)
1333 (Lisp_Object uid)
1334 {
1335 struct passwd *pw;
1336 register unsigned char *p, *q;
1337 Lisp_Object full;
1338
1339 if (NILP (uid))
1340 return Vuser_full_name;
1341 else if (NUMBERP (uid))
1342 {
1343 BLOCK_INPUT;
1344 pw = (struct passwd *) getpwuid ((uid_t) XFLOATINT (uid));
1345 UNBLOCK_INPUT;
1346 }
1347 else if (STRINGP (uid))
1348 {
1349 BLOCK_INPUT;
1350 pw = (struct passwd *) getpwnam (SDATA (uid));
1351 UNBLOCK_INPUT;
1352 }
1353 else
1354 error ("Invalid UID specification");
1355
1356 if (!pw)
1357 return Qnil;
1358
1359 p = (unsigned char *) USER_FULL_NAME;
1360 /* Chop off everything after the first comma. */
1361 q = (unsigned char *) strchr (p, ',');
1362 full = make_string (p, q ? q - p : strlen (p));
1363
1364 #ifdef AMPERSAND_FULL_NAME
1365 p = SDATA (full);
1366 q = (unsigned char *) strchr (p, '&');
1367 /* Substitute the login name for the &, upcasing the first character. */
1368 if (q)
1369 {
1370 register unsigned char *r;
1371 Lisp_Object login;
1372
1373 login = Fuser_login_name (make_number (pw->pw_uid));
1374 r = (unsigned char *) alloca (strlen (p) + SCHARS (login) + 1);
1375 memcpy (r, p, q - p);
1376 r[q - p] = 0;
1377 strcat (r, SDATA (login));
1378 r[q - p] = UPCASE (r[q - p]);
1379 strcat (r, q + 1);
1380 full = build_string (r);
1381 }
1382 #endif /* AMPERSAND_FULL_NAME */
1383
1384 return full;
1385 }
1386
1387 DEFUN ("system-name", Fsystem_name, Ssystem_name, 0, 0, 0,
1388 doc: /* Return the host name of the machine you are running on, as a string. */)
1389 (void)
1390 {
1391 return Vsystem_name;
1392 }
1393
1394 /* For the benefit of callers who don't want to include lisp.h */
1395
1396 const char *
1397 get_system_name (void)
1398 {
1399 if (STRINGP (Vsystem_name))
1400 return SSDATA (Vsystem_name);
1401 else
1402 return "";
1403 }
1404
1405 const char *
1406 get_operating_system_release (void)
1407 {
1408 if (STRINGP (Voperating_system_release))
1409 return SSDATA (Voperating_system_release);
1410 else
1411 return "";
1412 }
1413
1414 DEFUN ("emacs-pid", Femacs_pid, Semacs_pid, 0, 0, 0,
1415 doc: /* Return the process ID of Emacs, as an integer. */)
1416 (void)
1417 {
1418 return make_number (getpid ());
1419 }
1420
1421 DEFUN ("current-time", Fcurrent_time, Scurrent_time, 0, 0, 0,
1422 doc: /* Return the current time, as the number of seconds since 1970-01-01 00:00:00.
1423 The time is returned as a list of three integers. The first has the
1424 most significant 16 bits of the seconds, while the second has the
1425 least significant 16 bits. The third integer gives the microsecond
1426 count.
1427
1428 The microsecond count is zero on systems that do not provide
1429 resolution finer than a second. */)
1430 (void)
1431 {
1432 EMACS_TIME t;
1433
1434 EMACS_GET_TIME (t);
1435 return list3 (make_number ((EMACS_SECS (t) >> 16) & 0xffff),
1436 make_number ((EMACS_SECS (t) >> 0) & 0xffff),
1437 make_number (EMACS_USECS (t)));
1438 }
1439
1440 DEFUN ("get-internal-run-time", Fget_internal_run_time, Sget_internal_run_time,
1441 0, 0, 0,
1442 doc: /* Return the current run time used by Emacs.
1443 The time is returned as a list of three integers. The first has the
1444 most significant 16 bits of the seconds, while the second has the
1445 least significant 16 bits. The third integer gives the microsecond
1446 count.
1447
1448 On systems that can't determine the run time, `get-internal-run-time'
1449 does the same thing as `current-time'. The microsecond count is zero
1450 on systems that do not provide resolution finer than a second. */)
1451 (void)
1452 {
1453 #ifdef HAVE_GETRUSAGE
1454 struct rusage usage;
1455 int secs, usecs;
1456
1457 if (getrusage (RUSAGE_SELF, &usage) < 0)
1458 /* This shouldn't happen. What action is appropriate? */
1459 xsignal0 (Qerror);
1460
1461 /* Sum up user time and system time. */
1462 secs = usage.ru_utime.tv_sec + usage.ru_stime.tv_sec;
1463 usecs = usage.ru_utime.tv_usec + usage.ru_stime.tv_usec;
1464 if (usecs >= 1000000)
1465 {
1466 usecs -= 1000000;
1467 secs++;
1468 }
1469
1470 return list3 (make_number ((secs >> 16) & 0xffff),
1471 make_number ((secs >> 0) & 0xffff),
1472 make_number (usecs));
1473 #else /* ! HAVE_GETRUSAGE */
1474 #ifdef WINDOWSNT
1475 return w32_get_internal_run_time ();
1476 #else /* ! WINDOWSNT */
1477 return Fcurrent_time ();
1478 #endif /* WINDOWSNT */
1479 #endif /* HAVE_GETRUSAGE */
1480 }
1481 \f
1482
1483 int
1484 lisp_time_argument (Lisp_Object specified_time, time_t *result, int *usec)
1485 {
1486 if (NILP (specified_time))
1487 {
1488 if (usec)
1489 {
1490 EMACS_TIME t;
1491
1492 EMACS_GET_TIME (t);
1493 *usec = EMACS_USECS (t);
1494 *result = EMACS_SECS (t);
1495 return 1;
1496 }
1497 else
1498 return time (result) != -1;
1499 }
1500 else
1501 {
1502 Lisp_Object high, low;
1503 high = Fcar (specified_time);
1504 CHECK_NUMBER (high);
1505 low = Fcdr (specified_time);
1506 if (CONSP (low))
1507 {
1508 if (usec)
1509 {
1510 Lisp_Object usec_l = Fcdr (low);
1511 if (CONSP (usec_l))
1512 usec_l = Fcar (usec_l);
1513 if (NILP (usec_l))
1514 *usec = 0;
1515 else
1516 {
1517 CHECK_NUMBER (usec_l);
1518 *usec = XINT (usec_l);
1519 }
1520 }
1521 low = Fcar (low);
1522 }
1523 else if (usec)
1524 *usec = 0;
1525 CHECK_NUMBER (low);
1526 *result = (XINT (high) << 16) + (XINT (low) & 0xffff);
1527 return *result >> 16 == XINT (high);
1528 }
1529 }
1530
1531 DEFUN ("float-time", Ffloat_time, Sfloat_time, 0, 1, 0,
1532 doc: /* Return the current time, as a float number of seconds since the epoch.
1533 If SPECIFIED-TIME is given, it is the time to convert to float
1534 instead of the current time. The argument should have the form
1535 (HIGH LOW) or (HIGH LOW USEC). Thus, you can use times obtained from
1536 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
1537 have the form (HIGH . LOW), but this is considered obsolete.
1538
1539 WARNING: Since the result is floating point, it may not be exact.
1540 If precise time stamps are required, use either `current-time',
1541 or (if you need time as a string) `format-time-string'. */)
1542 (Lisp_Object specified_time)
1543 {
1544 time_t sec;
1545 int usec;
1546
1547 if (! lisp_time_argument (specified_time, &sec, &usec))
1548 error ("Invalid time specification");
1549
1550 return make_float ((sec * 1e6 + usec) / 1e6);
1551 }
1552
1553 /* Write information into buffer S of size MAXSIZE, according to the
1554 FORMAT of length FORMAT_LEN, using time information taken from *TP.
1555 Default to Universal Time if UT is nonzero, local time otherwise.
1556 Return the number of bytes written, not including the terminating
1557 '\0'. If S is NULL, nothing will be written anywhere; so to
1558 determine how many bytes would be written, use NULL for S and
1559 ((size_t) -1) for MAXSIZE.
1560
1561 This function behaves like emacs_strftimeu, except it allows null
1562 bytes in FORMAT. */
1563 static size_t
1564 emacs_memftimeu (char *s, size_t maxsize, const char *format, size_t format_len, const struct tm *tp, int ut)
1565 {
1566 size_t total = 0;
1567
1568 /* Loop through all the null-terminated strings in the format
1569 argument. Normally there's just one null-terminated string, but
1570 there can be arbitrarily many, concatenated together, if the
1571 format contains '\0' bytes. emacs_strftimeu stops at the first
1572 '\0' byte so we must invoke it separately for each such string. */
1573 for (;;)
1574 {
1575 size_t len;
1576 size_t result;
1577
1578 if (s)
1579 s[0] = '\1';
1580
1581 result = emacs_strftimeu (s, maxsize, format, tp, ut);
1582
1583 if (s)
1584 {
1585 if (result == 0 && s[0] != '\0')
1586 return 0;
1587 s += result + 1;
1588 }
1589
1590 maxsize -= result + 1;
1591 total += result;
1592 len = strlen (format);
1593 if (len == format_len)
1594 return total;
1595 total++;
1596 format += len + 1;
1597 format_len -= len + 1;
1598 }
1599 }
1600
1601 DEFUN ("format-time-string", Fformat_time_string, Sformat_time_string, 1, 3, 0,
1602 doc: /* Use FORMAT-STRING to format the time TIME, or now if omitted.
1603 TIME is specified as (HIGH LOW . IGNORED), as returned by
1604 `current-time' or `file-attributes'. The obsolete form (HIGH . LOW)
1605 is also still accepted.
1606 The third, optional, argument UNIVERSAL, if non-nil, means describe TIME
1607 as Universal Time; nil means describe TIME in the local time zone.
1608 The value is a copy of FORMAT-STRING, but with certain constructs replaced
1609 by text that describes the specified date and time in TIME:
1610
1611 %Y is the year, %y within the century, %C the century.
1612 %G is the year corresponding to the ISO week, %g within the century.
1613 %m is the numeric month.
1614 %b and %h are the locale's abbreviated month name, %B the full name.
1615 %d is the day of the month, zero-padded, %e is blank-padded.
1616 %u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.
1617 %a is the locale's abbreviated name of the day of week, %A the full name.
1618 %U is the week number starting on Sunday, %W starting on Monday,
1619 %V according to ISO 8601.
1620 %j is the day of the year.
1621
1622 %H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H
1623 only blank-padded, %l is like %I blank-padded.
1624 %p is the locale's equivalent of either AM or PM.
1625 %M is the minute.
1626 %S is the second.
1627 %Z is the time zone name, %z is the numeric form.
1628 %s is the number of seconds since 1970-01-01 00:00:00 +0000.
1629
1630 %c is the locale's date and time format.
1631 %x is the locale's "preferred" date format.
1632 %D is like "%m/%d/%y".
1633
1634 %R is like "%H:%M", %T is like "%H:%M:%S", %r is like "%I:%M:%S %p".
1635 %X is the locale's "preferred" time format.
1636
1637 Finally, %n is a newline, %t is a tab, %% is a literal %.
1638
1639 Certain flags and modifiers are available with some format controls.
1640 The flags are `_', `-', `^' and `#'. For certain characters X,
1641 %_X is like %X, but padded with blanks; %-X is like %X,
1642 but without padding. %^X is like %X, but with all textual
1643 characters up-cased; %#X is like %X, but with letter-case of
1644 all textual characters reversed.
1645 %NX (where N stands for an integer) is like %X,
1646 but takes up at least N (a number) positions.
1647 The modifiers are `E' and `O'. For certain characters X,
1648 %EX is a locale's alternative version of %X;
1649 %OX is like %X, but uses the locale's number symbols.
1650
1651 For example, to produce full ISO 8601 format, use "%Y-%m-%dT%T%z". */)
1652 (Lisp_Object format_string, Lisp_Object time, Lisp_Object universal)
1653 {
1654 time_t value;
1655 int size;
1656 struct tm *tm;
1657 int ut = ! NILP (universal);
1658
1659 CHECK_STRING (format_string);
1660
1661 if (! lisp_time_argument (time, &value, NULL))
1662 error ("Invalid time specification");
1663
1664 format_string = code_convert_string_norecord (format_string,
1665 Vlocale_coding_system, 1);
1666
1667 /* This is probably enough. */
1668 size = SBYTES (format_string) * 6 + 50;
1669
1670 BLOCK_INPUT;
1671 tm = ut ? gmtime (&value) : localtime (&value);
1672 UNBLOCK_INPUT;
1673 if (! tm)
1674 error ("Specified time is not representable");
1675
1676 synchronize_system_time_locale ();
1677
1678 while (1)
1679 {
1680 char *buf = (char *) alloca (size + 1);
1681 int result;
1682
1683 buf[0] = '\1';
1684 BLOCK_INPUT;
1685 result = emacs_memftimeu (buf, size, SDATA (format_string),
1686 SBYTES (format_string),
1687 tm, ut);
1688 UNBLOCK_INPUT;
1689 if ((result > 0 && result < size) || (result == 0 && buf[0] == '\0'))
1690 return code_convert_string_norecord (make_unibyte_string (buf, result),
1691 Vlocale_coding_system, 0);
1692
1693 /* If buffer was too small, make it bigger and try again. */
1694 BLOCK_INPUT;
1695 result = emacs_memftimeu (NULL, (size_t) -1,
1696 SDATA (format_string),
1697 SBYTES (format_string),
1698 tm, ut);
1699 UNBLOCK_INPUT;
1700 size = result + 1;
1701 }
1702 }
1703
1704 DEFUN ("decode-time", Fdecode_time, Sdecode_time, 0, 1, 0,
1705 doc: /* Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST ZONE).
1706 The optional SPECIFIED-TIME should be a list of (HIGH LOW . IGNORED),
1707 as from `current-time' and `file-attributes', or nil to use the
1708 current time. The obsolete form (HIGH . LOW) is also still accepted.
1709 The list has the following nine members: SEC is an integer between 0
1710 and 60; SEC is 60 for a leap second, which only some operating systems
1711 support. MINUTE is an integer between 0 and 59. HOUR is an integer
1712 between 0 and 23. DAY is an integer between 1 and 31. MONTH is an
1713 integer between 1 and 12. YEAR is an integer indicating the
1714 four-digit year. DOW is the day of week, an integer between 0 and 6,
1715 where 0 is Sunday. DST is t if daylight saving time is in effect,
1716 otherwise nil. ZONE is an integer indicating the number of seconds
1717 east of Greenwich. (Note that Common Lisp has different meanings for
1718 DOW and ZONE.) */)
1719 (Lisp_Object specified_time)
1720 {
1721 time_t time_spec;
1722 struct tm save_tm;
1723 struct tm *decoded_time;
1724 Lisp_Object list_args[9];
1725
1726 if (! lisp_time_argument (specified_time, &time_spec, NULL))
1727 error ("Invalid time specification");
1728
1729 BLOCK_INPUT;
1730 decoded_time = localtime (&time_spec);
1731 UNBLOCK_INPUT;
1732 if (! decoded_time)
1733 error ("Specified time is not representable");
1734 XSETFASTINT (list_args[0], decoded_time->tm_sec);
1735 XSETFASTINT (list_args[1], decoded_time->tm_min);
1736 XSETFASTINT (list_args[2], decoded_time->tm_hour);
1737 XSETFASTINT (list_args[3], decoded_time->tm_mday);
1738 XSETFASTINT (list_args[4], decoded_time->tm_mon + 1);
1739 /* On 64-bit machines an int is narrower than EMACS_INT, thus the
1740 cast below avoids overflow in int arithmetics. */
1741 XSETINT (list_args[5], TM_YEAR_BASE + (EMACS_INT) decoded_time->tm_year);
1742 XSETFASTINT (list_args[6], decoded_time->tm_wday);
1743 list_args[7] = (decoded_time->tm_isdst)? Qt : Qnil;
1744
1745 /* Make a copy, in case gmtime modifies the struct. */
1746 save_tm = *decoded_time;
1747 BLOCK_INPUT;
1748 decoded_time = gmtime (&time_spec);
1749 UNBLOCK_INPUT;
1750 if (decoded_time == 0)
1751 list_args[8] = Qnil;
1752 else
1753 XSETINT (list_args[8], tm_diff (&save_tm, decoded_time));
1754 return Flist (9, list_args);
1755 }
1756
1757 DEFUN ("encode-time", Fencode_time, Sencode_time, 6, MANY, 0,
1758 doc: /* Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.
1759 This is the reverse operation of `decode-time', which see.
1760 ZONE defaults to the current time zone rule. This can
1761 be a string or t (as from `set-time-zone-rule'), or it can be a list
1762 \(as from `current-time-zone') or an integer (as from `decode-time')
1763 applied without consideration for daylight saving time.
1764
1765 You can pass more than 7 arguments; then the first six arguments
1766 are used as SECOND through YEAR, and the *last* argument is used as ZONE.
1767 The intervening arguments are ignored.
1768 This feature lets (apply 'encode-time (decode-time ...)) work.
1769
1770 Out-of-range values for SECOND, MINUTE, HOUR, DAY, or MONTH are allowed;
1771 for example, a DAY of 0 means the day preceding the given month.
1772 Year numbers less than 100 are treated just like other year numbers.
1773 If you want them to stand for years in this century, you must do that yourself.
1774
1775 Years before 1970 are not guaranteed to work. On some systems,
1776 year values as low as 1901 do work.
1777
1778 usage: (encode-time SECOND MINUTE HOUR DAY MONTH YEAR &optional ZONE) */)
1779 (int nargs, register Lisp_Object *args)
1780 {
1781 time_t time;
1782 struct tm tm;
1783 Lisp_Object zone = (nargs > 6 ? args[nargs - 1] : Qnil);
1784
1785 CHECK_NUMBER (args[0]); /* second */
1786 CHECK_NUMBER (args[1]); /* minute */
1787 CHECK_NUMBER (args[2]); /* hour */
1788 CHECK_NUMBER (args[3]); /* day */
1789 CHECK_NUMBER (args[4]); /* month */
1790 CHECK_NUMBER (args[5]); /* year */
1791
1792 tm.tm_sec = XINT (args[0]);
1793 tm.tm_min = XINT (args[1]);
1794 tm.tm_hour = XINT (args[2]);
1795 tm.tm_mday = XINT (args[3]);
1796 tm.tm_mon = XINT (args[4]) - 1;
1797 tm.tm_year = XINT (args[5]) - TM_YEAR_BASE;
1798 tm.tm_isdst = -1;
1799
1800 if (CONSP (zone))
1801 zone = Fcar (zone);
1802 if (NILP (zone))
1803 {
1804 BLOCK_INPUT;
1805 time = mktime (&tm);
1806 UNBLOCK_INPUT;
1807 }
1808 else
1809 {
1810 char tzbuf[100];
1811 const char *tzstring;
1812 char **oldenv = environ, **newenv;
1813
1814 if (EQ (zone, Qt))
1815 tzstring = "UTC0";
1816 else if (STRINGP (zone))
1817 tzstring = SSDATA (zone);
1818 else if (INTEGERP (zone))
1819 {
1820 int abszone = eabs (XINT (zone));
1821 sprintf (tzbuf, "XXX%s%d:%02d:%02d", "-" + (XINT (zone) < 0),
1822 abszone / (60*60), (abszone/60) % 60, abszone % 60);
1823 tzstring = tzbuf;
1824 }
1825 else
1826 error ("Invalid time zone specification");
1827
1828 /* Set TZ before calling mktime; merely adjusting mktime's returned
1829 value doesn't suffice, since that would mishandle leap seconds. */
1830 set_time_zone_rule (tzstring);
1831
1832 BLOCK_INPUT;
1833 time = mktime (&tm);
1834 UNBLOCK_INPUT;
1835
1836 /* Restore TZ to previous value. */
1837 newenv = environ;
1838 environ = oldenv;
1839 xfree (newenv);
1840 #ifdef LOCALTIME_CACHE
1841 tzset ();
1842 #endif
1843 }
1844
1845 if (time == (time_t) -1)
1846 error ("Specified time is not representable");
1847
1848 return make_time (time);
1849 }
1850
1851 DEFUN ("current-time-string", Fcurrent_time_string, Scurrent_time_string, 0, 1, 0,
1852 doc: /* Return the current local time, as a human-readable string.
1853 Programs can use this function to decode a time,
1854 since the number of columns in each field is fixed
1855 if the year is in the range 1000-9999.
1856 The format is `Sun Sep 16 01:03:52 1973'.
1857 However, see also the functions `decode-time' and `format-time-string'
1858 which provide a much more powerful and general facility.
1859
1860 If SPECIFIED-TIME is given, it is a time to format instead of the
1861 current time. The argument should have the form (HIGH LOW . IGNORED).
1862 Thus, you can use times obtained from `current-time' and from
1863 `file-attributes'. SPECIFIED-TIME can also have the form (HIGH . LOW),
1864 but this is considered obsolete. */)
1865 (Lisp_Object specified_time)
1866 {
1867 time_t value;
1868 struct tm *tm;
1869 register char *tem;
1870
1871 if (! lisp_time_argument (specified_time, &value, NULL))
1872 error ("Invalid time specification");
1873
1874 /* Convert to a string, checking for out-of-range time stamps.
1875 Don't use 'ctime', as that might dump core if VALUE is out of
1876 range. */
1877 BLOCK_INPUT;
1878 tm = localtime (&value);
1879 UNBLOCK_INPUT;
1880 if (! (tm && TM_YEAR_IN_ASCTIME_RANGE (tm->tm_year) && (tem = asctime (tm))))
1881 error ("Specified time is not representable");
1882
1883 /* Remove the trailing newline. */
1884 tem[strlen (tem) - 1] = '\0';
1885
1886 return build_string (tem);
1887 }
1888
1889 /* Yield A - B, measured in seconds.
1890 This function is copied from the GNU C Library. */
1891 static int
1892 tm_diff (struct tm *a, struct tm *b)
1893 {
1894 /* Compute intervening leap days correctly even if year is negative.
1895 Take care to avoid int overflow in leap day calculations,
1896 but it's OK to assume that A and B are close to each other. */
1897 int a4 = (a->tm_year >> 2) + (TM_YEAR_BASE >> 2) - ! (a->tm_year & 3);
1898 int b4 = (b->tm_year >> 2) + (TM_YEAR_BASE >> 2) - ! (b->tm_year & 3);
1899 int a100 = a4 / 25 - (a4 % 25 < 0);
1900 int b100 = b4 / 25 - (b4 % 25 < 0);
1901 int a400 = a100 >> 2;
1902 int b400 = b100 >> 2;
1903 int intervening_leap_days = (a4 - b4) - (a100 - b100) + (a400 - b400);
1904 int years = a->tm_year - b->tm_year;
1905 int days = (365 * years + intervening_leap_days
1906 + (a->tm_yday - b->tm_yday));
1907 return (60 * (60 * (24 * days + (a->tm_hour - b->tm_hour))
1908 + (a->tm_min - b->tm_min))
1909 + (a->tm_sec - b->tm_sec));
1910 }
1911
1912 DEFUN ("current-time-zone", Fcurrent_time_zone, Scurrent_time_zone, 0, 1, 0,
1913 doc: /* Return the offset and name for the local time zone.
1914 This returns a list of the form (OFFSET NAME).
1915 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).
1916 A negative value means west of Greenwich.
1917 NAME is a string giving the name of the time zone.
1918 If SPECIFIED-TIME is given, the time zone offset is determined from it
1919 instead of using the current time. The argument should have the form
1920 (HIGH LOW . IGNORED). Thus, you can use times obtained from
1921 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
1922 have the form (HIGH . LOW), but this is considered obsolete.
1923
1924 Some operating systems cannot provide all this information to Emacs;
1925 in this case, `current-time-zone' returns a list containing nil for
1926 the data it can't find. */)
1927 (Lisp_Object specified_time)
1928 {
1929 time_t value;
1930 struct tm *t;
1931 struct tm gmt;
1932
1933 if (!lisp_time_argument (specified_time, &value, NULL))
1934 t = NULL;
1935 else
1936 {
1937 BLOCK_INPUT;
1938 t = gmtime (&value);
1939 if (t)
1940 {
1941 gmt = *t;
1942 t = localtime (&value);
1943 }
1944 UNBLOCK_INPUT;
1945 }
1946
1947 if (t)
1948 {
1949 int offset = tm_diff (t, &gmt);
1950 char *s = 0;
1951 char buf[6];
1952
1953 #ifdef HAVE_TM_ZONE
1954 if (t->tm_zone)
1955 s = (char *)t->tm_zone;
1956 #else /* not HAVE_TM_ZONE */
1957 #ifdef HAVE_TZNAME
1958 if (t->tm_isdst == 0 || t->tm_isdst == 1)
1959 s = tzname[t->tm_isdst];
1960 #endif
1961 #endif /* not HAVE_TM_ZONE */
1962
1963 if (!s)
1964 {
1965 /* No local time zone name is available; use "+-NNNN" instead. */
1966 int am = (offset < 0 ? -offset : offset) / 60;
1967 sprintf (buf, "%c%02d%02d", (offset < 0 ? '-' : '+'), am/60, am%60);
1968 s = buf;
1969 }
1970
1971 return Fcons (make_number (offset), Fcons (build_string (s), Qnil));
1972 }
1973 else
1974 return Fmake_list (make_number (2), Qnil);
1975 }
1976
1977 /* This holds the value of `environ' produced by the previous
1978 call to Fset_time_zone_rule, or 0 if Fset_time_zone_rule
1979 has never been called. */
1980 static char **environbuf;
1981
1982 /* This holds the startup value of the TZ environment variable so it
1983 can be restored if the user calls set-time-zone-rule with a nil
1984 argument. */
1985 static char *initial_tz;
1986
1987 DEFUN ("set-time-zone-rule", Fset_time_zone_rule, Sset_time_zone_rule, 1, 1, 0,
1988 doc: /* Set the local time zone using TZ, a string specifying a time zone rule.
1989 If TZ is nil, use implementation-defined default time zone information.
1990 If TZ is t, use Universal Time. */)
1991 (Lisp_Object tz)
1992 {
1993 const char *tzstring;
1994
1995 /* When called for the first time, save the original TZ. */
1996 if (!environbuf)
1997 initial_tz = (char *) getenv ("TZ");
1998
1999 if (NILP (tz))
2000 tzstring = initial_tz;
2001 else if (EQ (tz, Qt))
2002 tzstring = "UTC0";
2003 else
2004 {
2005 CHECK_STRING (tz);
2006 tzstring = SSDATA (tz);
2007 }
2008
2009 set_time_zone_rule (tzstring);
2010 free (environbuf);
2011 environbuf = environ;
2012
2013 return Qnil;
2014 }
2015
2016 #ifdef LOCALTIME_CACHE
2017
2018 /* These two values are known to load tz files in buggy implementations,
2019 i.e. Solaris 1 executables running under either Solaris 1 or Solaris 2.
2020 Their values shouldn't matter in non-buggy implementations.
2021 We don't use string literals for these strings,
2022 since if a string in the environment is in readonly
2023 storage, it runs afoul of bugs in SVR4 and Solaris 2.3.
2024 See Sun bugs 1113095 and 1114114, ``Timezone routines
2025 improperly modify environment''. */
2026
2027 static char set_time_zone_rule_tz1[] = "TZ=GMT+0";
2028 static char set_time_zone_rule_tz2[] = "TZ=GMT+1";
2029
2030 #endif
2031
2032 /* Set the local time zone rule to TZSTRING.
2033 This allocates memory into `environ', which it is the caller's
2034 responsibility to free. */
2035
2036 void
2037 set_time_zone_rule (const char *tzstring)
2038 {
2039 int envptrs;
2040 char **from, **to, **newenv;
2041
2042 /* Make the ENVIRON vector longer with room for TZSTRING. */
2043 for (from = environ; *from; from++)
2044 continue;
2045 envptrs = from - environ + 2;
2046 newenv = to = (char **) xmalloc (envptrs * sizeof (char *)
2047 + (tzstring ? strlen (tzstring) + 4 : 0));
2048
2049 /* Add TZSTRING to the end of environ, as a value for TZ. */
2050 if (tzstring)
2051 {
2052 char *t = (char *) (to + envptrs);
2053 strcpy (t, "TZ=");
2054 strcat (t, tzstring);
2055 *to++ = t;
2056 }
2057
2058 /* Copy the old environ vector elements into NEWENV,
2059 but don't copy the TZ variable.
2060 So we have only one definition of TZ, which came from TZSTRING. */
2061 for (from = environ; *from; from++)
2062 if (strncmp (*from, "TZ=", 3) != 0)
2063 *to++ = *from;
2064 *to = 0;
2065
2066 environ = newenv;
2067
2068 /* If we do have a TZSTRING, NEWENV points to the vector slot where
2069 the TZ variable is stored. If we do not have a TZSTRING,
2070 TO points to the vector slot which has the terminating null. */
2071
2072 #ifdef LOCALTIME_CACHE
2073 {
2074 /* In SunOS 4.1.3_U1 and 4.1.4, if TZ has a value like
2075 "US/Pacific" that loads a tz file, then changes to a value like
2076 "XXX0" that does not load a tz file, and then changes back to
2077 its original value, the last change is (incorrectly) ignored.
2078 Also, if TZ changes twice in succession to values that do
2079 not load a tz file, tzset can dump core (see Sun bug#1225179).
2080 The following code works around these bugs. */
2081
2082 if (tzstring)
2083 {
2084 /* Temporarily set TZ to a value that loads a tz file
2085 and that differs from tzstring. */
2086 char *tz = *newenv;
2087 *newenv = (strcmp (tzstring, set_time_zone_rule_tz1 + 3) == 0
2088 ? set_time_zone_rule_tz2 : set_time_zone_rule_tz1);
2089 tzset ();
2090 *newenv = tz;
2091 }
2092 else
2093 {
2094 /* The implied tzstring is unknown, so temporarily set TZ to
2095 two different values that each load a tz file. */
2096 *to = set_time_zone_rule_tz1;
2097 to[1] = 0;
2098 tzset ();
2099 *to = set_time_zone_rule_tz2;
2100 tzset ();
2101 *to = 0;
2102 }
2103
2104 /* Now TZ has the desired value, and tzset can be invoked safely. */
2105 }
2106
2107 tzset ();
2108 #endif
2109 }
2110 \f
2111 /* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC
2112 (if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a
2113 type of object is Lisp_String). INHERIT is passed to
2114 INSERT_FROM_STRING_FUNC as the last argument. */
2115
2116 static void
2117 general_insert_function (void (*insert_func)
2118 (const unsigned char *, EMACS_INT),
2119 void (*insert_from_string_func)
2120 (Lisp_Object, EMACS_INT, EMACS_INT,
2121 EMACS_INT, EMACS_INT, int),
2122 int inherit, int nargs, Lisp_Object *args)
2123 {
2124 register int argnum;
2125 register Lisp_Object val;
2126
2127 for (argnum = 0; argnum < nargs; argnum++)
2128 {
2129 val = args[argnum];
2130 if (CHARACTERP (val))
2131 {
2132 unsigned char str[MAX_MULTIBYTE_LENGTH];
2133 int len;
2134
2135 if (!NILP (current_buffer->enable_multibyte_characters))
2136 len = CHAR_STRING (XFASTINT (val), str);
2137 else
2138 {
2139 str[0] = (ASCII_CHAR_P (XINT (val))
2140 ? XINT (val)
2141 : multibyte_char_to_unibyte (XINT (val), Qnil));
2142 len = 1;
2143 }
2144 (*insert_func) (str, len);
2145 }
2146 else if (STRINGP (val))
2147 {
2148 (*insert_from_string_func) (val, 0, 0,
2149 SCHARS (val),
2150 SBYTES (val),
2151 inherit);
2152 }
2153 else
2154 wrong_type_argument (Qchar_or_string_p, val);
2155 }
2156 }
2157
2158 void
2159 insert1 (Lisp_Object arg)
2160 {
2161 Finsert (1, &arg);
2162 }
2163
2164
2165 /* Callers passing one argument to Finsert need not gcpro the
2166 argument "array", since the only element of the array will
2167 not be used after calling insert or insert_from_string, so
2168 we don't care if it gets trashed. */
2169
2170 DEFUN ("insert", Finsert, Sinsert, 0, MANY, 0,
2171 doc: /* Insert the arguments, either strings or characters, at point.
2172 Point and before-insertion markers move forward to end up
2173 after the inserted text.
2174 Any other markers at the point of insertion remain before the text.
2175
2176 If the current buffer is multibyte, unibyte strings are converted
2177 to multibyte for insertion (see `string-make-multibyte').
2178 If the current buffer is unibyte, multibyte strings are converted
2179 to unibyte for insertion (see `string-make-unibyte').
2180
2181 When operating on binary data, it may be necessary to preserve the
2182 original bytes of a unibyte string when inserting it into a multibyte
2183 buffer; to accomplish this, apply `string-as-multibyte' to the string
2184 and insert the result.
2185
2186 usage: (insert &rest ARGS) */)
2187 (int nargs, register Lisp_Object *args)
2188 {
2189 general_insert_function (insert, insert_from_string, 0, nargs, args);
2190 return Qnil;
2191 }
2192
2193 DEFUN ("insert-and-inherit", Finsert_and_inherit, Sinsert_and_inherit,
2194 0, MANY, 0,
2195 doc: /* Insert the arguments at point, inheriting properties from adjoining text.
2196 Point and before-insertion markers move forward to end up
2197 after the inserted text.
2198 Any other markers at the point of insertion remain before the text.
2199
2200 If the current buffer is multibyte, unibyte strings are converted
2201 to multibyte for insertion (see `unibyte-char-to-multibyte').
2202 If the current buffer is unibyte, multibyte strings are converted
2203 to unibyte for insertion.
2204
2205 usage: (insert-and-inherit &rest ARGS) */)
2206 (int nargs, register Lisp_Object *args)
2207 {
2208 general_insert_function (insert_and_inherit, insert_from_string, 1,
2209 nargs, args);
2210 return Qnil;
2211 }
2212
2213 DEFUN ("insert-before-markers", Finsert_before_markers, Sinsert_before_markers, 0, MANY, 0,
2214 doc: /* Insert strings or characters at point, relocating markers after the text.
2215 Point and markers move forward to end up after the inserted text.
2216
2217 If the current buffer is multibyte, unibyte strings are converted
2218 to multibyte for insertion (see `unibyte-char-to-multibyte').
2219 If the current buffer is unibyte, multibyte strings are converted
2220 to unibyte for insertion.
2221
2222 usage: (insert-before-markers &rest ARGS) */)
2223 (int nargs, register Lisp_Object *args)
2224 {
2225 general_insert_function (insert_before_markers,
2226 insert_from_string_before_markers, 0,
2227 nargs, args);
2228 return Qnil;
2229 }
2230
2231 DEFUN ("insert-before-markers-and-inherit", Finsert_and_inherit_before_markers,
2232 Sinsert_and_inherit_before_markers, 0, MANY, 0,
2233 doc: /* Insert text at point, relocating markers and inheriting properties.
2234 Point and markers move forward to end up after the inserted text.
2235
2236 If the current buffer is multibyte, unibyte strings are converted
2237 to multibyte for insertion (see `unibyte-char-to-multibyte').
2238 If the current buffer is unibyte, multibyte strings are converted
2239 to unibyte for insertion.
2240
2241 usage: (insert-before-markers-and-inherit &rest ARGS) */)
2242 (int nargs, register Lisp_Object *args)
2243 {
2244 general_insert_function (insert_before_markers_and_inherit,
2245 insert_from_string_before_markers, 1,
2246 nargs, args);
2247 return Qnil;
2248 }
2249 \f
2250 DEFUN ("insert-char", Finsert_char, Sinsert_char, 2, 3, 0,
2251 doc: /* Insert COUNT copies of CHARACTER.
2252 Point, and before-insertion markers, are relocated as in the function `insert'.
2253 The optional third arg INHERIT, if non-nil, says to inherit text properties
2254 from adjoining text, if those properties are sticky. */)
2255 (Lisp_Object character, Lisp_Object count, Lisp_Object inherit)
2256 {
2257 register unsigned char *string;
2258 register EMACS_INT strlen;
2259 register int i;
2260 register EMACS_INT n;
2261 int len;
2262 unsigned char str[MAX_MULTIBYTE_LENGTH];
2263
2264 CHECK_NUMBER (character);
2265 CHECK_NUMBER (count);
2266
2267 if (!NILP (current_buffer->enable_multibyte_characters))
2268 len = CHAR_STRING (XFASTINT (character), str);
2269 else
2270 str[0] = XFASTINT (character), len = 1;
2271 if (MOST_POSITIVE_FIXNUM / len < XINT (count))
2272 error ("Maximum buffer size would be exceeded");
2273 n = XINT (count) * len;
2274 if (n <= 0)
2275 return Qnil;
2276 strlen = min (n, 256 * len);
2277 string = (unsigned char *) alloca (strlen);
2278 for (i = 0; i < strlen; i++)
2279 string[i] = str[i % len];
2280 while (n >= strlen)
2281 {
2282 QUIT;
2283 if (!NILP (inherit))
2284 insert_and_inherit (string, strlen);
2285 else
2286 insert (string, strlen);
2287 n -= strlen;
2288 }
2289 if (n > 0)
2290 {
2291 if (!NILP (inherit))
2292 insert_and_inherit (string, n);
2293 else
2294 insert (string, n);
2295 }
2296 return Qnil;
2297 }
2298
2299 DEFUN ("insert-byte", Finsert_byte, Sinsert_byte, 2, 3, 0,
2300 doc: /* Insert COUNT (second arg) copies of BYTE (first arg).
2301 Both arguments are required.
2302 BYTE is a number of the range 0..255.
2303
2304 If BYTE is 128..255 and the current buffer is multibyte, the
2305 corresponding eight-bit character is inserted.
2306
2307 Point, and before-insertion markers, are relocated as in the function `insert'.
2308 The optional third arg INHERIT, if non-nil, says to inherit text properties
2309 from adjoining text, if those properties are sticky. */)
2310 (Lisp_Object byte, Lisp_Object count, Lisp_Object inherit)
2311 {
2312 CHECK_NUMBER (byte);
2313 if (XINT (byte) < 0 || XINT (byte) > 255)
2314 args_out_of_range_3 (byte, make_number (0), make_number (255));
2315 if (XINT (byte) >= 128
2316 && ! NILP (current_buffer->enable_multibyte_characters))
2317 XSETFASTINT (byte, BYTE8_TO_CHAR (XINT (byte)));
2318 return Finsert_char (byte, count, inherit);
2319 }
2320
2321 \f
2322 /* Making strings from buffer contents. */
2323
2324 /* Return a Lisp_String containing the text of the current buffer from
2325 START to END. If text properties are in use and the current buffer
2326 has properties in the range specified, the resulting string will also
2327 have them, if PROPS is nonzero.
2328
2329 We don't want to use plain old make_string here, because it calls
2330 make_uninit_string, which can cause the buffer arena to be
2331 compacted. make_string has no way of knowing that the data has
2332 been moved, and thus copies the wrong data into the string. This
2333 doesn't effect most of the other users of make_string, so it should
2334 be left as is. But we should use this function when conjuring
2335 buffer substrings. */
2336
2337 Lisp_Object
2338 make_buffer_string (EMACS_INT start, EMACS_INT end, int props)
2339 {
2340 EMACS_INT start_byte = CHAR_TO_BYTE (start);
2341 EMACS_INT end_byte = CHAR_TO_BYTE (end);
2342
2343 return make_buffer_string_both (start, start_byte, end, end_byte, props);
2344 }
2345
2346 /* Return a Lisp_String containing the text of the current buffer from
2347 START / START_BYTE to END / END_BYTE.
2348
2349 If text properties are in use and the current buffer
2350 has properties in the range specified, the resulting string will also
2351 have them, if PROPS is nonzero.
2352
2353 We don't want to use plain old make_string here, because it calls
2354 make_uninit_string, which can cause the buffer arena to be
2355 compacted. make_string has no way of knowing that the data has
2356 been moved, and thus copies the wrong data into the string. This
2357 doesn't effect most of the other users of make_string, so it should
2358 be left as is. But we should use this function when conjuring
2359 buffer substrings. */
2360
2361 Lisp_Object
2362 make_buffer_string_both (EMACS_INT start, EMACS_INT start_byte,
2363 EMACS_INT end, EMACS_INT end_byte, int props)
2364 {
2365 Lisp_Object result, tem, tem1;
2366
2367 if (start < GPT && GPT < end)
2368 move_gap (start);
2369
2370 if (! NILP (current_buffer->enable_multibyte_characters))
2371 result = make_uninit_multibyte_string (end - start, end_byte - start_byte);
2372 else
2373 result = make_uninit_string (end - start);
2374 memcpy (SDATA (result), BYTE_POS_ADDR (start_byte), end_byte - start_byte);
2375
2376 /* If desired, update and copy the text properties. */
2377 if (props)
2378 {
2379 update_buffer_properties (start, end);
2380
2381 tem = Fnext_property_change (make_number (start), Qnil, make_number (end));
2382 tem1 = Ftext_properties_at (make_number (start), Qnil);
2383
2384 if (XINT (tem) != end || !NILP (tem1))
2385 copy_intervals_to_string (result, current_buffer, start,
2386 end - start);
2387 }
2388
2389 return result;
2390 }
2391
2392 /* Call Vbuffer_access_fontify_functions for the range START ... END
2393 in the current buffer, if necessary. */
2394
2395 static void
2396 update_buffer_properties (EMACS_INT start, EMACS_INT end)
2397 {
2398 /* If this buffer has some access functions,
2399 call them, specifying the range of the buffer being accessed. */
2400 if (!NILP (Vbuffer_access_fontify_functions))
2401 {
2402 Lisp_Object args[3];
2403 Lisp_Object tem;
2404
2405 args[0] = Qbuffer_access_fontify_functions;
2406 XSETINT (args[1], start);
2407 XSETINT (args[2], end);
2408
2409 /* But don't call them if we can tell that the work
2410 has already been done. */
2411 if (!NILP (Vbuffer_access_fontified_property))
2412 {
2413 tem = Ftext_property_any (args[1], args[2],
2414 Vbuffer_access_fontified_property,
2415 Qnil, Qnil);
2416 if (! NILP (tem))
2417 Frun_hook_with_args (3, args);
2418 }
2419 else
2420 Frun_hook_with_args (3, args);
2421 }
2422 }
2423
2424 DEFUN ("buffer-substring", Fbuffer_substring, Sbuffer_substring, 2, 2, 0,
2425 doc: /* Return the contents of part of the current buffer as a string.
2426 The two arguments START and END are character positions;
2427 they can be in either order.
2428 The string returned is multibyte if the buffer is multibyte.
2429
2430 This function copies the text properties of that part of the buffer
2431 into the result string; if you don't want the text properties,
2432 use `buffer-substring-no-properties' instead. */)
2433 (Lisp_Object start, Lisp_Object end)
2434 {
2435 register EMACS_INT b, e;
2436
2437 validate_region (&start, &end);
2438 b = XINT (start);
2439 e = XINT (end);
2440
2441 return make_buffer_string (b, e, 1);
2442 }
2443
2444 DEFUN ("buffer-substring-no-properties", Fbuffer_substring_no_properties,
2445 Sbuffer_substring_no_properties, 2, 2, 0,
2446 doc: /* Return the characters of part of the buffer, without the text properties.
2447 The two arguments START and END are character positions;
2448 they can be in either order. */)
2449 (Lisp_Object start, Lisp_Object end)
2450 {
2451 register EMACS_INT b, e;
2452
2453 validate_region (&start, &end);
2454 b = XINT (start);
2455 e = XINT (end);
2456
2457 return make_buffer_string (b, e, 0);
2458 }
2459
2460 DEFUN ("buffer-string", Fbuffer_string, Sbuffer_string, 0, 0, 0,
2461 doc: /* Return the contents of the current buffer as a string.
2462 If narrowing is in effect, this function returns only the visible part
2463 of the buffer. */)
2464 (void)
2465 {
2466 return make_buffer_string (BEGV, ZV, 1);
2467 }
2468
2469 DEFUN ("insert-buffer-substring", Finsert_buffer_substring, Sinsert_buffer_substring,
2470 1, 3, 0,
2471 doc: /* Insert before point a substring of the contents of BUFFER.
2472 BUFFER may be a buffer or a buffer name.
2473 Arguments START and END are character positions specifying the substring.
2474 They default to the values of (point-min) and (point-max) in BUFFER. */)
2475 (Lisp_Object buffer, Lisp_Object start, Lisp_Object end)
2476 {
2477 register EMACS_INT b, e, temp;
2478 register struct buffer *bp, *obuf;
2479 Lisp_Object buf;
2480
2481 buf = Fget_buffer (buffer);
2482 if (NILP (buf))
2483 nsberror (buffer);
2484 bp = XBUFFER (buf);
2485 if (NILP (bp->name))
2486 error ("Selecting deleted buffer");
2487
2488 if (NILP (start))
2489 b = BUF_BEGV (bp);
2490 else
2491 {
2492 CHECK_NUMBER_COERCE_MARKER (start);
2493 b = XINT (start);
2494 }
2495 if (NILP (end))
2496 e = BUF_ZV (bp);
2497 else
2498 {
2499 CHECK_NUMBER_COERCE_MARKER (end);
2500 e = XINT (end);
2501 }
2502
2503 if (b > e)
2504 temp = b, b = e, e = temp;
2505
2506 if (!(BUF_BEGV (bp) <= b && e <= BUF_ZV (bp)))
2507 args_out_of_range (start, end);
2508
2509 obuf = current_buffer;
2510 set_buffer_internal_1 (bp);
2511 update_buffer_properties (b, e);
2512 set_buffer_internal_1 (obuf);
2513
2514 insert_from_buffer (bp, b, e - b, 0);
2515 return Qnil;
2516 }
2517
2518 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings, Scompare_buffer_substrings,
2519 6, 6, 0,
2520 doc: /* Compare two substrings of two buffers; return result as number.
2521 the value is -N if first string is less after N-1 chars,
2522 +N if first string is greater after N-1 chars, or 0 if strings match.
2523 Each substring is represented as three arguments: BUFFER, START and END.
2524 That makes six args in all, three for each substring.
2525
2526 The value of `case-fold-search' in the current buffer
2527 determines whether case is significant or ignored. */)
2528 (Lisp_Object buffer1, Lisp_Object start1, Lisp_Object end1, Lisp_Object buffer2, Lisp_Object start2, Lisp_Object end2)
2529 {
2530 register EMACS_INT begp1, endp1, begp2, endp2, temp;
2531 register struct buffer *bp1, *bp2;
2532 register Lisp_Object trt
2533 = (!NILP (current_buffer->case_fold_search)
2534 ? current_buffer->case_canon_table : Qnil);
2535 EMACS_INT chars = 0;
2536 EMACS_INT i1, i2, i1_byte, i2_byte;
2537
2538 /* Find the first buffer and its substring. */
2539
2540 if (NILP (buffer1))
2541 bp1 = current_buffer;
2542 else
2543 {
2544 Lisp_Object buf1;
2545 buf1 = Fget_buffer (buffer1);
2546 if (NILP (buf1))
2547 nsberror (buffer1);
2548 bp1 = XBUFFER (buf1);
2549 if (NILP (bp1->name))
2550 error ("Selecting deleted buffer");
2551 }
2552
2553 if (NILP (start1))
2554 begp1 = BUF_BEGV (bp1);
2555 else
2556 {
2557 CHECK_NUMBER_COERCE_MARKER (start1);
2558 begp1 = XINT (start1);
2559 }
2560 if (NILP (end1))
2561 endp1 = BUF_ZV (bp1);
2562 else
2563 {
2564 CHECK_NUMBER_COERCE_MARKER (end1);
2565 endp1 = XINT (end1);
2566 }
2567
2568 if (begp1 > endp1)
2569 temp = begp1, begp1 = endp1, endp1 = temp;
2570
2571 if (!(BUF_BEGV (bp1) <= begp1
2572 && begp1 <= endp1
2573 && endp1 <= BUF_ZV (bp1)))
2574 args_out_of_range (start1, end1);
2575
2576 /* Likewise for second substring. */
2577
2578 if (NILP (buffer2))
2579 bp2 = current_buffer;
2580 else
2581 {
2582 Lisp_Object buf2;
2583 buf2 = Fget_buffer (buffer2);
2584 if (NILP (buf2))
2585 nsberror (buffer2);
2586 bp2 = XBUFFER (buf2);
2587 if (NILP (bp2->name))
2588 error ("Selecting deleted buffer");
2589 }
2590
2591 if (NILP (start2))
2592 begp2 = BUF_BEGV (bp2);
2593 else
2594 {
2595 CHECK_NUMBER_COERCE_MARKER (start2);
2596 begp2 = XINT (start2);
2597 }
2598 if (NILP (end2))
2599 endp2 = BUF_ZV (bp2);
2600 else
2601 {
2602 CHECK_NUMBER_COERCE_MARKER (end2);
2603 endp2 = XINT (end2);
2604 }
2605
2606 if (begp2 > endp2)
2607 temp = begp2, begp2 = endp2, endp2 = temp;
2608
2609 if (!(BUF_BEGV (bp2) <= begp2
2610 && begp2 <= endp2
2611 && endp2 <= BUF_ZV (bp2)))
2612 args_out_of_range (start2, end2);
2613
2614 i1 = begp1;
2615 i2 = begp2;
2616 i1_byte = buf_charpos_to_bytepos (bp1, i1);
2617 i2_byte = buf_charpos_to_bytepos (bp2, i2);
2618
2619 while (i1 < endp1 && i2 < endp2)
2620 {
2621 /* When we find a mismatch, we must compare the
2622 characters, not just the bytes. */
2623 int c1, c2;
2624
2625 QUIT;
2626
2627 if (! NILP (bp1->enable_multibyte_characters))
2628 {
2629 c1 = BUF_FETCH_MULTIBYTE_CHAR (bp1, i1_byte);
2630 BUF_INC_POS (bp1, i1_byte);
2631 i1++;
2632 }
2633 else
2634 {
2635 c1 = BUF_FETCH_BYTE (bp1, i1);
2636 MAKE_CHAR_MULTIBYTE (c1);
2637 i1++;
2638 }
2639
2640 if (! NILP (bp2->enable_multibyte_characters))
2641 {
2642 c2 = BUF_FETCH_MULTIBYTE_CHAR (bp2, i2_byte);
2643 BUF_INC_POS (bp2, i2_byte);
2644 i2++;
2645 }
2646 else
2647 {
2648 c2 = BUF_FETCH_BYTE (bp2, i2);
2649 MAKE_CHAR_MULTIBYTE (c2);
2650 i2++;
2651 }
2652
2653 if (!NILP (trt))
2654 {
2655 c1 = CHAR_TABLE_TRANSLATE (trt, c1);
2656 c2 = CHAR_TABLE_TRANSLATE (trt, c2);
2657 }
2658 if (c1 < c2)
2659 return make_number (- 1 - chars);
2660 if (c1 > c2)
2661 return make_number (chars + 1);
2662
2663 chars++;
2664 }
2665
2666 /* The strings match as far as they go.
2667 If one is shorter, that one is less. */
2668 if (chars < endp1 - begp1)
2669 return make_number (chars + 1);
2670 else if (chars < endp2 - begp2)
2671 return make_number (- chars - 1);
2672
2673 /* Same length too => they are equal. */
2674 return make_number (0);
2675 }
2676 \f
2677 static Lisp_Object
2678 subst_char_in_region_unwind (Lisp_Object arg)
2679 {
2680 return current_buffer->undo_list = arg;
2681 }
2682
2683 static Lisp_Object
2684 subst_char_in_region_unwind_1 (Lisp_Object arg)
2685 {
2686 return current_buffer->filename = arg;
2687 }
2688
2689 DEFUN ("subst-char-in-region", Fsubst_char_in_region,
2690 Ssubst_char_in_region, 4, 5, 0,
2691 doc: /* From START to END, replace FROMCHAR with TOCHAR each time it occurs.
2692 If optional arg NOUNDO is non-nil, don't record this change for undo
2693 and don't mark the buffer as really changed.
2694 Both characters must have the same length of multi-byte form. */)
2695 (Lisp_Object start, Lisp_Object end, Lisp_Object fromchar, Lisp_Object tochar, Lisp_Object noundo)
2696 {
2697 register EMACS_INT pos, pos_byte, stop, i, len, end_byte;
2698 /* Keep track of the first change in the buffer:
2699 if 0 we haven't found it yet.
2700 if < 0 we've found it and we've run the before-change-function.
2701 if > 0 we've actually performed it and the value is its position. */
2702 EMACS_INT changed = 0;
2703 unsigned char fromstr[MAX_MULTIBYTE_LENGTH], tostr[MAX_MULTIBYTE_LENGTH];
2704 unsigned char *p;
2705 int count = SPECPDL_INDEX ();
2706 #define COMBINING_NO 0
2707 #define COMBINING_BEFORE 1
2708 #define COMBINING_AFTER 2
2709 #define COMBINING_BOTH (COMBINING_BEFORE | COMBINING_AFTER)
2710 int maybe_byte_combining = COMBINING_NO;
2711 EMACS_INT last_changed = 0;
2712 int multibyte_p = !NILP (current_buffer->enable_multibyte_characters);
2713
2714 restart:
2715
2716 validate_region (&start, &end);
2717 CHECK_NUMBER (fromchar);
2718 CHECK_NUMBER (tochar);
2719
2720 if (multibyte_p)
2721 {
2722 len = CHAR_STRING (XFASTINT (fromchar), fromstr);
2723 if (CHAR_STRING (XFASTINT (tochar), tostr) != len)
2724 error ("Characters in `subst-char-in-region' have different byte-lengths");
2725 if (!ASCII_BYTE_P (*tostr))
2726 {
2727 /* If *TOSTR is in the range 0x80..0x9F and TOCHAR is not a
2728 complete multibyte character, it may be combined with the
2729 after bytes. If it is in the range 0xA0..0xFF, it may be
2730 combined with the before and after bytes. */
2731 if (!CHAR_HEAD_P (*tostr))
2732 maybe_byte_combining = COMBINING_BOTH;
2733 else if (BYTES_BY_CHAR_HEAD (*tostr) > len)
2734 maybe_byte_combining = COMBINING_AFTER;
2735 }
2736 }
2737 else
2738 {
2739 len = 1;
2740 fromstr[0] = XFASTINT (fromchar);
2741 tostr[0] = XFASTINT (tochar);
2742 }
2743
2744 pos = XINT (start);
2745 pos_byte = CHAR_TO_BYTE (pos);
2746 stop = CHAR_TO_BYTE (XINT (end));
2747 end_byte = stop;
2748
2749 /* If we don't want undo, turn off putting stuff on the list.
2750 That's faster than getting rid of things,
2751 and it prevents even the entry for a first change.
2752 Also inhibit locking the file. */
2753 if (!changed && !NILP (noundo))
2754 {
2755 record_unwind_protect (subst_char_in_region_unwind,
2756 current_buffer->undo_list);
2757 current_buffer->undo_list = Qt;
2758 /* Don't do file-locking. */
2759 record_unwind_protect (subst_char_in_region_unwind_1,
2760 current_buffer->filename);
2761 current_buffer->filename = Qnil;
2762 }
2763
2764 if (pos_byte < GPT_BYTE)
2765 stop = min (stop, GPT_BYTE);
2766 while (1)
2767 {
2768 EMACS_INT pos_byte_next = pos_byte;
2769
2770 if (pos_byte >= stop)
2771 {
2772 if (pos_byte >= end_byte) break;
2773 stop = end_byte;
2774 }
2775 p = BYTE_POS_ADDR (pos_byte);
2776 if (multibyte_p)
2777 INC_POS (pos_byte_next);
2778 else
2779 ++pos_byte_next;
2780 if (pos_byte_next - pos_byte == len
2781 && p[0] == fromstr[0]
2782 && (len == 1
2783 || (p[1] == fromstr[1]
2784 && (len == 2 || (p[2] == fromstr[2]
2785 && (len == 3 || p[3] == fromstr[3]))))))
2786 {
2787 if (changed < 0)
2788 /* We've already seen this and run the before-change-function;
2789 this time we only need to record the actual position. */
2790 changed = pos;
2791 else if (!changed)
2792 {
2793 changed = -1;
2794 modify_region (current_buffer, pos, XINT (end), 0);
2795
2796 if (! NILP (noundo))
2797 {
2798 if (MODIFF - 1 == SAVE_MODIFF)
2799 SAVE_MODIFF++;
2800 if (MODIFF - 1 == BUF_AUTOSAVE_MODIFF (current_buffer))
2801 BUF_AUTOSAVE_MODIFF (current_buffer)++;
2802 }
2803
2804 /* The before-change-function may have moved the gap
2805 or even modified the buffer so we should start over. */
2806 goto restart;
2807 }
2808
2809 /* Take care of the case where the new character
2810 combines with neighboring bytes. */
2811 if (maybe_byte_combining
2812 && (maybe_byte_combining == COMBINING_AFTER
2813 ? (pos_byte_next < Z_BYTE
2814 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next)))
2815 : ((pos_byte_next < Z_BYTE
2816 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next)))
2817 || (pos_byte > BEG_BYTE
2818 && ! ASCII_BYTE_P (FETCH_BYTE (pos_byte - 1))))))
2819 {
2820 Lisp_Object tem, string;
2821
2822 struct gcpro gcpro1;
2823
2824 tem = current_buffer->undo_list;
2825 GCPRO1 (tem);
2826
2827 /* Make a multibyte string containing this single character. */
2828 string = make_multibyte_string (tostr, 1, len);
2829 /* replace_range is less efficient, because it moves the gap,
2830 but it handles combining correctly. */
2831 replace_range (pos, pos + 1, string,
2832 0, 0, 1);
2833 pos_byte_next = CHAR_TO_BYTE (pos);
2834 if (pos_byte_next > pos_byte)
2835 /* Before combining happened. We should not increment
2836 POS. So, to cancel the later increment of POS,
2837 decrease it now. */
2838 pos--;
2839 else
2840 INC_POS (pos_byte_next);
2841
2842 if (! NILP (noundo))
2843 current_buffer->undo_list = tem;
2844
2845 UNGCPRO;
2846 }
2847 else
2848 {
2849 if (NILP (noundo))
2850 record_change (pos, 1);
2851 for (i = 0; i < len; i++) *p++ = tostr[i];
2852 }
2853 last_changed = pos + 1;
2854 }
2855 pos_byte = pos_byte_next;
2856 pos++;
2857 }
2858
2859 if (changed > 0)
2860 {
2861 signal_after_change (changed,
2862 last_changed - changed, last_changed - changed);
2863 update_compositions (changed, last_changed, CHECK_ALL);
2864 }
2865
2866 unbind_to (count, Qnil);
2867 return Qnil;
2868 }
2869
2870
2871 static Lisp_Object check_translation (EMACS_INT, EMACS_INT, EMACS_INT,
2872 Lisp_Object);
2873
2874 /* Helper function for Ftranslate_region_internal.
2875
2876 Check if a character sequence at POS (POS_BYTE) matches an element
2877 of VAL. VAL is a list (([FROM-CHAR ...] . TO) ...). If a matching
2878 element is found, return it. Otherwise return Qnil. */
2879
2880 static Lisp_Object
2881 check_translation (EMACS_INT pos, EMACS_INT pos_byte, EMACS_INT end,
2882 Lisp_Object val)
2883 {
2884 int buf_size = 16, buf_used = 0;
2885 int *buf = alloca (sizeof (int) * buf_size);
2886
2887 for (; CONSP (val); val = XCDR (val))
2888 {
2889 Lisp_Object elt;
2890 EMACS_INT len, i;
2891
2892 elt = XCAR (val);
2893 if (! CONSP (elt))
2894 continue;
2895 elt = XCAR (elt);
2896 if (! VECTORP (elt))
2897 continue;
2898 len = ASIZE (elt);
2899 if (len <= end - pos)
2900 {
2901 for (i = 0; i < len; i++)
2902 {
2903 if (buf_used <= i)
2904 {
2905 unsigned char *p = BYTE_POS_ADDR (pos_byte);
2906 int len1;
2907
2908 if (buf_used == buf_size)
2909 {
2910 int *newbuf;
2911
2912 buf_size += 16;
2913 newbuf = alloca (sizeof (int) * buf_size);
2914 memcpy (newbuf, buf, sizeof (int) * buf_used);
2915 buf = newbuf;
2916 }
2917 buf[buf_used++] = STRING_CHAR_AND_LENGTH (p, len1);
2918 pos_byte += len1;
2919 }
2920 if (XINT (AREF (elt, i)) != buf[i])
2921 break;
2922 }
2923 if (i == len)
2924 return XCAR (val);
2925 }
2926 }
2927 return Qnil;
2928 }
2929
2930
2931 DEFUN ("translate-region-internal", Ftranslate_region_internal,
2932 Stranslate_region_internal, 3, 3, 0,
2933 doc: /* Internal use only.
2934 From START to END, translate characters according to TABLE.
2935 TABLE is a string or a char-table; the Nth character in it is the
2936 mapping for the character with code N.
2937 It returns the number of characters changed. */)
2938 (Lisp_Object start, Lisp_Object end, register Lisp_Object table)
2939 {
2940 register unsigned char *tt; /* Trans table. */
2941 register int nc; /* New character. */
2942 int cnt; /* Number of changes made. */
2943 EMACS_INT size; /* Size of translate table. */
2944 EMACS_INT pos, pos_byte, end_pos;
2945 int multibyte = !NILP (current_buffer->enable_multibyte_characters);
2946 int string_multibyte;
2947 Lisp_Object val;
2948
2949 validate_region (&start, &end);
2950 if (CHAR_TABLE_P (table))
2951 {
2952 if (! EQ (XCHAR_TABLE (table)->purpose, Qtranslation_table))
2953 error ("Not a translation table");
2954 size = MAX_CHAR;
2955 tt = NULL;
2956 }
2957 else
2958 {
2959 CHECK_STRING (table);
2960
2961 if (! multibyte && (SCHARS (table) < SBYTES (table)))
2962 table = string_make_unibyte (table);
2963 string_multibyte = SCHARS (table) < SBYTES (table);
2964 size = SBYTES (table);
2965 tt = SDATA (table);
2966 }
2967
2968 pos = XINT (start);
2969 pos_byte = CHAR_TO_BYTE (pos);
2970 end_pos = XINT (end);
2971 modify_region (current_buffer, pos, end_pos, 0);
2972
2973 cnt = 0;
2974 for (; pos < end_pos; )
2975 {
2976 register unsigned char *p = BYTE_POS_ADDR (pos_byte);
2977 unsigned char *str, buf[MAX_MULTIBYTE_LENGTH];
2978 int len, str_len;
2979 int oc;
2980 Lisp_Object val;
2981
2982 if (multibyte)
2983 oc = STRING_CHAR_AND_LENGTH (p, len);
2984 else
2985 oc = *p, len = 1;
2986 if (oc < size)
2987 {
2988 if (tt)
2989 {
2990 /* Reload as signal_after_change in last iteration may GC. */
2991 tt = SDATA (table);
2992 if (string_multibyte)
2993 {
2994 str = tt + string_char_to_byte (table, oc);
2995 nc = STRING_CHAR_AND_LENGTH (str, str_len);
2996 }
2997 else
2998 {
2999 nc = tt[oc];
3000 if (! ASCII_BYTE_P (nc) && multibyte)
3001 {
3002 str_len = BYTE8_STRING (nc, buf);
3003 str = buf;
3004 }
3005 else
3006 {
3007 str_len = 1;
3008 str = tt + oc;
3009 }
3010 }
3011 }
3012 else
3013 {
3014 EMACS_INT c;
3015
3016 nc = oc;
3017 val = CHAR_TABLE_REF (table, oc);
3018 if (CHARACTERP (val)
3019 && (c = XINT (val), CHAR_VALID_P (c, 0)))
3020 {
3021 nc = c;
3022 str_len = CHAR_STRING (nc, buf);
3023 str = buf;
3024 }
3025 else if (VECTORP (val) || (CONSP (val)))
3026 {
3027 /* VAL is [TO_CHAR ...] or (([FROM-CHAR ...] . TO) ...)
3028 where TO is TO-CHAR or [TO-CHAR ...]. */
3029 nc = -1;
3030 }
3031 }
3032
3033 if (nc != oc && nc >= 0)
3034 {
3035 /* Simple one char to one char translation. */
3036 if (len != str_len)
3037 {
3038 Lisp_Object string;
3039
3040 /* This is less efficient, because it moves the gap,
3041 but it should handle multibyte characters correctly. */
3042 string = make_multibyte_string (str, 1, str_len);
3043 replace_range (pos, pos + 1, string, 1, 0, 1);
3044 len = str_len;
3045 }
3046 else
3047 {
3048 record_change (pos, 1);
3049 while (str_len-- > 0)
3050 *p++ = *str++;
3051 signal_after_change (pos, 1, 1);
3052 update_compositions (pos, pos + 1, CHECK_BORDER);
3053 }
3054 ++cnt;
3055 }
3056 else if (nc < 0)
3057 {
3058 Lisp_Object string;
3059
3060 if (CONSP (val))
3061 {
3062 val = check_translation (pos, pos_byte, end_pos, val);
3063 if (NILP (val))
3064 {
3065 pos_byte += len;
3066 pos++;
3067 continue;
3068 }
3069 /* VAL is ([FROM-CHAR ...] . TO). */
3070 len = ASIZE (XCAR (val));
3071 val = XCDR (val);
3072 }
3073 else
3074 len = 1;
3075
3076 if (VECTORP (val))
3077 {
3078 string = Fconcat (1, &val);
3079 }
3080 else
3081 {
3082 string = Fmake_string (make_number (1), val);
3083 }
3084 replace_range (pos, pos + len, string, 1, 0, 1);
3085 pos_byte += SBYTES (string);
3086 pos += SCHARS (string);
3087 cnt += SCHARS (string);
3088 end_pos += SCHARS (string) - len;
3089 continue;
3090 }
3091 }
3092 pos_byte += len;
3093 pos++;
3094 }
3095
3096 return make_number (cnt);
3097 }
3098
3099 DEFUN ("delete-region", Fdelete_region, Sdelete_region, 2, 2, "r",
3100 doc: /* Delete the text between point and mark.
3101
3102 When called from a program, expects two arguments,
3103 positions (integers or markers) specifying the stretch to be deleted. */)
3104 (Lisp_Object start, Lisp_Object end)
3105 {
3106 validate_region (&start, &end);
3107 del_range (XINT (start), XINT (end));
3108 return Qnil;
3109 }
3110
3111 DEFUN ("delete-and-extract-region", Fdelete_and_extract_region,
3112 Sdelete_and_extract_region, 2, 2, 0,
3113 doc: /* Delete the text between START and END and return it. */)
3114 (Lisp_Object start, Lisp_Object end)
3115 {
3116 validate_region (&start, &end);
3117 if (XINT (start) == XINT (end))
3118 return empty_unibyte_string;
3119 return del_range_1 (XINT (start), XINT (end), 1, 1);
3120 }
3121 \f
3122 DEFUN ("widen", Fwiden, Swiden, 0, 0, "",
3123 doc: /* Remove restrictions (narrowing) from current buffer.
3124 This allows the buffer's full text to be seen and edited. */)
3125 (void)
3126 {
3127 if (BEG != BEGV || Z != ZV)
3128 current_buffer->clip_changed = 1;
3129 BEGV = BEG;
3130 BEGV_BYTE = BEG_BYTE;
3131 SET_BUF_ZV_BOTH (current_buffer, Z, Z_BYTE);
3132 /* Changing the buffer bounds invalidates any recorded current column. */
3133 invalidate_current_column ();
3134 return Qnil;
3135 }
3136
3137 DEFUN ("narrow-to-region", Fnarrow_to_region, Snarrow_to_region, 2, 2, "r",
3138 doc: /* Restrict editing in this buffer to the current region.
3139 The rest of the text becomes temporarily invisible and untouchable
3140 but is not deleted; if you save the buffer in a file, the invisible
3141 text is included in the file. \\[widen] makes all visible again.
3142 See also `save-restriction'.
3143
3144 When calling from a program, pass two arguments; positions (integers
3145 or markers) bounding the text that should remain visible. */)
3146 (register Lisp_Object start, Lisp_Object end)
3147 {
3148 CHECK_NUMBER_COERCE_MARKER (start);
3149 CHECK_NUMBER_COERCE_MARKER (end);
3150
3151 if (XINT (start) > XINT (end))
3152 {
3153 Lisp_Object tem;
3154 tem = start; start = end; end = tem;
3155 }
3156
3157 if (!(BEG <= XINT (start) && XINT (start) <= XINT (end) && XINT (end) <= Z))
3158 args_out_of_range (start, end);
3159
3160 if (BEGV != XFASTINT (start) || ZV != XFASTINT (end))
3161 current_buffer->clip_changed = 1;
3162
3163 SET_BUF_BEGV (current_buffer, XFASTINT (start));
3164 SET_BUF_ZV (current_buffer, XFASTINT (end));
3165 if (PT < XFASTINT (start))
3166 SET_PT (XFASTINT (start));
3167 if (PT > XFASTINT (end))
3168 SET_PT (XFASTINT (end));
3169 /* Changing the buffer bounds invalidates any recorded current column. */
3170 invalidate_current_column ();
3171 return Qnil;
3172 }
3173
3174 Lisp_Object
3175 save_restriction_save (void)
3176 {
3177 if (BEGV == BEG && ZV == Z)
3178 /* The common case that the buffer isn't narrowed.
3179 We return just the buffer object, which save_restriction_restore
3180 recognizes as meaning `no restriction'. */
3181 return Fcurrent_buffer ();
3182 else
3183 /* We have to save a restriction, so return a pair of markers, one
3184 for the beginning and one for the end. */
3185 {
3186 Lisp_Object beg, end;
3187
3188 beg = buildmark (BEGV, BEGV_BYTE);
3189 end = buildmark (ZV, ZV_BYTE);
3190
3191 /* END must move forward if text is inserted at its exact location. */
3192 XMARKER(end)->insertion_type = 1;
3193
3194 return Fcons (beg, end);
3195 }
3196 }
3197
3198 Lisp_Object
3199 save_restriction_restore (Lisp_Object data)
3200 {
3201 struct buffer *cur = NULL;
3202 struct buffer *buf = (CONSP (data)
3203 ? XMARKER (XCAR (data))->buffer
3204 : XBUFFER (data));
3205
3206 if (buf && buf != current_buffer && !NILP (buf->pt_marker))
3207 { /* If `buf' uses markers to keep track of PT, BEGV, and ZV (as
3208 is the case if it is or has an indirect buffer), then make
3209 sure it is current before we update BEGV, so
3210 set_buffer_internal takes care of managing those markers. */
3211 cur = current_buffer;
3212 set_buffer_internal (buf);
3213 }
3214
3215 if (CONSP (data))
3216 /* A pair of marks bounding a saved restriction. */
3217 {
3218 struct Lisp_Marker *beg = XMARKER (XCAR (data));
3219 struct Lisp_Marker *end = XMARKER (XCDR (data));
3220 eassert (buf == end->buffer);
3221
3222 if (buf /* Verify marker still points to a buffer. */
3223 && (beg->charpos != BUF_BEGV (buf) || end->charpos != BUF_ZV (buf)))
3224 /* The restriction has changed from the saved one, so restore
3225 the saved restriction. */
3226 {
3227 EMACS_INT pt = BUF_PT (buf);
3228
3229 SET_BUF_BEGV_BOTH (buf, beg->charpos, beg->bytepos);
3230 SET_BUF_ZV_BOTH (buf, end->charpos, end->bytepos);
3231
3232 if (pt < beg->charpos || pt > end->charpos)
3233 /* The point is outside the new visible range, move it inside. */
3234 SET_BUF_PT_BOTH (buf,
3235 clip_to_bounds (beg->charpos, pt, end->charpos),
3236 clip_to_bounds (beg->bytepos, BUF_PT_BYTE (buf),
3237 end->bytepos));
3238
3239 buf->clip_changed = 1; /* Remember that the narrowing changed. */
3240 }
3241 }
3242 else
3243 /* A buffer, which means that there was no old restriction. */
3244 {
3245 if (buf /* Verify marker still points to a buffer. */
3246 && (BUF_BEGV (buf) != BUF_BEG (buf) || BUF_ZV (buf) != BUF_Z (buf)))
3247 /* The buffer has been narrowed, get rid of the narrowing. */
3248 {
3249 SET_BUF_BEGV_BOTH (buf, BUF_BEG (buf), BUF_BEG_BYTE (buf));
3250 SET_BUF_ZV_BOTH (buf, BUF_Z (buf), BUF_Z_BYTE (buf));
3251
3252 buf->clip_changed = 1; /* Remember that the narrowing changed. */
3253 }
3254 }
3255
3256 if (cur)
3257 set_buffer_internal (cur);
3258
3259 return Qnil;
3260 }
3261
3262 DEFUN ("save-restriction", Fsave_restriction, Ssave_restriction, 0, UNEVALLED, 0,
3263 doc: /* Execute BODY, saving and restoring current buffer's restrictions.
3264 The buffer's restrictions make parts of the beginning and end invisible.
3265 \(They are set up with `narrow-to-region' and eliminated with `widen'.)
3266 This special form, `save-restriction', saves the current buffer's restrictions
3267 when it is entered, and restores them when it is exited.
3268 So any `narrow-to-region' within BODY lasts only until the end of the form.
3269 The old restrictions settings are restored
3270 even in case of abnormal exit (throw or error).
3271
3272 The value returned is the value of the last form in BODY.
3273
3274 Note: if you are using both `save-excursion' and `save-restriction',
3275 use `save-excursion' outermost:
3276 (save-excursion (save-restriction ...))
3277
3278 usage: (save-restriction &rest BODY) */)
3279 (Lisp_Object body)
3280 {
3281 register Lisp_Object val;
3282 int count = SPECPDL_INDEX ();
3283
3284 record_unwind_protect (save_restriction_restore, save_restriction_save ());
3285 val = Fprogn (body);
3286 return unbind_to (count, val);
3287 }
3288 \f
3289 /* Buffer for the most recent text displayed by Fmessage_box. */
3290 static char *message_text;
3291
3292 /* Allocated length of that buffer. */
3293 static int message_length;
3294
3295 DEFUN ("message", Fmessage, Smessage, 1, MANY, 0,
3296 doc: /* Display a message at the bottom of the screen.
3297 The message also goes into the `*Messages*' buffer.
3298 \(In keyboard macros, that's all it does.)
3299 Return the message.
3300
3301 The first argument is a format control string, and the rest are data
3302 to be formatted under control of the string. See `format' for details.
3303
3304 Note: Use (message "%s" VALUE) to print the value of expressions and
3305 variables to avoid accidentally interpreting `%' as format specifiers.
3306
3307 If the first argument is nil or the empty string, the function clears
3308 any existing message; this lets the minibuffer contents show. See
3309 also `current-message'.
3310
3311 usage: (message FORMAT-STRING &rest ARGS) */)
3312 (int nargs, Lisp_Object *args)
3313 {
3314 if (NILP (args[0])
3315 || (STRINGP (args[0])
3316 && SBYTES (args[0]) == 0))
3317 {
3318 message (0);
3319 return args[0];
3320 }
3321 else
3322 {
3323 register Lisp_Object val;
3324 val = Fformat (nargs, args);
3325 message3 (val, SBYTES (val), STRING_MULTIBYTE (val));
3326 return val;
3327 }
3328 }
3329
3330 DEFUN ("message-box", Fmessage_box, Smessage_box, 1, MANY, 0,
3331 doc: /* Display a message, in a dialog box if possible.
3332 If a dialog box is not available, use the echo area.
3333 The first argument is a format control string, and the rest are data
3334 to be formatted under control of the string. See `format' for details.
3335
3336 If the first argument is nil or the empty string, clear any existing
3337 message; let the minibuffer contents show.
3338
3339 usage: (message-box FORMAT-STRING &rest ARGS) */)
3340 (int nargs, Lisp_Object *args)
3341 {
3342 if (NILP (args[0]))
3343 {
3344 message (0);
3345 return Qnil;
3346 }
3347 else
3348 {
3349 register Lisp_Object val;
3350 val = Fformat (nargs, args);
3351 #ifdef HAVE_MENUS
3352 /* The MS-DOS frames support popup menus even though they are
3353 not FRAME_WINDOW_P. */
3354 if (FRAME_WINDOW_P (XFRAME (selected_frame))
3355 || FRAME_MSDOS_P (XFRAME (selected_frame)))
3356 {
3357 Lisp_Object pane, menu, obj;
3358 struct gcpro gcpro1;
3359 pane = Fcons (Fcons (build_string ("OK"), Qt), Qnil);
3360 GCPRO1 (pane);
3361 menu = Fcons (val, pane);
3362 obj = Fx_popup_dialog (Qt, menu, Qt);
3363 UNGCPRO;
3364 return val;
3365 }
3366 #endif /* HAVE_MENUS */
3367 /* Copy the data so that it won't move when we GC. */
3368 if (! message_text)
3369 {
3370 message_text = (char *)xmalloc (80);
3371 message_length = 80;
3372 }
3373 if (SBYTES (val) > message_length)
3374 {
3375 message_length = SBYTES (val);
3376 message_text = (char *)xrealloc (message_text, message_length);
3377 }
3378 memcpy (message_text, SDATA (val), SBYTES (val));
3379 message2 (message_text, SBYTES (val),
3380 STRING_MULTIBYTE (val));
3381 return val;
3382 }
3383 }
3384
3385 DEFUN ("message-or-box", Fmessage_or_box, Smessage_or_box, 1, MANY, 0,
3386 doc: /* Display a message in a dialog box or in the echo area.
3387 If this command was invoked with the mouse, use a dialog box if
3388 `use-dialog-box' is non-nil.
3389 Otherwise, use the echo area.
3390 The first argument is a format control string, and the rest are data
3391 to be formatted under control of the string. See `format' for details.
3392
3393 If the first argument is nil or the empty string, clear any existing
3394 message; let the minibuffer contents show.
3395
3396 usage: (message-or-box FORMAT-STRING &rest ARGS) */)
3397 (int nargs, Lisp_Object *args)
3398 {
3399 #ifdef HAVE_MENUS
3400 if ((NILP (last_nonmenu_event) || CONSP (last_nonmenu_event))
3401 && use_dialog_box)
3402 return Fmessage_box (nargs, args);
3403 #endif
3404 return Fmessage (nargs, args);
3405 }
3406
3407 DEFUN ("current-message", Fcurrent_message, Scurrent_message, 0, 0, 0,
3408 doc: /* Return the string currently displayed in the echo area, or nil if none. */)
3409 (void)
3410 {
3411 return current_message ();
3412 }
3413
3414
3415 DEFUN ("propertize", Fpropertize, Spropertize, 1, MANY, 0,
3416 doc: /* Return a copy of STRING with text properties added.
3417 First argument is the string to copy.
3418 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
3419 properties to add to the result.
3420 usage: (propertize STRING &rest PROPERTIES) */)
3421 (int nargs, Lisp_Object *args)
3422 {
3423 Lisp_Object properties, string;
3424 struct gcpro gcpro1, gcpro2;
3425 int i;
3426
3427 /* Number of args must be odd. */
3428 if ((nargs & 1) == 0 || nargs < 1)
3429 error ("Wrong number of arguments");
3430
3431 properties = string = Qnil;
3432 GCPRO2 (properties, string);
3433
3434 /* First argument must be a string. */
3435 CHECK_STRING (args[0]);
3436 string = Fcopy_sequence (args[0]);
3437
3438 for (i = 1; i < nargs; i += 2)
3439 properties = Fcons (args[i], Fcons (args[i + 1], properties));
3440
3441 Fadd_text_properties (make_number (0),
3442 make_number (SCHARS (string)),
3443 properties, string);
3444 RETURN_UNGCPRO (string);
3445 }
3446
3447
3448 /* Number of bytes that STRING will occupy when put into the result.
3449 MULTIBYTE is nonzero if the result should be multibyte. */
3450
3451 #define CONVERTED_BYTE_SIZE(MULTIBYTE, STRING) \
3452 (((MULTIBYTE) && ! STRING_MULTIBYTE (STRING)) \
3453 ? count_size_as_multibyte (SDATA (STRING), SBYTES (STRING)) \
3454 : SBYTES (STRING))
3455
3456 DEFUN ("format", Fformat, Sformat, 1, MANY, 0,
3457 doc: /* Format a string out of a format-string and arguments.
3458 The first argument is a format control string.
3459 The other arguments are substituted into it to make the result, a string.
3460
3461 The format control string may contain %-sequences meaning to substitute
3462 the next available argument:
3463
3464 %s means print a string argument. Actually, prints any object, with `princ'.
3465 %d means print as number in decimal (%o octal, %x hex).
3466 %X is like %x, but uses upper case.
3467 %e means print a number in exponential notation.
3468 %f means print a number in decimal-point notation.
3469 %g means print a number in exponential notation
3470 or decimal-point notation, whichever uses fewer characters.
3471 %c means print a number as a single character.
3472 %S means print any object as an s-expression (using `prin1').
3473
3474 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.
3475 Use %% to put a single % into the output.
3476
3477 A %-sequence may contain optional flag, width, and precision
3478 specifiers, as follows:
3479
3480 %<flags><width><precision>character
3481
3482 where flags is [+ #-0]+, width is [0-9]+, and precision is .[0-9]+
3483
3484 The + flag character inserts a + before any positive number, while a
3485 space inserts a space before any positive number; these flags only
3486 affect %d, %e, %f, and %g sequences, and the + flag takes precedence.
3487 The # flag means to use an alternate display form for %o, %x, %X, %e,
3488 %f, and %g sequences. The - and 0 flags affect the width specifier,
3489 as described below.
3490
3491 The width specifier supplies a lower limit for the length of the
3492 printed representation. The padding, if any, normally goes on the
3493 left, but it goes on the right if the - flag is present. The padding
3494 character is normally a space, but it is 0 if the 0 flag is present.
3495 The - flag takes precedence over the 0 flag.
3496
3497 For %e, %f, and %g sequences, the number after the "." in the
3498 precision specifier says how many decimal places to show; if zero, the
3499 decimal point itself is omitted. For %s and %S, the precision
3500 specifier truncates the string to the given width.
3501
3502 usage: (format STRING &rest OBJECTS) */)
3503 (int nargs, register Lisp_Object *args)
3504 {
3505 register int n; /* The number of the next arg to substitute */
3506 register EMACS_INT total; /* An estimate of the final length */
3507 char *buf, *p;
3508 register unsigned char *format, *end, *format_start;
3509 int nchars;
3510 /* Nonzero if the output should be a multibyte string,
3511 which is true if any of the inputs is one. */
3512 int multibyte = 0;
3513 /* When we make a multibyte string, we must pay attention to the
3514 byte combining problem, i.e., a byte may be combined with a
3515 multibyte character of the previous string. This flag tells if we
3516 must consider such a situation or not. */
3517 int maybe_combine_byte;
3518 unsigned char *this_format;
3519 /* Precision for each spec, or -1, a flag value meaning no precision
3520 was given in that spec. Element 0, corresonding to the format
3521 string itself, will not be used. Element NARGS, corresponding to
3522 no argument, *will* be assigned to in the case that a `%' and `.'
3523 occur after the final format specifier. */
3524 int *precision = (int *) (alloca ((nargs + 1) * sizeof (int)));
3525 int longest_format;
3526 Lisp_Object val;
3527 int arg_intervals = 0;
3528 USE_SAFE_ALLOCA;
3529
3530 /* discarded[I] is 1 if byte I of the format
3531 string was not copied into the output.
3532 It is 2 if byte I was not the first byte of its character. */
3533 char *discarded = 0;
3534
3535 /* Each element records, for one argument,
3536 the start and end bytepos in the output string,
3537 and whether the argument is a string with intervals.
3538 info[0] is unused. Unused elements have -1 for start. */
3539 struct info
3540 {
3541 int start, end, intervals;
3542 } *info = 0;
3543
3544 /* It should not be necessary to GCPRO ARGS, because
3545 the caller in the interpreter should take care of that. */
3546
3547 /* Try to determine whether the result should be multibyte.
3548 This is not always right; sometimes the result needs to be multibyte
3549 because of an object that we will pass through prin1,
3550 and in that case, we won't know it here. */
3551 for (n = 0; n < nargs; n++)
3552 {
3553 if (STRINGP (args[n]) && STRING_MULTIBYTE (args[n]))
3554 multibyte = 1;
3555 /* Piggyback on this loop to initialize precision[N]. */
3556 precision[n] = -1;
3557 }
3558 precision[nargs] = -1;
3559
3560 CHECK_STRING (args[0]);
3561 /* We may have to change "%S" to "%s". */
3562 args[0] = Fcopy_sequence (args[0]);
3563
3564 /* GC should never happen here, so abort if it does. */
3565 abort_on_gc++;
3566
3567 /* If we start out planning a unibyte result,
3568 then discover it has to be multibyte, we jump back to retry.
3569 That can only happen from the first large while loop below. */
3570 retry:
3571
3572 format = SDATA (args[0]);
3573 format_start = format;
3574 end = format + SBYTES (args[0]);
3575 longest_format = 0;
3576
3577 /* Make room in result for all the non-%-codes in the control string. */
3578 total = 5 + CONVERTED_BYTE_SIZE (multibyte, args[0]) + 1;
3579
3580 /* Allocate the info and discarded tables. */
3581 {
3582 int nbytes = (nargs+1) * sizeof *info;
3583 int i;
3584 if (!info)
3585 info = (struct info *) alloca (nbytes);
3586 memset (info, 0, nbytes);
3587 for (i = 0; i <= nargs; i++)
3588 info[i].start = -1;
3589 if (!discarded)
3590 SAFE_ALLOCA (discarded, char *, SBYTES (args[0]));
3591 memset (discarded, 0, SBYTES (args[0]));
3592 }
3593
3594 /* Add to TOTAL enough space to hold the converted arguments. */
3595
3596 n = 0;
3597 while (format != end)
3598 if (*format++ == '%')
3599 {
3600 EMACS_INT thissize = 0;
3601 EMACS_INT actual_width = 0;
3602 unsigned char *this_format_start = format - 1;
3603 int field_width = 0;
3604
3605 /* General format specifications look like
3606
3607 '%' [flags] [field-width] [precision] format
3608
3609 where
3610
3611 flags ::= [-+ #0]+
3612 field-width ::= [0-9]+
3613 precision ::= '.' [0-9]*
3614
3615 If a field-width is specified, it specifies to which width
3616 the output should be padded with blanks, if the output
3617 string is shorter than field-width.
3618
3619 If precision is specified, it specifies the number of
3620 digits to print after the '.' for floats, or the max.
3621 number of chars to print from a string. */
3622
3623 while (format != end
3624 && (*format == '-' || *format == '0' || *format == '#'
3625 || * format == ' ' || *format == '+'))
3626 ++format;
3627
3628 if (*format >= '0' && *format <= '9')
3629 {
3630 for (field_width = 0; *format >= '0' && *format <= '9'; ++format)
3631 field_width = 10 * field_width + *format - '0';
3632 }
3633
3634 /* N is not incremented for another few lines below, so refer to
3635 element N+1 (which might be precision[NARGS]). */
3636 if (*format == '.')
3637 {
3638 ++format;
3639 for (precision[n+1] = 0; *format >= '0' && *format <= '9'; ++format)
3640 precision[n+1] = 10 * precision[n+1] + *format - '0';
3641 }
3642
3643 /* Extra +1 for 'l' that we may need to insert into the
3644 format. */
3645 if (format - this_format_start + 2 > longest_format)
3646 longest_format = format - this_format_start + 2;
3647
3648 if (format == end)
3649 error ("Format string ends in middle of format specifier");
3650 if (*format == '%')
3651 format++;
3652 else if (++n >= nargs)
3653 error ("Not enough arguments for format string");
3654 else if (*format == 'S')
3655 {
3656 /* For `S', prin1 the argument and then treat like a string. */
3657 register Lisp_Object tem;
3658 tem = Fprin1_to_string (args[n], Qnil);
3659 if (STRING_MULTIBYTE (tem) && ! multibyte)
3660 {
3661 multibyte = 1;
3662 goto retry;
3663 }
3664 args[n] = tem;
3665 /* If we restart the loop, we should not come here again
3666 because args[n] is now a string and calling
3667 Fprin1_to_string on it produces superflous double
3668 quotes. So, change "%S" to "%s" now. */
3669 *format = 's';
3670 goto string;
3671 }
3672 else if (SYMBOLP (args[n]))
3673 {
3674 args[n] = SYMBOL_NAME (args[n]);
3675 if (STRING_MULTIBYTE (args[n]) && ! multibyte)
3676 {
3677 multibyte = 1;
3678 goto retry;
3679 }
3680 goto string;
3681 }
3682 else if (STRINGP (args[n]))
3683 {
3684 string:
3685 if (*format != 's' && *format != 'S')
3686 error ("Format specifier doesn't match argument type");
3687 /* In the case (PRECISION[N] > 0), THISSIZE may not need
3688 to be as large as is calculated here. Easy check for
3689 the case PRECISION = 0. */
3690 thissize = precision[n] ? CONVERTED_BYTE_SIZE (multibyte, args[n]) : 0;
3691 /* The precision also constrains how much of the argument
3692 string will finally appear (Bug#5710). */
3693 actual_width = lisp_string_width (args[n], -1, NULL, NULL);
3694 if (precision[n] != -1)
3695 actual_width = min (actual_width, precision[n]);
3696 }
3697 /* Would get MPV otherwise, since Lisp_Int's `point' to low memory. */
3698 else if (INTEGERP (args[n]) && *format != 's')
3699 {
3700 /* The following loop assumes the Lisp type indicates
3701 the proper way to pass the argument.
3702 So make sure we have a flonum if the argument should
3703 be a double. */
3704 if (*format == 'e' || *format == 'f' || *format == 'g')
3705 args[n] = Ffloat (args[n]);
3706 else
3707 if (*format != 'd' && *format != 'o' && *format != 'x'
3708 && *format != 'i' && *format != 'X' && *format != 'c')
3709 error ("Invalid format operation %%%c", *format);
3710
3711 thissize = 30 + (precision[n] > 0 ? precision[n] : 0);
3712 if (*format == 'c')
3713 {
3714 if (! ASCII_CHAR_P (XINT (args[n]))
3715 /* Note: No one can remeber why we have to treat
3716 the character 0 as a multibyte character here.
3717 But, until it causes a real problem, let's
3718 don't change it. */
3719 || XINT (args[n]) == 0)
3720 {
3721 if (! multibyte)
3722 {
3723 multibyte = 1;
3724 goto retry;
3725 }
3726 args[n] = Fchar_to_string (args[n]);
3727 thissize = SBYTES (args[n]);
3728 }
3729 else if (! ASCII_BYTE_P (XINT (args[n])) && multibyte)
3730 {
3731 args[n]
3732 = Fchar_to_string (Funibyte_char_to_multibyte (args[n]));
3733 thissize = SBYTES (args[n]);
3734 }
3735 }
3736 }
3737 else if (FLOATP (args[n]) && *format != 's')
3738 {
3739 if (! (*format == 'e' || *format == 'f' || *format == 'g'))
3740 {
3741 if (*format != 'd' && *format != 'o' && *format != 'x'
3742 && *format != 'i' && *format != 'X' && *format != 'c')
3743 error ("Invalid format operation %%%c", *format);
3744 /* This fails unnecessarily if args[n] is bigger than
3745 most-positive-fixnum but smaller than MAXINT.
3746 These cases are important because we sometimes use floats
3747 to represent such integer values (typically such values
3748 come from UIDs or PIDs). */
3749 /* args[n] = Ftruncate (args[n], Qnil); */
3750 }
3751
3752 /* Note that we're using sprintf to print floats,
3753 so we have to take into account what that function
3754 prints. */
3755 /* Filter out flag value of -1. */
3756 thissize = (MAX_10_EXP + 100
3757 + (precision[n] > 0 ? precision[n] : 0));
3758 }
3759 else
3760 {
3761 /* Anything but a string, convert to a string using princ. */
3762 register Lisp_Object tem;
3763 tem = Fprin1_to_string (args[n], Qt);
3764 if (STRING_MULTIBYTE (tem) && ! multibyte)
3765 {
3766 multibyte = 1;
3767 goto retry;
3768 }
3769 args[n] = tem;
3770 goto string;
3771 }
3772
3773 thissize += max (0, field_width - actual_width);
3774 total += thissize + 4;
3775 }
3776
3777 abort_on_gc--;
3778
3779 /* Now we can no longer jump to retry.
3780 TOTAL and LONGEST_FORMAT are known for certain. */
3781
3782 this_format = (unsigned char *) alloca (longest_format + 1);
3783
3784 /* Allocate the space for the result.
3785 Note that TOTAL is an overestimate. */
3786 SAFE_ALLOCA (buf, char *, total);
3787
3788 p = buf;
3789 nchars = 0;
3790 n = 0;
3791
3792 /* Scan the format and store result in BUF. */
3793 format = SDATA (args[0]);
3794 format_start = format;
3795 end = format + SBYTES (args[0]);
3796 maybe_combine_byte = 0;
3797 while (format != end)
3798 {
3799 if (*format == '%')
3800 {
3801 int minlen;
3802 int negative = 0;
3803 unsigned char *this_format_start = format;
3804
3805 discarded[format - format_start] = 1;
3806 format++;
3807
3808 while (strchr ("-+0# ", *format))
3809 {
3810 if (*format == '-')
3811 {
3812 negative = 1;
3813 }
3814 discarded[format - format_start] = 1;
3815 ++format;
3816 }
3817
3818 minlen = atoi (format);
3819
3820 while ((*format >= '0' && *format <= '9') || *format == '.')
3821 {
3822 discarded[format - format_start] = 1;
3823 format++;
3824 }
3825
3826 if (*format++ == '%')
3827 {
3828 *p++ = '%';
3829 nchars++;
3830 continue;
3831 }
3832
3833 ++n;
3834
3835 discarded[format - format_start - 1] = 1;
3836 info[n].start = nchars;
3837
3838 if (STRINGP (args[n]))
3839 {
3840 /* handle case (precision[n] >= 0) */
3841
3842 int width, padding;
3843 EMACS_INT nbytes, start, end;
3844 EMACS_INT nchars_string;
3845
3846 /* lisp_string_width ignores a precision of 0, but GNU
3847 libc functions print 0 characters when the precision
3848 is 0. Imitate libc behavior here. Changing
3849 lisp_string_width is the right thing, and will be
3850 done, but meanwhile we work with it. */
3851
3852 if (precision[n] == 0)
3853 width = nchars_string = nbytes = 0;
3854 else if (precision[n] > 0)
3855 width = lisp_string_width (args[n], precision[n],
3856 &nchars_string, &nbytes);
3857 else
3858 { /* no precision spec given for this argument */
3859 width = lisp_string_width (args[n], -1, NULL, NULL);
3860 nbytes = SBYTES (args[n]);
3861 nchars_string = SCHARS (args[n]);
3862 }
3863
3864 /* If spec requires it, pad on right with spaces. */
3865 padding = minlen - width;
3866 if (! negative)
3867 while (padding-- > 0)
3868 {
3869 *p++ = ' ';
3870 ++nchars;
3871 }
3872
3873 info[n].start = start = nchars;
3874 nchars += nchars_string;
3875 end = nchars;
3876
3877 if (p > buf
3878 && multibyte
3879 && !ASCII_BYTE_P (*((unsigned char *) p - 1))
3880 && STRING_MULTIBYTE (args[n])
3881 && !CHAR_HEAD_P (SREF (args[n], 0)))
3882 maybe_combine_byte = 1;
3883
3884 p += copy_text (SDATA (args[n]), p,
3885 nbytes,
3886 STRING_MULTIBYTE (args[n]), multibyte);
3887
3888 info[n].end = nchars;
3889
3890 if (negative)
3891 while (padding-- > 0)
3892 {
3893 *p++ = ' ';
3894 nchars++;
3895 }
3896
3897 /* If this argument has text properties, record where
3898 in the result string it appears. */
3899 if (STRING_INTERVALS (args[n]))
3900 info[n].intervals = arg_intervals = 1;
3901 }
3902 else if (INTEGERP (args[n]) || FLOATP (args[n]))
3903 {
3904 int this_nchars;
3905
3906 memcpy (this_format, this_format_start,
3907 format - this_format_start);
3908 this_format[format - this_format_start] = 0;
3909
3910 if (format[-1] == 'e' || format[-1] == 'f' || format[-1] == 'g')
3911 sprintf (p, this_format, XFLOAT_DATA (args[n]));
3912 else
3913 {
3914 if (sizeof (EMACS_INT) > sizeof (int)
3915 && format[-1] != 'c')
3916 {
3917 /* Insert 'l' before format spec. */
3918 this_format[format - this_format_start]
3919 = this_format[format - this_format_start - 1];
3920 this_format[format - this_format_start - 1] = 'l';
3921 this_format[format - this_format_start + 1] = 0;
3922 }
3923
3924 if (INTEGERP (args[n]))
3925 {
3926 if (format[-1] == 'c')
3927 sprintf (p, this_format, (int) XINT (args[n]));
3928 else if (format[-1] == 'd')
3929 sprintf (p, this_format, XINT (args[n]));
3930 /* Don't sign-extend for octal or hex printing. */
3931 else
3932 sprintf (p, this_format, XUINT (args[n]));
3933 }
3934 else if (format[-1] == 'c')
3935 sprintf (p, this_format, (int) XFLOAT_DATA (args[n]));
3936 else if (format[-1] == 'd')
3937 /* Maybe we should use "%1.0f" instead so it also works
3938 for values larger than MAXINT. */
3939 sprintf (p, this_format, (EMACS_INT) XFLOAT_DATA (args[n]));
3940 else
3941 /* Don't sign-extend for octal or hex printing. */
3942 sprintf (p, this_format, (EMACS_UINT) XFLOAT_DATA (args[n]));
3943 }
3944
3945 if (p > buf
3946 && multibyte
3947 && !ASCII_BYTE_P (*((unsigned char *) p - 1))
3948 && !CHAR_HEAD_P (*((unsigned char *) p)))
3949 maybe_combine_byte = 1;
3950 this_nchars = strlen (p);
3951 if (multibyte)
3952 p += str_to_multibyte (p, buf + total - 1 - p, this_nchars);
3953 else
3954 p += this_nchars;
3955 nchars += this_nchars;
3956 info[n].end = nchars;
3957 }
3958
3959 }
3960 else if (STRING_MULTIBYTE (args[0]))
3961 {
3962 /* Copy a whole multibyte character. */
3963 if (p > buf
3964 && multibyte
3965 && !ASCII_BYTE_P (*((unsigned char *) p - 1))
3966 && !CHAR_HEAD_P (*format))
3967 maybe_combine_byte = 1;
3968 *p++ = *format++;
3969 while (! CHAR_HEAD_P (*format))
3970 {
3971 discarded[format - format_start] = 2;
3972 *p++ = *format++;
3973 }
3974 nchars++;
3975 }
3976 else if (multibyte)
3977 {
3978 /* Convert a single-byte character to multibyte. */
3979 int len = copy_text (format, p, 1, 0, 1);
3980
3981 p += len;
3982 format++;
3983 nchars++;
3984 }
3985 else
3986 *p++ = *format++, nchars++;
3987 }
3988
3989 if (p > buf + total)
3990 abort ();
3991
3992 if (maybe_combine_byte)
3993 nchars = multibyte_chars_in_text (buf, p - buf);
3994 val = make_specified_string (buf, nchars, p - buf, multibyte);
3995
3996 /* If we allocated BUF with malloc, free it too. */
3997 SAFE_FREE ();
3998
3999 /* If the format string has text properties, or any of the string
4000 arguments has text properties, set up text properties of the
4001 result string. */
4002
4003 if (STRING_INTERVALS (args[0]) || arg_intervals)
4004 {
4005 Lisp_Object len, new_len, props;
4006 struct gcpro gcpro1;
4007
4008 /* Add text properties from the format string. */
4009 len = make_number (SCHARS (args[0]));
4010 props = text_property_list (args[0], make_number (0), len, Qnil);
4011 GCPRO1 (props);
4012
4013 if (CONSP (props))
4014 {
4015 EMACS_INT bytepos = 0, position = 0, translated = 0;
4016 int argn = 1;
4017 Lisp_Object list;
4018
4019 /* Adjust the bounds of each text property
4020 to the proper start and end in the output string. */
4021
4022 /* Put the positions in PROPS in increasing order, so that
4023 we can do (effectively) one scan through the position
4024 space of the format string. */
4025 props = Fnreverse (props);
4026
4027 /* BYTEPOS is the byte position in the format string,
4028 POSITION is the untranslated char position in it,
4029 TRANSLATED is the translated char position in BUF,
4030 and ARGN is the number of the next arg we will come to. */
4031 for (list = props; CONSP (list); list = XCDR (list))
4032 {
4033 Lisp_Object item;
4034 EMACS_INT pos;
4035
4036 item = XCAR (list);
4037
4038 /* First adjust the property start position. */
4039 pos = XINT (XCAR (item));
4040
4041 /* Advance BYTEPOS, POSITION, TRANSLATED and ARGN
4042 up to this position. */
4043 for (; position < pos; bytepos++)
4044 {
4045 if (! discarded[bytepos])
4046 position++, translated++;
4047 else if (discarded[bytepos] == 1)
4048 {
4049 position++;
4050 if (translated == info[argn].start)
4051 {
4052 translated += info[argn].end - info[argn].start;
4053 argn++;
4054 }
4055 }
4056 }
4057
4058 XSETCAR (item, make_number (translated));
4059
4060 /* Likewise adjust the property end position. */
4061 pos = XINT (XCAR (XCDR (item)));
4062
4063 for (; position < pos; bytepos++)
4064 {
4065 if (! discarded[bytepos])
4066 position++, translated++;
4067 else if (discarded[bytepos] == 1)
4068 {
4069 position++;
4070 if (translated == info[argn].start)
4071 {
4072 translated += info[argn].end - info[argn].start;
4073 argn++;
4074 }
4075 }
4076 }
4077
4078 XSETCAR (XCDR (item), make_number (translated));
4079 }
4080
4081 add_text_properties_from_list (val, props, make_number (0));
4082 }
4083
4084 /* Add text properties from arguments. */
4085 if (arg_intervals)
4086 for (n = 1; n < nargs; ++n)
4087 if (info[n].intervals)
4088 {
4089 len = make_number (SCHARS (args[n]));
4090 new_len = make_number (info[n].end - info[n].start);
4091 props = text_property_list (args[n], make_number (0), len, Qnil);
4092 props = extend_property_ranges (props, new_len);
4093 /* If successive arguments have properties, be sure that
4094 the value of `composition' property be the copy. */
4095 if (n > 1 && info[n - 1].end)
4096 make_composition_value_copy (props);
4097 add_text_properties_from_list (val, props,
4098 make_number (info[n].start));
4099 }
4100
4101 UNGCPRO;
4102 }
4103
4104 return val;
4105 }
4106
4107 Lisp_Object
4108 format2 (const char *string1, Lisp_Object arg0, Lisp_Object arg1)
4109 {
4110 Lisp_Object args[3];
4111 args[0] = build_string (string1);
4112 args[1] = arg0;
4113 args[2] = arg1;
4114 return Fformat (3, args);
4115 }
4116 \f
4117 DEFUN ("char-equal", Fchar_equal, Schar_equal, 2, 2, 0,
4118 doc: /* Return t if two characters match, optionally ignoring case.
4119 Both arguments must be characters (i.e. integers).
4120 Case is ignored if `case-fold-search' is non-nil in the current buffer. */)
4121 (register Lisp_Object c1, Lisp_Object c2)
4122 {
4123 int i1, i2;
4124 /* Check they're chars, not just integers, otherwise we could get array
4125 bounds violations in DOWNCASE. */
4126 CHECK_CHARACTER (c1);
4127 CHECK_CHARACTER (c2);
4128
4129 if (XINT (c1) == XINT (c2))
4130 return Qt;
4131 if (NILP (current_buffer->case_fold_search))
4132 return Qnil;
4133
4134 /* Do these in separate statements,
4135 then compare the variables.
4136 because of the way DOWNCASE uses temp variables. */
4137 i1 = XFASTINT (c1);
4138 if (NILP (current_buffer->enable_multibyte_characters)
4139 && ! ASCII_CHAR_P (i1))
4140 {
4141 MAKE_CHAR_MULTIBYTE (i1);
4142 }
4143 i2 = XFASTINT (c2);
4144 if (NILP (current_buffer->enable_multibyte_characters)
4145 && ! ASCII_CHAR_P (i2))
4146 {
4147 MAKE_CHAR_MULTIBYTE (i2);
4148 }
4149 i1 = DOWNCASE (i1);
4150 i2 = DOWNCASE (i2);
4151 return (i1 == i2 ? Qt : Qnil);
4152 }
4153 \f
4154 /* Transpose the markers in two regions of the current buffer, and
4155 adjust the ones between them if necessary (i.e.: if the regions
4156 differ in size).
4157
4158 START1, END1 are the character positions of the first region.
4159 START1_BYTE, END1_BYTE are the byte positions.
4160 START2, END2 are the character positions of the second region.
4161 START2_BYTE, END2_BYTE are the byte positions.
4162
4163 Traverses the entire marker list of the buffer to do so, adding an
4164 appropriate amount to some, subtracting from some, and leaving the
4165 rest untouched. Most of this is copied from adjust_markers in insdel.c.
4166
4167 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
4168
4169 static void
4170 transpose_markers (EMACS_INT start1, EMACS_INT end1,
4171 EMACS_INT start2, EMACS_INT end2,
4172 EMACS_INT start1_byte, EMACS_INT end1_byte,
4173 EMACS_INT start2_byte, EMACS_INT end2_byte)
4174 {
4175 register EMACS_INT amt1, amt1_byte, amt2, amt2_byte, diff, diff_byte, mpos;
4176 register struct Lisp_Marker *marker;
4177
4178 /* Update point as if it were a marker. */
4179 if (PT < start1)
4180 ;
4181 else if (PT < end1)
4182 TEMP_SET_PT_BOTH (PT + (end2 - end1),
4183 PT_BYTE + (end2_byte - end1_byte));
4184 else if (PT < start2)
4185 TEMP_SET_PT_BOTH (PT + (end2 - start2) - (end1 - start1),
4186 (PT_BYTE + (end2_byte - start2_byte)
4187 - (end1_byte - start1_byte)));
4188 else if (PT < end2)
4189 TEMP_SET_PT_BOTH (PT - (start2 - start1),
4190 PT_BYTE - (start2_byte - start1_byte));
4191
4192 /* We used to adjust the endpoints here to account for the gap, but that
4193 isn't good enough. Even if we assume the caller has tried to move the
4194 gap out of our way, it might still be at start1 exactly, for example;
4195 and that places it `inside' the interval, for our purposes. The amount
4196 of adjustment is nontrivial if there's a `denormalized' marker whose
4197 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
4198 the dirty work to Fmarker_position, below. */
4199
4200 /* The difference between the region's lengths */
4201 diff = (end2 - start2) - (end1 - start1);
4202 diff_byte = (end2_byte - start2_byte) - (end1_byte - start1_byte);
4203
4204 /* For shifting each marker in a region by the length of the other
4205 region plus the distance between the regions. */
4206 amt1 = (end2 - start2) + (start2 - end1);
4207 amt2 = (end1 - start1) + (start2 - end1);
4208 amt1_byte = (end2_byte - start2_byte) + (start2_byte - end1_byte);
4209 amt2_byte = (end1_byte - start1_byte) + (start2_byte - end1_byte);
4210
4211 for (marker = BUF_MARKERS (current_buffer); marker; marker = marker->next)
4212 {
4213 mpos = marker->bytepos;
4214 if (mpos >= start1_byte && mpos < end2_byte)
4215 {
4216 if (mpos < end1_byte)
4217 mpos += amt1_byte;
4218 else if (mpos < start2_byte)
4219 mpos += diff_byte;
4220 else
4221 mpos -= amt2_byte;
4222 marker->bytepos = mpos;
4223 }
4224 mpos = marker->charpos;
4225 if (mpos >= start1 && mpos < end2)
4226 {
4227 if (mpos < end1)
4228 mpos += amt1;
4229 else if (mpos < start2)
4230 mpos += diff;
4231 else
4232 mpos -= amt2;
4233 }
4234 marker->charpos = mpos;
4235 }
4236 }
4237
4238 DEFUN ("transpose-regions", Ftranspose_regions, Stranspose_regions, 4, 5, 0,
4239 doc: /* Transpose region STARTR1 to ENDR1 with STARTR2 to ENDR2.
4240 The regions should not be overlapping, because the size of the buffer is
4241 never changed in a transposition.
4242
4243 Optional fifth arg LEAVE-MARKERS, if non-nil, means don't update
4244 any markers that happen to be located in the regions.
4245
4246 Transposing beyond buffer boundaries is an error. */)
4247 (Lisp_Object startr1, Lisp_Object endr1, Lisp_Object startr2, Lisp_Object endr2, Lisp_Object leave_markers)
4248 {
4249 register EMACS_INT start1, end1, start2, end2;
4250 EMACS_INT start1_byte, start2_byte, len1_byte, len2_byte;
4251 EMACS_INT gap, len1, len_mid, len2;
4252 unsigned char *start1_addr, *start2_addr, *temp;
4253
4254 INTERVAL cur_intv, tmp_interval1, tmp_interval_mid, tmp_interval2, tmp_interval3;
4255 Lisp_Object buf;
4256
4257 XSETBUFFER (buf, current_buffer);
4258 cur_intv = BUF_INTERVALS (current_buffer);
4259
4260 validate_region (&startr1, &endr1);
4261 validate_region (&startr2, &endr2);
4262
4263 start1 = XFASTINT (startr1);
4264 end1 = XFASTINT (endr1);
4265 start2 = XFASTINT (startr2);
4266 end2 = XFASTINT (endr2);
4267 gap = GPT;
4268
4269 /* Swap the regions if they're reversed. */
4270 if (start2 < end1)
4271 {
4272 register EMACS_INT glumph = start1;
4273 start1 = start2;
4274 start2 = glumph;
4275 glumph = end1;
4276 end1 = end2;
4277 end2 = glumph;
4278 }
4279
4280 len1 = end1 - start1;
4281 len2 = end2 - start2;
4282
4283 if (start2 < end1)
4284 error ("Transposed regions overlap");
4285 else if (start1 == end1 || start2 == end2)
4286 error ("Transposed region has length 0");
4287
4288 /* The possibilities are:
4289 1. Adjacent (contiguous) regions, or separate but equal regions
4290 (no, really equal, in this case!), or
4291 2. Separate regions of unequal size.
4292
4293 The worst case is usually No. 2. It means that (aside from
4294 potential need for getting the gap out of the way), there also
4295 needs to be a shifting of the text between the two regions. So
4296 if they are spread far apart, we are that much slower... sigh. */
4297
4298 /* It must be pointed out that the really studly thing to do would
4299 be not to move the gap at all, but to leave it in place and work
4300 around it if necessary. This would be extremely efficient,
4301 especially considering that people are likely to do
4302 transpositions near where they are working interactively, which
4303 is exactly where the gap would be found. However, such code
4304 would be much harder to write and to read. So, if you are
4305 reading this comment and are feeling squirrely, by all means have
4306 a go! I just didn't feel like doing it, so I will simply move
4307 the gap the minimum distance to get it out of the way, and then
4308 deal with an unbroken array. */
4309
4310 /* Make sure the gap won't interfere, by moving it out of the text
4311 we will operate on. */
4312 if (start1 < gap && gap < end2)
4313 {
4314 if (gap - start1 < end2 - gap)
4315 move_gap (start1);
4316 else
4317 move_gap (end2);
4318 }
4319
4320 start1_byte = CHAR_TO_BYTE (start1);
4321 start2_byte = CHAR_TO_BYTE (start2);
4322 len1_byte = CHAR_TO_BYTE (end1) - start1_byte;
4323 len2_byte = CHAR_TO_BYTE (end2) - start2_byte;
4324
4325 #ifdef BYTE_COMBINING_DEBUG
4326 if (end1 == start2)
4327 {
4328 if (count_combining_before (BYTE_POS_ADDR (start2_byte),
4329 len2_byte, start1, start1_byte)
4330 || count_combining_before (BYTE_POS_ADDR (start1_byte),
4331 len1_byte, end2, start2_byte + len2_byte)
4332 || count_combining_after (BYTE_POS_ADDR (start1_byte),
4333 len1_byte, end2, start2_byte + len2_byte))
4334 abort ();
4335 }
4336 else
4337 {
4338 if (count_combining_before (BYTE_POS_ADDR (start2_byte),
4339 len2_byte, start1, start1_byte)
4340 || count_combining_before (BYTE_POS_ADDR (start1_byte),
4341 len1_byte, start2, start2_byte)
4342 || count_combining_after (BYTE_POS_ADDR (start2_byte),
4343 len2_byte, end1, start1_byte + len1_byte)
4344 || count_combining_after (BYTE_POS_ADDR (start1_byte),
4345 len1_byte, end2, start2_byte + len2_byte))
4346 abort ();
4347 }
4348 #endif
4349
4350 /* Hmmm... how about checking to see if the gap is large
4351 enough to use as the temporary storage? That would avoid an
4352 allocation... interesting. Later, don't fool with it now. */
4353
4354 /* Working without memmove, for portability (sigh), so must be
4355 careful of overlapping subsections of the array... */
4356
4357 if (end1 == start2) /* adjacent regions */
4358 {
4359 modify_region (current_buffer, start1, end2, 0);
4360 record_change (start1, len1 + len2);
4361
4362 tmp_interval1 = copy_intervals (cur_intv, start1, len1);
4363 tmp_interval2 = copy_intervals (cur_intv, start2, len2);
4364 /* Don't use Fset_text_properties: that can cause GC, which can
4365 clobber objects stored in the tmp_intervals. */
4366 tmp_interval3 = validate_interval_range (buf, &startr1, &endr2, 0);
4367 if (!NULL_INTERVAL_P (tmp_interval3))
4368 set_text_properties_1 (startr1, endr2, Qnil, buf, tmp_interval3);
4369
4370 /* First region smaller than second. */
4371 if (len1_byte < len2_byte)
4372 {
4373 USE_SAFE_ALLOCA;
4374
4375 SAFE_ALLOCA (temp, unsigned char *, len2_byte);
4376
4377 /* Don't precompute these addresses. We have to compute them
4378 at the last minute, because the relocating allocator might
4379 have moved the buffer around during the xmalloc. */
4380 start1_addr = BYTE_POS_ADDR (start1_byte);
4381 start2_addr = BYTE_POS_ADDR (start2_byte);
4382
4383 memcpy (temp, start2_addr, len2_byte);
4384 memcpy (start1_addr + len2_byte, start1_addr, len1_byte);
4385 memcpy (start1_addr, temp, len2_byte);
4386 SAFE_FREE ();
4387 }
4388 else
4389 /* First region not smaller than second. */
4390 {
4391 USE_SAFE_ALLOCA;
4392
4393 SAFE_ALLOCA (temp, unsigned char *, len1_byte);
4394 start1_addr = BYTE_POS_ADDR (start1_byte);
4395 start2_addr = BYTE_POS_ADDR (start2_byte);
4396 memcpy (temp, start1_addr, len1_byte);
4397 memcpy (start1_addr, start2_addr, len2_byte);
4398 memcpy (start1_addr + len2_byte, temp, len1_byte);
4399 SAFE_FREE ();
4400 }
4401 graft_intervals_into_buffer (tmp_interval1, start1 + len2,
4402 len1, current_buffer, 0);
4403 graft_intervals_into_buffer (tmp_interval2, start1,
4404 len2, current_buffer, 0);
4405 update_compositions (start1, start1 + len2, CHECK_BORDER);
4406 update_compositions (start1 + len2, end2, CHECK_TAIL);
4407 }
4408 /* Non-adjacent regions, because end1 != start2, bleagh... */
4409 else
4410 {
4411 len_mid = start2_byte - (start1_byte + len1_byte);
4412
4413 if (len1_byte == len2_byte)
4414 /* Regions are same size, though, how nice. */
4415 {
4416 USE_SAFE_ALLOCA;
4417
4418 modify_region (current_buffer, start1, end1, 0);
4419 modify_region (current_buffer, start2, end2, 0);
4420 record_change (start1, len1);
4421 record_change (start2, len2);
4422 tmp_interval1 = copy_intervals (cur_intv, start1, len1);
4423 tmp_interval2 = copy_intervals (cur_intv, start2, len2);
4424
4425 tmp_interval3 = validate_interval_range (buf, &startr1, &endr1, 0);
4426 if (!NULL_INTERVAL_P (tmp_interval3))
4427 set_text_properties_1 (startr1, endr1, Qnil, buf, tmp_interval3);
4428
4429 tmp_interval3 = validate_interval_range (buf, &startr2, &endr2, 0);
4430 if (!NULL_INTERVAL_P (tmp_interval3))
4431 set_text_properties_1 (startr2, endr2, Qnil, buf, tmp_interval3);
4432
4433 SAFE_ALLOCA (temp, unsigned char *, len1_byte);
4434 start1_addr = BYTE_POS_ADDR (start1_byte);
4435 start2_addr = BYTE_POS_ADDR (start2_byte);
4436 memcpy (temp, start1_addr, len1_byte);
4437 memcpy (start1_addr, start2_addr, len2_byte);
4438 memcpy (start2_addr, temp, len1_byte);
4439 SAFE_FREE ();
4440
4441 graft_intervals_into_buffer (tmp_interval1, start2,
4442 len1, current_buffer, 0);
4443 graft_intervals_into_buffer (tmp_interval2, start1,
4444 len2, current_buffer, 0);
4445 }
4446
4447 else if (len1_byte < len2_byte) /* Second region larger than first */
4448 /* Non-adjacent & unequal size, area between must also be shifted. */
4449 {
4450 USE_SAFE_ALLOCA;
4451
4452 modify_region (current_buffer, start1, end2, 0);
4453 record_change (start1, (end2 - start1));
4454 tmp_interval1 = copy_intervals (cur_intv, start1, len1);
4455 tmp_interval_mid = copy_intervals (cur_intv, end1, len_mid);
4456 tmp_interval2 = copy_intervals (cur_intv, start2, len2);
4457
4458 tmp_interval3 = validate_interval_range (buf, &startr1, &endr2, 0);
4459 if (!NULL_INTERVAL_P (tmp_interval3))
4460 set_text_properties_1 (startr1, endr2, Qnil, buf, tmp_interval3);
4461
4462 /* holds region 2 */
4463 SAFE_ALLOCA (temp, unsigned char *, len2_byte);
4464 start1_addr = BYTE_POS_ADDR (start1_byte);
4465 start2_addr = BYTE_POS_ADDR (start2_byte);
4466 memcpy (temp, start2_addr, len2_byte);
4467 memcpy (start1_addr + len_mid + len2_byte, start1_addr, len1_byte);
4468 memmove (start1_addr + len2_byte, start1_addr + len1_byte, len_mid);
4469 memcpy (start1_addr, temp, len2_byte);
4470 SAFE_FREE ();
4471
4472 graft_intervals_into_buffer (tmp_interval1, end2 - len1,
4473 len1, current_buffer, 0);
4474 graft_intervals_into_buffer (tmp_interval_mid, start1 + len2,
4475 len_mid, current_buffer, 0);
4476 graft_intervals_into_buffer (tmp_interval2, start1,
4477 len2, current_buffer, 0);
4478 }
4479 else
4480 /* Second region smaller than first. */
4481 {
4482 USE_SAFE_ALLOCA;
4483
4484 record_change (start1, (end2 - start1));
4485 modify_region (current_buffer, start1, end2, 0);
4486
4487 tmp_interval1 = copy_intervals (cur_intv, start1, len1);
4488 tmp_interval_mid = copy_intervals (cur_intv, end1, len_mid);
4489 tmp_interval2 = copy_intervals (cur_intv, start2, len2);
4490
4491 tmp_interval3 = validate_interval_range (buf, &startr1, &endr2, 0);
4492 if (!NULL_INTERVAL_P (tmp_interval3))
4493 set_text_properties_1 (startr1, endr2, Qnil, buf, tmp_interval3);
4494
4495 /* holds region 1 */
4496 SAFE_ALLOCA (temp, unsigned char *, len1_byte);
4497 start1_addr = BYTE_POS_ADDR (start1_byte);
4498 start2_addr = BYTE_POS_ADDR (start2_byte);
4499 memcpy (temp, start1_addr, len1_byte);
4500 memcpy (start1_addr, start2_addr, len2_byte);
4501 memcpy (start1_addr + len2_byte, start1_addr + len1_byte, len_mid);
4502 memcpy (start1_addr + len2_byte + len_mid, temp, len1_byte);
4503 SAFE_FREE ();
4504
4505 graft_intervals_into_buffer (tmp_interval1, end2 - len1,
4506 len1, current_buffer, 0);
4507 graft_intervals_into_buffer (tmp_interval_mid, start1 + len2,
4508 len_mid, current_buffer, 0);
4509 graft_intervals_into_buffer (tmp_interval2, start1,
4510 len2, current_buffer, 0);
4511 }
4512
4513 update_compositions (start1, start1 + len2, CHECK_BORDER);
4514 update_compositions (end2 - len1, end2, CHECK_BORDER);
4515 }
4516
4517 /* When doing multiple transpositions, it might be nice
4518 to optimize this. Perhaps the markers in any one buffer
4519 should be organized in some sorted data tree. */
4520 if (NILP (leave_markers))
4521 {
4522 transpose_markers (start1, end1, start2, end2,
4523 start1_byte, start1_byte + len1_byte,
4524 start2_byte, start2_byte + len2_byte);
4525 fix_start_end_in_overlays (start1, end2);
4526 }
4527
4528 signal_after_change (start1, end2 - start1, end2 - start1);
4529 return Qnil;
4530 }
4531
4532 \f
4533 void
4534 syms_of_editfns (void)
4535 {
4536 environbuf = 0;
4537 initial_tz = 0;
4538
4539 Qbuffer_access_fontify_functions
4540 = intern_c_string ("buffer-access-fontify-functions");
4541 staticpro (&Qbuffer_access_fontify_functions);
4542
4543 DEFVAR_LISP ("inhibit-field-text-motion", Vinhibit_field_text_motion,
4544 doc: /* Non-nil means text motion commands don't notice fields. */);
4545 Vinhibit_field_text_motion = Qnil;
4546
4547 DEFVAR_LISP ("buffer-access-fontify-functions",
4548 Vbuffer_access_fontify_functions,
4549 doc: /* List of functions called by `buffer-substring' to fontify if necessary.
4550 Each function is called with two arguments which specify the range
4551 of the buffer being accessed. */);
4552 Vbuffer_access_fontify_functions = Qnil;
4553
4554 {
4555 Lisp_Object obuf;
4556 obuf = Fcurrent_buffer ();
4557 /* Do this here, because init_buffer_once is too early--it won't work. */
4558 Fset_buffer (Vprin1_to_string_buffer);
4559 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
4560 Fset (Fmake_local_variable (intern_c_string ("buffer-access-fontify-functions")),
4561 Qnil);
4562 Fset_buffer (obuf);
4563 }
4564
4565 DEFVAR_LISP ("buffer-access-fontified-property",
4566 Vbuffer_access_fontified_property,
4567 doc: /* Property which (if non-nil) indicates text has been fontified.
4568 `buffer-substring' need not call the `buffer-access-fontify-functions'
4569 functions if all the text being accessed has this property. */);
4570 Vbuffer_access_fontified_property = Qnil;
4571
4572 DEFVAR_LISP ("system-name", Vsystem_name,
4573 doc: /* The host name of the machine Emacs is running on. */);
4574
4575 DEFVAR_LISP ("user-full-name", Vuser_full_name,
4576 doc: /* The full name of the user logged in. */);
4577
4578 DEFVAR_LISP ("user-login-name", Vuser_login_name,
4579 doc: /* The user's name, taken from environment variables if possible. */);
4580
4581 DEFVAR_LISP ("user-real-login-name", Vuser_real_login_name,
4582 doc: /* The user's name, based upon the real uid only. */);
4583
4584 DEFVAR_LISP ("operating-system-release", Voperating_system_release,
4585 doc: /* The release of the operating system Emacs is running on. */);
4586
4587 defsubr (&Spropertize);
4588 defsubr (&Schar_equal);
4589 defsubr (&Sgoto_char);
4590 defsubr (&Sstring_to_char);
4591 defsubr (&Schar_to_string);
4592 defsubr (&Sbyte_to_string);
4593 defsubr (&Sbuffer_substring);
4594 defsubr (&Sbuffer_substring_no_properties);
4595 defsubr (&Sbuffer_string);
4596
4597 defsubr (&Spoint_marker);
4598 defsubr (&Smark_marker);
4599 defsubr (&Spoint);
4600 defsubr (&Sregion_beginning);
4601 defsubr (&Sregion_end);
4602
4603 staticpro (&Qfield);
4604 Qfield = intern_c_string ("field");
4605 staticpro (&Qboundary);
4606 Qboundary = intern_c_string ("boundary");
4607 defsubr (&Sfield_beginning);
4608 defsubr (&Sfield_end);
4609 defsubr (&Sfield_string);
4610 defsubr (&Sfield_string_no_properties);
4611 defsubr (&Sdelete_field);
4612 defsubr (&Sconstrain_to_field);
4613
4614 defsubr (&Sline_beginning_position);
4615 defsubr (&Sline_end_position);
4616
4617 /* defsubr (&Smark); */
4618 /* defsubr (&Sset_mark); */
4619 defsubr (&Ssave_excursion);
4620 defsubr (&Ssave_current_buffer);
4621
4622 defsubr (&Sbufsize);
4623 defsubr (&Spoint_max);
4624 defsubr (&Spoint_min);
4625 defsubr (&Spoint_min_marker);
4626 defsubr (&Spoint_max_marker);
4627 defsubr (&Sgap_position);
4628 defsubr (&Sgap_size);
4629 defsubr (&Sposition_bytes);
4630 defsubr (&Sbyte_to_position);
4631
4632 defsubr (&Sbobp);
4633 defsubr (&Seobp);
4634 defsubr (&Sbolp);
4635 defsubr (&Seolp);
4636 defsubr (&Sfollowing_char);
4637 defsubr (&Sprevious_char);
4638 defsubr (&Schar_after);
4639 defsubr (&Schar_before);
4640 defsubr (&Sinsert);
4641 defsubr (&Sinsert_before_markers);
4642 defsubr (&Sinsert_and_inherit);
4643 defsubr (&Sinsert_and_inherit_before_markers);
4644 defsubr (&Sinsert_char);
4645 defsubr (&Sinsert_byte);
4646
4647 defsubr (&Suser_login_name);
4648 defsubr (&Suser_real_login_name);
4649 defsubr (&Suser_uid);
4650 defsubr (&Suser_real_uid);
4651 defsubr (&Suser_full_name);
4652 defsubr (&Semacs_pid);
4653 defsubr (&Scurrent_time);
4654 defsubr (&Sget_internal_run_time);
4655 defsubr (&Sformat_time_string);
4656 defsubr (&Sfloat_time);
4657 defsubr (&Sdecode_time);
4658 defsubr (&Sencode_time);
4659 defsubr (&Scurrent_time_string);
4660 defsubr (&Scurrent_time_zone);
4661 defsubr (&Sset_time_zone_rule);
4662 defsubr (&Ssystem_name);
4663 defsubr (&Smessage);
4664 defsubr (&Smessage_box);
4665 defsubr (&Smessage_or_box);
4666 defsubr (&Scurrent_message);
4667 defsubr (&Sformat);
4668
4669 defsubr (&Sinsert_buffer_substring);
4670 defsubr (&Scompare_buffer_substrings);
4671 defsubr (&Ssubst_char_in_region);
4672 defsubr (&Stranslate_region_internal);
4673 defsubr (&Sdelete_region);
4674 defsubr (&Sdelete_and_extract_region);
4675 defsubr (&Swiden);
4676 defsubr (&Snarrow_to_region);
4677 defsubr (&Ssave_restriction);
4678 defsubr (&Stranspose_regions);
4679 }