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