1 /* Lisp functions pertaining to editing.
2 Copyright (C) 1985,86,87,89,93,94 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 1, or (at your option)
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs; see the file COPYING. If not, write to
18 the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
21 #include <sys/types.h>
32 #include "intervals.h"
38 #define min(a, b) ((a) < (b) ? (a) : (b))
39 #define max(a, b) ((a) > (b) ? (a) : (b))
41 /* Some static data, and a function to initialize it for each run */
43 Lisp_Object Vsystem_name
;
44 Lisp_Object Vuser_real_name
; /* login name of current user ID */
45 Lisp_Object Vuser_full_name
; /* full name of current user */
46 Lisp_Object Vuser_name
; /* user name from LOGNAME or USER */
52 register unsigned char *p
, *q
, *r
;
53 struct passwd
*pw
; /* password entry for the current user */
54 extern char *index ();
57 /* Set up system_name even when dumping. */
61 /* Don't bother with this on initial start when just dumping out */
64 #endif /* not CANNOT_DUMP */
66 pw
= (struct passwd
*) getpwuid (getuid ());
67 Vuser_real_name
= build_string (pw
? pw
->pw_name
: "unknown");
69 /* Get the effective user name, by consulting environment variables,
70 or the effective uid if those are unset. */
71 user_name
= (char *) getenv ("LOGNAME");
73 user_name
= (char *) getenv ("USER");
76 pw
= (struct passwd
*) getpwuid (geteuid ());
77 user_name
= (char *) (pw
? pw
->pw_name
: "unknown");
79 Vuser_name
= build_string (user_name
);
81 /* If the user name claimed in the environment vars differs from
82 the real uid, use the claimed name to find the full name. */
83 tem
= Fstring_equal (Vuser_name
, Vuser_real_name
);
85 pw
= (struct passwd
*) getpwnam (XSTRING (Vuser_name
)->data
);
87 p
= (unsigned char *) (pw
? USER_FULL_NAME
: "unknown");
88 q
= (unsigned char *) index (p
, ',');
89 Vuser_full_name
= make_string (p
, q
? q
- p
: strlen (p
));
91 #ifdef AMPERSAND_FULL_NAME
92 p
= XSTRING (Vuser_full_name
)->data
;
93 q
= (char *) index (p
, '&');
94 /* Substitute the login name for the &, upcasing the first character. */
97 r
= (char *) alloca (strlen (p
) + XSTRING (Vuser_name
)->size
+ 1);
100 strcat (r
, XSTRING (Vuser_name
)->data
);
101 r
[q
- p
] = UPCASE (r
[q
- p
]);
103 Vuser_full_name
= build_string (r
);
105 #endif /* AMPERSAND_FULL_NAME */
108 DEFUN ("char-to-string", Fchar_to_string
, Schar_to_string
, 1, 1, 0,
109 "Convert arg CHAR to a one-character string containing that character.")
117 return make_string (&c
, 1);
120 DEFUN ("string-to-char", Fstring_to_char
, Sstring_to_char
, 1, 1, 0,
121 "Convert arg STRING to a character, the first character of that string.")
123 register Lisp_Object str
;
125 register Lisp_Object val
;
126 register struct Lisp_String
*p
;
127 CHECK_STRING (str
, 0);
131 XFASTINT (val
) = ((unsigned char *) p
->data
)[0];
141 register Lisp_Object mark
;
142 mark
= Fmake_marker ();
143 Fset_marker (mark
, make_number (val
), Qnil
);
147 DEFUN ("point", Fpoint
, Spoint
, 0, 0, 0,
148 "Return value of point, as an integer.\n\
149 Beginning of buffer is position (point-min)")
153 XFASTINT (temp
) = point
;
157 DEFUN ("point-marker", Fpoint_marker
, Spoint_marker
, 0, 0, 0,
158 "Return value of point, as a marker object.")
161 return buildmark (point
);
165 clip_to_bounds (lower
, num
, upper
)
166 int lower
, num
, upper
;
170 else if (num
> upper
)
176 DEFUN ("goto-char", Fgoto_char
, Sgoto_char
, 1, 1, "NGoto char: ",
177 "Set point to POSITION, a number or marker.\n\
178 Beginning of buffer is position (point-min), end is (point-max).")
180 register Lisp_Object n
;
182 CHECK_NUMBER_COERCE_MARKER (n
, 0);
184 SET_PT (clip_to_bounds (BEGV
, XINT (n
), ZV
));
189 region_limit (beginningp
)
192 extern Lisp_Object Vmark_even_if_inactive
; /* Defined in callint.c. */
193 register Lisp_Object m
;
194 if (!NILP (Vtransient_mark_mode
) && NILP (Vmark_even_if_inactive
)
195 && NILP (current_buffer
->mark_active
))
196 Fsignal (Qmark_inactive
, Qnil
);
197 m
= Fmarker_position (current_buffer
->mark
);
198 if (NILP (m
)) error ("There is no region now");
199 if ((point
< XFASTINT (m
)) == beginningp
)
200 return (make_number (point
));
205 DEFUN ("region-beginning", Fregion_beginning
, Sregion_beginning
, 0, 0, 0,
206 "Return position of beginning of region, as an integer.")
209 return (region_limit (1));
212 DEFUN ("region-end", Fregion_end
, Sregion_end
, 0, 0, 0,
213 "Return position of end of region, as an integer.")
216 return (region_limit (0));
219 #if 0 /* now in lisp code */
220 DEFUN ("mark", Fmark
, Smark
, 0, 0, 0,
221 "Return this buffer's mark value as integer, or nil if no mark.\n\
222 If you are using this in an editing command, you are most likely making\n\
223 a mistake; see the documentation of `set-mark'.")
226 return Fmarker_position (current_buffer
->mark
);
228 #endif /* commented out code */
230 DEFUN ("mark-marker", Fmark_marker
, Smark_marker
, 0, 0, 0,
231 "Return this buffer's mark, as a marker object.\n\
232 Watch out! Moving this marker changes the mark position.\n\
233 If you set the marker not to point anywhere, the buffer will have no mark.")
236 return current_buffer
->mark
;
239 #if 0 /* this is now in lisp code */
240 DEFUN ("set-mark", Fset_mark
, Sset_mark
, 1, 1, 0,
241 "Set this buffer's mark to POS. Don't use this function!\n\
242 That is to say, don't use this function unless you want\n\
243 the user to see that the mark has moved, and you want the previous\n\
244 mark position to be lost.\n\
246 Normally, when a new mark is set, the old one should go on the stack.\n\
247 This is why most applications should use push-mark, not set-mark.\n\
249 Novice programmers often try to use the mark for the wrong purposes.\n\
250 The mark saves a location for the user's convenience.\n\
251 Most editing commands should not alter the mark.\n\
252 To remember a location for internal use in the Lisp program,\n\
253 store it in a Lisp variable. Example:\n\
255 (let ((beg (point))) (forward-line 1) (delete-region beg (point))).")
261 current_buffer
->mark
= Qnil
;
264 CHECK_NUMBER_COERCE_MARKER (pos
, 0);
266 if (NILP (current_buffer
->mark
))
267 current_buffer
->mark
= Fmake_marker ();
269 Fset_marker (current_buffer
->mark
, pos
, Qnil
);
272 #endif /* commented-out code */
275 save_excursion_save ()
277 register int visible
= (XBUFFER (XWINDOW (selected_window
)->buffer
)
280 return Fcons (Fpoint_marker (),
281 Fcons (Fcopy_marker (current_buffer
->mark
),
282 Fcons (visible
? Qt
: Qnil
,
283 current_buffer
->mark_active
)));
287 save_excursion_restore (info
)
288 register Lisp_Object info
;
290 register Lisp_Object tem
, tem1
, omark
, nmark
;
292 tem
= Fmarker_buffer (Fcar (info
));
293 /* If buffer being returned to is now deleted, avoid error */
294 /* Otherwise could get error here while unwinding to top level
296 /* In that case, Fmarker_buffer returns nil now. */
302 unchain_marker (tem
);
303 tem
= Fcar (Fcdr (info
));
304 omark
= Fmarker_position (current_buffer
->mark
);
305 Fset_marker (current_buffer
->mark
, tem
, Fcurrent_buffer ());
306 nmark
= Fmarker_position (tem
);
307 unchain_marker (tem
);
308 tem
= Fcdr (Fcdr (info
));
309 #if 0 /* We used to make the current buffer visible in the selected window
310 if that was true previously. That avoids some anomalies.
311 But it creates others, and it wasn't documented, and it is simpler
312 and cleaner never to alter the window/buffer connections. */
315 && current_buffer
!= XBUFFER (XWINDOW (selected_window
)->buffer
))
316 Fswitch_to_buffer (Fcurrent_buffer (), Qnil
);
319 tem1
= current_buffer
->mark_active
;
320 current_buffer
->mark_active
= Fcdr (tem
);
321 if (!NILP (Vrun_hooks
))
323 /* If mark is active now, and either was not active
324 or was at a different place, run the activate hook. */
325 if (! NILP (current_buffer
->mark_active
))
327 if (! EQ (omark
, nmark
))
328 call1 (Vrun_hooks
, intern ("activate-mark-hook"));
330 /* If mark has ceased to be active, run deactivate hook. */
331 else if (! NILP (tem1
))
332 call1 (Vrun_hooks
, intern ("deactivate-mark-hook"));
337 DEFUN ("save-excursion", Fsave_excursion
, Ssave_excursion
, 0, UNEVALLED
, 0,
338 "Save point, mark, and current buffer; execute BODY; restore those things.\n\
339 Executes BODY just like `progn'.\n\
340 The values of point, mark and the current buffer are restored\n\
341 even in case of abnormal exit (throw or error).\n\
342 The state of activation of the mark is also restored.")
346 register Lisp_Object val
;
347 int count
= specpdl_ptr
- specpdl
;
349 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
352 return unbind_to (count
, val
);
355 DEFUN ("buffer-size", Fbufsize
, Sbufsize
, 0, 0, 0,
356 "Return the number of characters in the current buffer.")
360 XFASTINT (temp
) = Z
- BEG
;
364 DEFUN ("point-min", Fpoint_min
, Spoint_min
, 0, 0, 0,
365 "Return the minimum permissible value of point in the current buffer.\n\
366 This is 1, unless narrowing (a buffer restriction) is in effect.")
370 XFASTINT (temp
) = BEGV
;
374 DEFUN ("point-min-marker", Fpoint_min_marker
, Spoint_min_marker
, 0, 0, 0,
375 "Return a marker to the minimum permissible value of point in this buffer.\n\
376 This is the beginning, unless narrowing (a buffer restriction) is in effect.")
379 return buildmark (BEGV
);
382 DEFUN ("point-max", Fpoint_max
, Spoint_max
, 0, 0, 0,
383 "Return the maximum permissible value of point in the current buffer.\n\
384 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)\n\
385 is in effect, in which case it is less.")
389 XFASTINT (temp
) = ZV
;
393 DEFUN ("point-max-marker", Fpoint_max_marker
, Spoint_max_marker
, 0, 0, 0,
394 "Return a marker to the maximum permissible value of point in this buffer.\n\
395 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)\n\
396 is in effect, in which case it is less.")
399 return buildmark (ZV
);
402 DEFUN ("following-char", Ffollowing_char
, Sfollowing_char
, 0, 0, 0,
403 "Return the character following point, as a number.\n\
404 At the end of the buffer or accessible region, return 0.")
411 XFASTINT (temp
) = FETCH_CHAR (point
);
415 DEFUN ("preceding-char", Fprevious_char
, Sprevious_char
, 0, 0, 0,
416 "Return the character preceding point, as a number.\n\
417 At the beginning of the buffer or accessible region, return 0.")
424 XFASTINT (temp
) = FETCH_CHAR (point
- 1);
428 DEFUN ("bobp", Fbobp
, Sbobp
, 0, 0, 0,
429 "Return T if point is at the beginning of the buffer.\n\
430 If the buffer is narrowed, this means the beginning of the narrowed part.")
438 DEFUN ("eobp", Feobp
, Seobp
, 0, 0, 0,
439 "Return T if point is at the end of the buffer.\n\
440 If the buffer is narrowed, this means the end of the narrowed part.")
448 DEFUN ("bolp", Fbolp
, Sbolp
, 0, 0, 0,
449 "Return T if point is at the beginning of a line.")
452 if (point
== BEGV
|| FETCH_CHAR (point
- 1) == '\n')
457 DEFUN ("eolp", Feolp
, Seolp
, 0, 0, 0,
458 "Return T if point is at the end of a line.\n\
459 `End of a line' includes point being at the end of the buffer.")
462 if (point
== ZV
|| FETCH_CHAR (point
) == '\n')
467 DEFUN ("char-after", Fchar_after
, Schar_after
, 1, 1, 0,
468 "Return character in current buffer at position POS.\n\
469 POS is an integer or a buffer pointer.\n\
470 If POS is out of range, the value is nil.")
474 register Lisp_Object val
;
477 CHECK_NUMBER_COERCE_MARKER (pos
, 0);
480 if (n
< BEGV
|| n
>= ZV
) return Qnil
;
482 XFASTINT (val
) = FETCH_CHAR (n
);
486 DEFUN ("user-login-name", Fuser_login_name
, Suser_login_name
, 0, 0, 0,
487 "Return the name under which the user logged in, as a string.\n\
488 This is based on the effective uid, not the real uid.\n\
489 Also, if the environment variable LOGNAME or USER is set,\n\
490 that determines the value of this function.")
496 DEFUN ("user-real-login-name", Fuser_real_login_name
, Suser_real_login_name
,
498 "Return the name of the user's real uid, as a string.\n\
499 This ignores the environment variables LOGNAME and USER, so it differs from\n\
500 `user-login-name' when running under `su'.")
503 return Vuser_real_name
;
506 DEFUN ("user-uid", Fuser_uid
, Suser_uid
, 0, 0, 0,
507 "Return the effective uid of Emacs, as an integer.")
510 return make_number (geteuid ());
513 DEFUN ("user-real-uid", Fuser_real_uid
, Suser_real_uid
, 0, 0, 0,
514 "Return the real uid of Emacs, as an integer.")
517 return make_number (getuid ());
520 DEFUN ("user-full-name", Fuser_full_name
, Suser_full_name
, 0, 0, 0,
521 "Return the full name of the user logged in, as a string.")
524 return Vuser_full_name
;
527 DEFUN ("system-name", Fsystem_name
, Ssystem_name
, 0, 0, 0,
528 "Return the name of the machine you are running on, as a string.")
534 /* For the benefit of callers who don't want to include lisp.h */
538 return (char *) XSTRING (Vsystem_name
)->data
;
541 DEFUN ("emacs-pid", Femacs_pid
, Semacs_pid
, 0, 0, 0,
542 "Return the process ID of Emacs, as an integer.")
545 return make_number (getpid ());
548 DEFUN ("current-time", Fcurrent_time
, Scurrent_time
, 0, 0, 0,
549 "Return the current time, as the number of seconds since 12:00 AM January 1970.\n\
550 The time is returned as a list of three integers. The first has the\n\
551 most significant 16 bits of the seconds, while the second has the\n\
552 least significant 16 bits. The third integer gives the microsecond\n\
555 The microsecond count is zero on systems that do not provide\n\
556 resolution finer than a second.")
560 Lisp_Object result
[3];
563 XSET (result
[0], Lisp_Int
, (EMACS_SECS (t
) >> 16) & 0xffff);
564 XSET (result
[1], Lisp_Int
, (EMACS_SECS (t
) >> 0) & 0xffff);
565 XSET (result
[2], Lisp_Int
, EMACS_USECS (t
));
567 return Flist (3, result
);
572 lisp_time_argument (specified_time
, result
)
573 Lisp_Object specified_time
;
576 if (NILP (specified_time
))
577 return time (result
) != -1;
580 Lisp_Object high
, low
;
581 high
= Fcar (specified_time
);
582 CHECK_NUMBER (high
, 0);
583 low
= Fcdr (specified_time
);
584 if (XTYPE (low
) == Lisp_Cons
)
586 CHECK_NUMBER (low
, 0);
587 *result
= (XINT (high
) << 16) + (XINT (low
) & 0xffff);
588 return *result
>> 16 == XINT (high
);
592 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
, 0, 1, 0,
593 "Return the current time, as a human-readable string.\n\
594 Programs can use this function to decode a time,\n\
595 since the number of columns in each field is fixed.\n\
596 The format is `Sun Sep 16 01:03:52 1973'.\n\
597 If an argument is given, it specifies a time to format\n\
598 instead of the current time. The argument should have the form:\n\
601 (HIGH LOW . IGNORED).\n\
602 Thus, you can use times obtained from `current-time'\n\
603 and from `file-attributes'.")
605 Lisp_Object specified_time
;
611 if (! lisp_time_argument (specified_time
, &value
))
613 tem
= (char *) ctime (&value
);
615 strncpy (buf
, tem
, 24);
618 return build_string (buf
);
621 #define TM_YEAR_ORIGIN 1900
623 /* Yield A - B, measured in seconds. */
628 int ay
= a
->tm_year
+ (TM_YEAR_ORIGIN
- 1);
629 int by
= b
->tm_year
+ (TM_YEAR_ORIGIN
- 1);
630 /* Some compilers can't handle this as a single return statement. */
632 /* difference in day of year */
633 a
->tm_yday
- b
->tm_yday
634 /* + intervening leap days */
635 + ((ay
>> 2) - (by
>> 2))
637 + ((ay
/100 >> 2) - (by
/100 >> 2))
638 /* + difference in years * 365 */
639 + (long)(ay
-by
) * 365
641 return (60*(60*(24*days
+ (a
->tm_hour
- b
->tm_hour
))
642 + (a
->tm_min
- b
->tm_min
))
643 + (a
->tm_sec
- b
->tm_sec
));
646 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 1, 0,
647 "Return the offset and name for the local time zone.\n\
648 This returns a list of the form (OFFSET NAME).\n\
649 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).\n\
650 A negative value means west of Greenwich.\n\
651 NAME is a string giving the name of the time zone.\n\
652 If an argument is given, it specifies when the time zone offset is determined\n\
653 instead of using the current time. The argument should have the form:\n\
656 (HIGH LOW . IGNORED).\n\
657 Thus, you can use times obtained from `current-time'\n\
658 and from `file-attributes'.\n\
660 Some operating systems cannot provide all this information to Emacs;\n\
661 in this case, `current-time-zone' returns a list containing nil for\n\
662 the data it can't find.")
664 Lisp_Object specified_time
;
669 if (lisp_time_argument (specified_time
, &value
)
670 && (t
= gmtime (&value
)) != 0)
676 gmt
= *t
; /* Make a copy, in case localtime modifies *t. */
677 t
= localtime (&value
);
678 offset
= difftm (t
, &gmt
);
682 s
= (char *)t
->tm_zone
;
683 #else /* not HAVE_TM_ZONE */
685 if (t
->tm_isdst
== 0 || t
->tm_isdst
== 1)
686 s
= tzname
[t
->tm_isdst
];
688 #endif /* not HAVE_TM_ZONE */
691 /* No local time zone name is available; use "+-NNNN" instead. */
692 int am
= (offset
< 0 ? -offset
: offset
) / 60;
693 sprintf (buf
, "%c%02d%02d", (offset
< 0 ? '-' : '+'), am
/60, am
%60);
696 return Fcons (make_number (offset
), Fcons (build_string (s
), Qnil
));
699 return Fmake_list (2, Qnil
);
711 /* Callers passing one argument to Finsert need not gcpro the
712 argument "array", since the only element of the array will
713 not be used after calling insert or insert_from_string, so
714 we don't care if it gets trashed. */
716 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
717 "Insert the arguments, either strings or characters, at point.\n\
718 Point moves forward so that it ends up after the inserted text.\n\
719 Any other markers at the point of insertion remain before the text.")
722 register Lisp_Object
*args
;
725 register Lisp_Object tem
;
728 for (argnum
= 0; argnum
< nargs
; argnum
++)
732 if (XTYPE (tem
) == Lisp_Int
)
737 else if (XTYPE (tem
) == Lisp_String
)
739 insert_from_string (tem
, 0, XSTRING (tem
)->size
, 0);
743 tem
= wrong_type_argument (Qchar_or_string_p
, tem
);
751 DEFUN ("insert-and-inherit", Finsert_and_inherit
, Sinsert_and_inherit
,
753 "Insert the arguments at point, inheriting properties from adjoining text.\n\
754 Point moves forward so that it ends up after the inserted text.\n\
755 Any other markers at the point of insertion remain before the text.")
758 register Lisp_Object
*args
;
761 register Lisp_Object tem
;
764 for (argnum
= 0; argnum
< nargs
; argnum
++)
768 if (XTYPE (tem
) == Lisp_Int
)
773 else if (XTYPE (tem
) == Lisp_String
)
775 insert_from_string (tem
, 0, XSTRING (tem
)->size
, 1);
779 tem
= wrong_type_argument (Qchar_or_string_p
, tem
);
787 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
788 "Insert strings or characters at point, relocating markers after the text.\n\
789 Point moves forward so that it ends up after the inserted text.\n\
790 Any other markers at the point of insertion also end up after the text.")
793 register Lisp_Object
*args
;
796 register Lisp_Object tem
;
799 for (argnum
= 0; argnum
< nargs
; argnum
++)
803 if (XTYPE (tem
) == Lisp_Int
)
806 insert_before_markers (str
, 1);
808 else if (XTYPE (tem
) == Lisp_String
)
810 insert_from_string_before_markers (tem
, 0, XSTRING (tem
)->size
, 0);
814 tem
= wrong_type_argument (Qchar_or_string_p
, tem
);
822 DEFUN ("insert-before-markers-and-inherit",
823 Finsert_and_inherit_before_markers
, Sinsert_and_inherit_before_markers
,
825 "Insert text at point, relocating markers and inheriting properties.\n\
826 Point moves forward so that it ends up after the inserted text.\n\
827 Any other markers at the point of insertion also end up after the text.")
830 register Lisp_Object
*args
;
833 register Lisp_Object tem
;
836 for (argnum
= 0; argnum
< nargs
; argnum
++)
840 if (XTYPE (tem
) == Lisp_Int
)
843 insert_before_markers (str
, 1);
845 else if (XTYPE (tem
) == Lisp_String
)
847 insert_from_string_before_markers (tem
, 0, XSTRING (tem
)->size
, 1);
851 tem
= wrong_type_argument (Qchar_or_string_p
, tem
);
859 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 2, 2, 0,
860 "Insert COUNT (second arg) copies of CHAR (first arg).\n\
861 Point and all markers are affected as in the function `insert'.\n\
862 Both arguments are required.")
864 Lisp_Object chr
, count
;
866 register unsigned char *string
;
870 CHECK_NUMBER (chr
, 0);
871 CHECK_NUMBER (count
, 1);
876 strlen
= min (n
, 256);
877 string
= (unsigned char *) alloca (strlen
);
878 for (i
= 0; i
< strlen
; i
++)
879 string
[i
] = XFASTINT (chr
);
882 insert (string
, strlen
);
891 /* Making strings from buffer contents. */
893 /* Return a Lisp_String containing the text of the current buffer from
894 START to END. If text properties are in use and the current buffer
895 has properties in the range specified, the resulting string will also
898 We don't want to use plain old make_string here, because it calls
899 make_uninit_string, which can cause the buffer arena to be
900 compacted. make_string has no way of knowing that the data has
901 been moved, and thus copies the wrong data into the string. This
902 doesn't effect most of the other users of make_string, so it should
903 be left as is. But we should use this function when conjuring
904 buffer substrings. */
907 make_buffer_string (start
, end
)
910 Lisp_Object result
, tem
, tem1
;
912 if (start
< GPT
&& GPT
< end
)
915 result
= make_uninit_string (end
- start
);
916 bcopy (&FETCH_CHAR (start
), XSTRING (result
)->data
, end
- start
);
918 tem
= Fnext_property_change (make_number (start
), Qnil
, make_number (end
));
919 tem1
= Ftext_properties_at (make_number (start
), Qnil
);
921 #ifdef USE_TEXT_PROPERTIES
922 if (XINT (tem
) != end
|| !NILP (tem1
))
923 copy_intervals_to_string (result
, current_buffer
, start
, end
- start
);
929 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
930 "Return the contents of part of the current buffer as a string.\n\
931 The two arguments START and END are character positions;\n\
932 they can be in either order.")
936 register int beg
, end
;
938 validate_region (&b
, &e
);
942 return make_buffer_string (beg
, end
);
945 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
946 "Return the contents of the current buffer as a string.")
949 return make_buffer_string (BEGV
, ZV
);
952 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
954 "Insert before point a substring of the contents of buffer BUFFER.\n\
955 BUFFER may be a buffer or a buffer name.\n\
956 Arguments START and END are character numbers specifying the substring.\n\
957 They default to the beginning and the end of BUFFER.")
959 Lisp_Object buf
, b
, e
;
961 register int beg
, end
, temp
, len
, opoint
, start
;
962 register struct buffer
*bp
;
965 buffer
= Fget_buffer (buf
);
968 bp
= XBUFFER (buffer
);
974 CHECK_NUMBER_COERCE_MARKER (b
, 0);
981 CHECK_NUMBER_COERCE_MARKER (e
, 1);
986 temp
= beg
, beg
= end
, end
= temp
;
988 /* Move the gap or create enough gap in the current buffer. */
992 if (GAP_SIZE
< end
- beg
)
993 make_gap (end
- beg
- GAP_SIZE
);
999 if (!(BUF_BEGV (bp
) <= beg
1001 && end
<= BUF_ZV (bp
)))
1002 args_out_of_range (b
, e
);
1004 /* Now the actual insertion will not do any gap motion,
1005 so it matters not if BUF is the current buffer. */
1006 if (beg
< BUF_GPT (bp
))
1008 insert (BUF_CHAR_ADDRESS (bp
, beg
), min (end
, BUF_GPT (bp
)) - beg
);
1009 beg
= min (end
, BUF_GPT (bp
));
1012 insert (BUF_CHAR_ADDRESS (bp
, beg
), end
- beg
);
1014 /* Only defined if Emacs is compiled with USE_TEXT_PROPERTIES */
1015 graft_intervals_into_buffer (copy_intervals (bp
->intervals
, start
, len
),
1016 opoint
, len
, current_buffer
, 0);
1021 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
1023 "Compare two substrings of two buffers; return result as number.\n\
1024 the value is -N if first string is less after N-1 chars,\n\
1025 +N if first string is greater after N-1 chars, or 0 if strings match.\n\
1026 Each substring is represented as three arguments: BUFFER, START and END.\n\
1027 That makes six args in all, three for each substring.\n\n\
1028 The value of `case-fold-search' in the current buffer\n\
1029 determines whether case is significant or ignored.")
1030 (buffer1
, start1
, end1
, buffer2
, start2
, end2
)
1031 Lisp_Object buffer1
, start1
, end1
, buffer2
, start2
, end2
;
1033 register int begp1
, endp1
, begp2
, endp2
, temp
, len1
, len2
, length
, i
;
1034 register struct buffer
*bp1
, *bp2
;
1035 register unsigned char *trt
1036 = (!NILP (current_buffer
->case_fold_search
)
1037 ? XSTRING (current_buffer
->case_canon_table
)->data
: 0);
1039 /* Find the first buffer and its substring. */
1042 bp1
= current_buffer
;
1046 buf1
= Fget_buffer (buffer1
);
1049 bp1
= XBUFFER (buf1
);
1053 begp1
= BUF_BEGV (bp1
);
1056 CHECK_NUMBER_COERCE_MARKER (start1
, 1);
1057 begp1
= XINT (start1
);
1060 endp1
= BUF_ZV (bp1
);
1063 CHECK_NUMBER_COERCE_MARKER (end1
, 2);
1064 endp1
= XINT (end1
);
1068 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
1070 if (!(BUF_BEGV (bp1
) <= begp1
1072 && endp1
<= BUF_ZV (bp1
)))
1073 args_out_of_range (start1
, end1
);
1075 /* Likewise for second substring. */
1078 bp2
= current_buffer
;
1082 buf2
= Fget_buffer (buffer2
);
1085 bp2
= XBUFFER (buffer2
);
1089 begp2
= BUF_BEGV (bp2
);
1092 CHECK_NUMBER_COERCE_MARKER (start2
, 4);
1093 begp2
= XINT (start2
);
1096 endp2
= BUF_ZV (bp2
);
1099 CHECK_NUMBER_COERCE_MARKER (end2
, 5);
1100 endp2
= XINT (end2
);
1104 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
1106 if (!(BUF_BEGV (bp2
) <= begp2
1108 && endp2
<= BUF_ZV (bp2
)))
1109 args_out_of_range (start2
, end2
);
1111 len1
= endp1
- begp1
;
1112 len2
= endp2
- begp2
;
1117 for (i
= 0; i
< length
; i
++)
1119 int c1
= *BUF_CHAR_ADDRESS (bp1
, begp1
+ i
);
1120 int c2
= *BUF_CHAR_ADDRESS (bp2
, begp2
+ i
);
1127 return make_number (- 1 - i
);
1129 return make_number (i
+ 1);
1132 /* The strings match as far as they go.
1133 If one is shorter, that one is less. */
1135 return make_number (length
+ 1);
1136 else if (length
< len2
)
1137 return make_number (- length
- 1);
1139 /* Same length too => they are equal. */
1140 return make_number (0);
1143 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
1144 Ssubst_char_in_region
, 4, 5, 0,
1145 "From START to END, replace FROMCHAR with TOCHAR each time it occurs.\n\
1146 If optional arg NOUNDO is non-nil, don't record this change for undo\n\
1147 and don't mark the buffer as really changed.")
1148 (start
, end
, fromchar
, tochar
, noundo
)
1149 Lisp_Object start
, end
, fromchar
, tochar
, noundo
;
1151 register int pos
, stop
, look
;
1154 validate_region (&start
, &end
);
1155 CHECK_NUMBER (fromchar
, 2);
1156 CHECK_NUMBER (tochar
, 3);
1160 look
= XINT (fromchar
);
1164 if (FETCH_CHAR (pos
) == look
)
1168 modify_region (current_buffer
, XINT (start
), stop
);
1170 if (! NILP (noundo
))
1172 if (MODIFF
- 1 == current_buffer
->save_modified
)
1173 current_buffer
->save_modified
++;
1174 if (MODIFF
- 1 == current_buffer
->auto_save_modified
)
1175 current_buffer
->auto_save_modified
++;
1182 record_change (pos
, 1);
1183 FETCH_CHAR (pos
) = XINT (tochar
);
1189 signal_after_change (XINT (start
),
1190 stop
- XINT (start
), stop
- XINT (start
));
1195 DEFUN ("translate-region", Ftranslate_region
, Stranslate_region
, 3, 3, 0,
1196 "From START to END, translate characters according to TABLE.\n\
1197 TABLE is a string; the Nth character in it is the mapping\n\
1198 for the character with code N. Returns the number of characters changed.")
1202 register Lisp_Object table
;
1204 register int pos
, stop
; /* Limits of the region. */
1205 register unsigned char *tt
; /* Trans table. */
1206 register int oc
; /* Old character. */
1207 register int nc
; /* New character. */
1208 int cnt
; /* Number of changes made. */
1209 Lisp_Object z
; /* Return. */
1210 int size
; /* Size of translate table. */
1212 validate_region (&start
, &end
);
1213 CHECK_STRING (table
, 2);
1215 size
= XSTRING (table
)->size
;
1216 tt
= XSTRING (table
)->data
;
1220 modify_region (current_buffer
, pos
, stop
);
1223 for (; pos
< stop
; ++pos
)
1225 oc
= FETCH_CHAR (pos
);
1231 record_change (pos
, 1);
1232 FETCH_CHAR (pos
) = nc
;
1233 signal_after_change (pos
, 1, 1);
1243 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
1244 "Delete the text between point and mark.\n\
1245 When called from a program, expects two arguments,\n\
1246 positions (integers or markers) specifying the stretch to be deleted.")
1250 validate_region (&b
, &e
);
1251 del_range (XINT (b
), XINT (e
));
1255 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
1256 "Remove restrictions (narrowing) from current buffer.\n\
1257 This allows the buffer's full text to be seen and edited.")
1261 SET_BUF_ZV (current_buffer
, Z
);
1263 /* Changing the buffer bounds invalidates any recorded current column. */
1264 invalidate_current_column ();
1268 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
1269 "Restrict editing in this buffer to the current region.\n\
1270 The rest of the text becomes temporarily invisible and untouchable\n\
1271 but is not deleted; if you save the buffer in a file, the invisible\n\
1272 text is included in the file. \\[widen] makes all visible again.\n\
1273 See also `save-restriction'.\n\
1275 When calling from a program, pass two arguments; positions (integers\n\
1276 or markers) bounding the text that should remain visible.")
1278 register Lisp_Object b
, e
;
1282 CHECK_NUMBER_COERCE_MARKER (b
, 0);
1283 CHECK_NUMBER_COERCE_MARKER (e
, 1);
1285 if (XINT (b
) > XINT (e
))
1292 if (!(BEG
<= XINT (b
) && XINT (b
) <= XINT (e
) && XINT (e
) <= Z
))
1293 args_out_of_range (b
, e
);
1295 BEGV
= XFASTINT (b
);
1296 SET_BUF_ZV (current_buffer
, XFASTINT (e
));
1297 if (point
< XFASTINT (b
))
1298 SET_PT (XFASTINT (b
));
1299 if (point
> XFASTINT (e
))
1300 SET_PT (XFASTINT (e
));
1302 /* Changing the buffer bounds invalidates any recorded current column. */
1303 invalidate_current_column ();
1308 save_restriction_save ()
1310 register Lisp_Object bottom
, top
;
1311 /* Note: I tried using markers here, but it does not win
1312 because insertion at the end of the saved region
1313 does not advance mh and is considered "outside" the saved region. */
1314 XFASTINT (bottom
) = BEGV
- BEG
;
1315 XFASTINT (top
) = Z
- ZV
;
1317 return Fcons (Fcurrent_buffer (), Fcons (bottom
, top
));
1321 save_restriction_restore (data
)
1324 register struct buffer
*buf
;
1325 register int newhead
, newtail
;
1326 register Lisp_Object tem
;
1328 buf
= XBUFFER (XCONS (data
)->car
);
1330 data
= XCONS (data
)->cdr
;
1332 tem
= XCONS (data
)->car
;
1333 newhead
= XINT (tem
);
1334 tem
= XCONS (data
)->cdr
;
1335 newtail
= XINT (tem
);
1336 if (newhead
+ newtail
> BUF_Z (buf
) - BUF_BEG (buf
))
1341 BUF_BEGV (buf
) = BUF_BEG (buf
) + newhead
;
1342 SET_BUF_ZV (buf
, BUF_Z (buf
) - newtail
);
1345 /* If point is outside the new visible range, move it inside. */
1347 clip_to_bounds (BUF_BEGV (buf
), BUF_PT (buf
), BUF_ZV (buf
)));
1352 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
1353 "Execute BODY, saving and restoring current buffer's restrictions.\n\
1354 The buffer's restrictions make parts of the beginning and end invisible.\n\
1355 \(They are set up with `narrow-to-region' and eliminated with `widen'.)\n\
1356 This special form, `save-restriction', saves the current buffer's restrictions\n\
1357 when it is entered, and restores them when it is exited.\n\
1358 So any `narrow-to-region' within BODY lasts only until the end of the form.\n\
1359 The old restrictions settings are restored\n\
1360 even in case of abnormal exit (throw or error).\n\
1362 The value returned is the value of the last form in BODY.\n\
1364 `save-restriction' can get confused if, within the BODY, you widen\n\
1365 and then make changes outside the area within the saved restrictions.\n\
1367 Note: if you are using both `save-excursion' and `save-restriction',\n\
1368 use `save-excursion' outermost:\n\
1369 (save-excursion (save-restriction ...))")
1373 register Lisp_Object val
;
1374 int count
= specpdl_ptr
- specpdl
;
1376 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
1377 val
= Fprogn (body
);
1378 return unbind_to (count
, val
);
1381 /* Buffer for the most recent text displayed by Fmessage. */
1382 static char *message_text
;
1384 /* Allocated length of that buffer. */
1385 static int message_length
;
1387 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
1388 "Print a one-line message at the bottom of the screen.\n\
1389 The first argument is a control string.\n\
1390 It may contain %s or %d or %c to print successive following arguments.\n\
1391 %s means print an argument as a string, %d means print as number in decimal,\n\
1392 %c means print a number as a single character.\n\
1393 The argument used by %s must be a string or a symbol;\n\
1394 the argument used by %d or %c must be a number.\n\
1395 If the first argument is nil, clear any existing message; let the\n\
1396 minibuffer contents show.")
1408 register Lisp_Object val
;
1409 val
= Fformat (nargs
, args
);
1410 /* Copy the data so that it won't move when we GC. */
1413 message_text
= (char *)xmalloc (80);
1414 message_length
= 80;
1416 if (XSTRING (val
)->size
> message_length
)
1418 message_length
= XSTRING (val
)->size
;
1419 message_text
= (char *)xrealloc (message_text
, message_length
);
1421 bcopy (XSTRING (val
)->data
, message_text
, XSTRING (val
)->size
);
1422 message2 (message_text
, XSTRING (val
)->size
);
1427 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
1428 "Format a string out of a control-string and arguments.\n\
1429 The first argument is a control string.\n\
1430 The other arguments are substituted into it to make the result, a string.\n\
1431 It may contain %-sequences meaning to substitute the next argument.\n\
1432 %s means print a string argument. Actually, prints any object, with `princ'.\n\
1433 %d means print as number in decimal (%o octal, %x hex).\n\
1434 %c means print a number as a single character.\n\
1435 %S means print any object as an s-expression (using prin1).\n\
1436 The argument used for %d, %o, %x or %c must be a number.\n\
1437 Use %% to put a single % into the output.")
1440 register Lisp_Object
*args
;
1442 register int n
; /* The number of the next arg to substitute */
1443 register int total
= 5; /* An estimate of the final length */
1445 register unsigned char *format
, *end
;
1447 extern char *index ();
1448 /* It should not be necessary to GCPRO ARGS, because
1449 the caller in the interpreter should take care of that. */
1451 CHECK_STRING (args
[0], 0);
1452 format
= XSTRING (args
[0])->data
;
1453 end
= format
+ XSTRING (args
[0])->size
;
1456 while (format
!= end
)
1457 if (*format
++ == '%')
1461 /* Process a numeric arg and skip it. */
1462 minlen
= atoi (format
);
1467 while ((*format
>= '0' && *format
<= '9')
1468 || *format
== '-' || *format
== ' ' || *format
== '.')
1473 else if (++n
>= nargs
)
1474 error ("not enough arguments for format string");
1475 else if (*format
== 'S')
1477 /* For `S', prin1 the argument and then treat like a string. */
1478 register Lisp_Object tem
;
1479 tem
= Fprin1_to_string (args
[n
], Qnil
);
1483 else if (XTYPE (args
[n
]) == Lisp_Symbol
)
1485 XSET (args
[n
], Lisp_String
, XSYMBOL (args
[n
])->name
);
1488 else if (XTYPE (args
[n
]) == Lisp_String
)
1491 if (*format
!= 's' && *format
!= 'S')
1492 error ("format specifier doesn't match argument type");
1493 total
+= XSTRING (args
[n
])->size
;
1495 /* Would get MPV otherwise, since Lisp_Int's `point' to low memory. */
1496 else if (XTYPE (args
[n
]) == Lisp_Int
&& *format
!= 's')
1498 #ifdef LISP_FLOAT_TYPE
1499 /* The following loop assumes the Lisp type indicates
1500 the proper way to pass the argument.
1501 So make sure we have a flonum if the argument should
1503 if (*format
== 'e' || *format
== 'f' || *format
== 'g')
1504 args
[n
] = Ffloat (args
[n
]);
1508 #ifdef LISP_FLOAT_TYPE
1509 else if (XTYPE (args
[n
]) == Lisp_Float
&& *format
!= 's')
1511 if (! (*format
== 'e' || *format
== 'f' || *format
== 'g'))
1512 args
[n
] = Ftruncate (args
[n
]);
1518 /* Anything but a string, convert to a string using princ. */
1519 register Lisp_Object tem
;
1520 tem
= Fprin1_to_string (args
[n
], Qt
);
1527 register int nstrings
= n
+ 1;
1529 /* Allocate twice as many strings as we have %-escapes; floats occupy
1530 two slots, and we're not sure how many of those we have. */
1531 register unsigned char **strings
1532 = (unsigned char **) alloca (2 * nstrings
* sizeof (unsigned char *));
1536 for (n
= 0; n
< nstrings
; n
++)
1539 strings
[i
++] = (unsigned char *) "";
1540 else if (XTYPE (args
[n
]) == Lisp_Int
)
1541 /* We checked above that the corresponding format effector
1542 isn't %s, which would cause MPV. */
1543 strings
[i
++] = (unsigned char *) XINT (args
[n
]);
1544 #ifdef LISP_FLOAT_TYPE
1545 else if (XTYPE (args
[n
]) == Lisp_Float
)
1547 union { double d
; int half
[2]; } u
;
1549 u
.d
= XFLOAT (args
[n
])->data
;
1550 strings
[i
++] = (unsigned char *) u
.half
[0];
1551 strings
[i
++] = (unsigned char *) u
.half
[1];
1555 strings
[i
++] = XSTRING (args
[n
])->data
;
1558 /* Format it in bigger and bigger buf's until it all fits. */
1561 buf
= (char *) alloca (total
+ 1);
1564 length
= doprnt (buf
, total
+ 1, strings
[0], end
, i
-1, strings
+ 1);
1565 if (buf
[total
- 1] == 0)
1573 return make_string (buf
, length
);
1579 format1 (string1
, arg0
, arg1
, arg2
, arg3
, arg4
)
1580 int arg0
, arg1
, arg2
, arg3
, arg4
;
1594 doprnt (buf
, sizeof buf
, string1
, 0, 5, args
);
1596 doprnt (buf
, sizeof buf
, string1
, 0, 5, &string1
+ 1);
1598 return build_string (buf
);
1601 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
1602 "Return t if two characters match, optionally ignoring case.\n\
1603 Both arguments must be characters (i.e. integers).\n\
1604 Case is ignored if `case-fold-search' is non-nil in the current buffer.")
1606 register Lisp_Object c1
, c2
;
1608 unsigned char *downcase
= DOWNCASE_TABLE
;
1609 CHECK_NUMBER (c1
, 0);
1610 CHECK_NUMBER (c2
, 1);
1612 if (!NILP (current_buffer
->case_fold_search
)
1613 ? (downcase
[0xff & XFASTINT (c1
)] == downcase
[0xff & XFASTINT (c2
)]
1614 && (XFASTINT (c1
) & ~0xff) == (XFASTINT (c2
) & ~0xff))
1615 : XINT (c1
) == XINT (c2
))
1620 /* Transpose the markers in two regions of the current buffer, and
1621 adjust the ones between them if necessary (i.e.: if the regions
1624 Traverses the entire marker list of the buffer to do so, adding an
1625 appropriate amount to some, subtracting from some, and leaving the
1626 rest untouched. Most of this is copied from adjust_markers in insdel.c.
1628 It's the caller's job to see that (start1 <= end1 <= start2 <= end2). */
1631 transpose_markers (start1
, end1
, start2
, end2
)
1632 register int start1
, end1
, start2
, end2
;
1634 register int amt1
, amt2
, diff
, mpos
;
1635 register Lisp_Object marker
;
1637 /* Update point as if it were a marker. */
1641 TEMP_SET_PT (PT
+ (end2
- end1
));
1642 else if (PT
< start2
)
1643 TEMP_SET_PT (PT
+ (end2
- start2
) - (end1
- start1
));
1645 TEMP_SET_PT (PT
- (start2
- start1
));
1647 /* We used to adjust the endpoints here to account for the gap, but that
1648 isn't good enough. Even if we assume the caller has tried to move the
1649 gap out of our way, it might still be at start1 exactly, for example;
1650 and that places it `inside' the interval, for our purposes. The amount
1651 of adjustment is nontrivial if there's a `denormalized' marker whose
1652 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
1653 the dirty work to Fmarker_position, below. */
1655 /* The difference between the region's lengths */
1656 diff
= (end2
- start2
) - (end1
- start1
);
1658 /* For shifting each marker in a region by the length of the other
1659 * region plus the distance between the regions.
1661 amt1
= (end2
- start2
) + (start2
- end1
);
1662 amt2
= (end1
- start1
) + (start2
- end1
);
1664 for (marker
= current_buffer
->markers
; !NILP (marker
);
1665 marker
= XMARKER (marker
)->chain
)
1667 mpos
= Fmarker_position (marker
);
1668 if (mpos
>= start1
&& mpos
< end2
)
1672 else if (mpos
< start2
)
1676 if (mpos
> GPT
) mpos
+= GAP_SIZE
;
1677 XMARKER (marker
)->bufpos
= mpos
;
1682 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
1683 "Transpose region START1 to END1 with START2 to END2.\n\
1684 The regions may not be overlapping, because the size of the buffer is\n\
1685 never changed in a transposition.\n\
1687 Optional fifth arg LEAVE_MARKERS, if non-nil, means don't transpose\n\
1688 any markers that happen to be located in the regions.\n\
1690 Transposing beyond buffer boundaries is an error.")
1691 (startr1
, endr1
, startr2
, endr2
, leave_markers
)
1692 Lisp_Object startr1
, endr1
, startr2
, endr2
, leave_markers
;
1694 register int start1
, end1
, start2
, end2
,
1695 gap
, len1
, len_mid
, len2
;
1696 unsigned char *start1_addr
, *start2_addr
, *temp
;
1698 #ifdef USE_TEXT_PROPERTIES
1699 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
;
1700 cur_intv
= current_buffer
->intervals
;
1701 #endif /* USE_TEXT_PROPERTIES */
1703 validate_region (&startr1
, &endr1
);
1704 validate_region (&startr2
, &endr2
);
1706 start1
= XFASTINT (startr1
);
1707 end1
= XFASTINT (endr1
);
1708 start2
= XFASTINT (startr2
);
1709 end2
= XFASTINT (endr2
);
1712 /* Swap the regions if they're reversed. */
1715 register int glumph
= start1
;
1723 len1
= end1
- start1
;
1724 len2
= end2
- start2
;
1727 error ("transposed regions not properly ordered");
1728 else if (start1
== end1
|| start2
== end2
)
1729 error ("transposed region may not be of length 0");
1731 /* The possibilities are:
1732 1. Adjacent (contiguous) regions, or separate but equal regions
1733 (no, really equal, in this case!), or
1734 2. Separate regions of unequal size.
1736 The worst case is usually No. 2. It means that (aside from
1737 potential need for getting the gap out of the way), there also
1738 needs to be a shifting of the text between the two regions. So
1739 if they are spread far apart, we are that much slower... sigh. */
1741 /* It must be pointed out that the really studly thing to do would
1742 be not to move the gap at all, but to leave it in place and work
1743 around it if necessary. This would be extremely efficient,
1744 especially considering that people are likely to do
1745 transpositions near where they are working interactively, which
1746 is exactly where the gap would be found. However, such code
1747 would be much harder to write and to read. So, if you are
1748 reading this comment and are feeling squirrely, by all means have
1749 a go! I just didn't feel like doing it, so I will simply move
1750 the gap the minimum distance to get it out of the way, and then
1751 deal with an unbroken array. */
1753 /* Make sure the gap won't interfere, by moving it out of the text
1754 we will operate on. */
1755 if (start1
< gap
&& gap
< end2
)
1757 if (gap
- start1
< end2
- gap
)
1763 /* Hmmm... how about checking to see if the gap is large
1764 enough to use as the temporary storage? That would avoid an
1765 allocation... interesting. Later, don't fool with it now. */
1767 /* Working without memmove, for portability (sigh), so must be
1768 careful of overlapping subsections of the array... */
1770 if (end1
== start2
) /* adjacent regions */
1772 modify_region (current_buffer
, start1
, end2
);
1773 record_change (start1
, len1
+ len2
);
1775 #ifdef USE_TEXT_PROPERTIES
1776 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
1777 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
1778 Fset_text_properties (start1
, end2
, Qnil
, Qnil
);
1779 #endif /* USE_TEXT_PROPERTIES */
1781 /* First region smaller than second. */
1784 /* We use alloca only if it is small,
1785 because we want to avoid stack overflow. */
1787 temp
= (unsigned char *) xmalloc (len2
);
1789 temp
= (unsigned char *) alloca (len2
);
1791 /* Don't precompute these addresses. We have to compute them
1792 at the last minute, because the relocating allocator might
1793 have moved the buffer around during the xmalloc. */
1794 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1
);
1795 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2
);
1797 bcopy (start2_addr
, temp
, len2
);
1798 bcopy (start1_addr
, start1_addr
+ len2
, len1
);
1799 bcopy (temp
, start1_addr
, len2
);
1804 /* First region not smaller than second. */
1807 temp
= (unsigned char *) xmalloc (len1
);
1809 temp
= (unsigned char *) alloca (len1
);
1810 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1
);
1811 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2
);
1812 bcopy (start1_addr
, temp
, len1
);
1813 bcopy (start2_addr
, start1_addr
, len2
);
1814 bcopy (temp
, start1_addr
+ len2
, len1
);
1818 #ifdef USE_TEXT_PROPERTIES
1819 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
1820 len1
, current_buffer
, 0);
1821 graft_intervals_into_buffer (tmp_interval2
, start1
,
1822 len2
, current_buffer
, 0);
1823 #endif /* USE_TEXT_PROPERTIES */
1825 /* Non-adjacent regions, because end1 != start2, bleagh... */
1829 /* Regions are same size, though, how nice. */
1831 modify_region (current_buffer
, start1
, end1
);
1832 modify_region (current_buffer
, start2
, end2
);
1833 record_change (start1
, len1
);
1834 record_change (start2
, len2
);
1835 #ifdef USE_TEXT_PROPERTIES
1836 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
1837 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
1838 Fset_text_properties (start1
, end1
, Qnil
, Qnil
);
1839 Fset_text_properties (start2
, end2
, Qnil
, Qnil
);
1840 #endif /* USE_TEXT_PROPERTIES */
1843 temp
= (unsigned char *) xmalloc (len1
);
1845 temp
= (unsigned char *) alloca (len1
);
1846 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1
);
1847 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2
);
1848 bcopy (start1_addr
, temp
, len1
);
1849 bcopy (start2_addr
, start1_addr
, len2
);
1850 bcopy (temp
, start2_addr
, len1
);
1853 #ifdef USE_TEXT_PROPERTIES
1854 graft_intervals_into_buffer (tmp_interval1
, start2
,
1855 len1
, current_buffer
, 0);
1856 graft_intervals_into_buffer (tmp_interval2
, start1
,
1857 len2
, current_buffer
, 0);
1858 #endif /* USE_TEXT_PROPERTIES */
1861 else if (len1
< len2
) /* Second region larger than first */
1862 /* Non-adjacent & unequal size, area between must also be shifted. */
1864 len_mid
= start2
- end1
;
1865 modify_region (current_buffer
, start1
, end2
);
1866 record_change (start1
, (end2
- start1
));
1867 #ifdef USE_TEXT_PROPERTIES
1868 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
1869 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
1870 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
1871 Fset_text_properties (start1
, end2
, Qnil
, Qnil
);
1872 #endif /* USE_TEXT_PROPERTIES */
1874 /* holds region 2 */
1876 temp
= (unsigned char *) xmalloc (len2
);
1878 temp
= (unsigned char *) alloca (len2
);
1879 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1
);
1880 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2
);
1881 bcopy (start2_addr
, temp
, len2
);
1882 bcopy (start1_addr
, start1_addr
+ len_mid
+ len2
, len1
);
1883 safe_bcopy (start1_addr
+ len1
, start1_addr
+ len2
, len_mid
);
1884 bcopy (temp
, start1_addr
, len2
);
1887 #ifdef USE_TEXT_PROPERTIES
1888 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
1889 len1
, current_buffer
, 0);
1890 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
1891 len_mid
, current_buffer
, 0);
1892 graft_intervals_into_buffer (tmp_interval2
, start1
,
1893 len2
, current_buffer
, 0);
1894 #endif /* USE_TEXT_PROPERTIES */
1897 /* Second region smaller than first. */
1899 len_mid
= start2
- end1
;
1900 record_change (start1
, (end2
- start1
));
1901 modify_region (current_buffer
, start1
, end2
);
1903 #ifdef USE_TEXT_PROPERTIES
1904 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
1905 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
1906 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
1907 Fset_text_properties (start1
, end2
, Qnil
, Qnil
);
1908 #endif /* USE_TEXT_PROPERTIES */
1910 /* holds region 1 */
1912 temp
= (unsigned char *) xmalloc (len1
);
1914 temp
= (unsigned char *) alloca (len1
);
1915 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1
);
1916 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2
);
1917 bcopy (start1_addr
, temp
, len1
);
1918 bcopy (start2_addr
, start1_addr
, len2
);
1919 bcopy (start1_addr
+ len1
, start1_addr
+ len2
, len_mid
);
1920 bcopy (temp
, start1_addr
+ len2
+ len_mid
, len1
);
1923 #ifdef USE_TEXT_PROPERTIES
1924 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
1925 len1
, current_buffer
, 0);
1926 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
1927 len_mid
, current_buffer
, 0);
1928 graft_intervals_into_buffer (tmp_interval2
, start1
,
1929 len2
, current_buffer
, 0);
1930 #endif /* USE_TEXT_PROPERTIES */
1934 /* todo: this will be slow, because for every transposition, we
1935 traverse the whole friggin marker list. Possible solutions:
1936 somehow get a list of *all* the markers across multiple
1937 transpositions and do it all in one swell phoop. Or maybe modify
1938 Emacs' marker code to keep an ordered list or tree. This might
1939 be nicer, and more beneficial in the long run, but would be a
1940 bunch of work. Plus the way they're arranged now is nice. */
1941 if (NILP (leave_markers
))
1943 transpose_markers (start1
, end1
, start2
, end2
);
1944 fix_overlays_in_range (start1
, end2
);
1954 staticpro (&Vuser_name
);
1955 staticpro (&Vuser_full_name
);
1956 staticpro (&Vuser_real_name
);
1957 staticpro (&Vsystem_name
);
1959 defsubr (&Schar_equal
);
1960 defsubr (&Sgoto_char
);
1961 defsubr (&Sstring_to_char
);
1962 defsubr (&Schar_to_string
);
1963 defsubr (&Sbuffer_substring
);
1964 defsubr (&Sbuffer_string
);
1966 defsubr (&Spoint_marker
);
1967 defsubr (&Smark_marker
);
1969 defsubr (&Sregion_beginning
);
1970 defsubr (&Sregion_end
);
1971 /* defsubr (&Smark); */
1972 /* defsubr (&Sset_mark); */
1973 defsubr (&Ssave_excursion
);
1975 defsubr (&Sbufsize
);
1976 defsubr (&Spoint_max
);
1977 defsubr (&Spoint_min
);
1978 defsubr (&Spoint_min_marker
);
1979 defsubr (&Spoint_max_marker
);
1985 defsubr (&Sfollowing_char
);
1986 defsubr (&Sprevious_char
);
1987 defsubr (&Schar_after
);
1989 defsubr (&Sinsert_before_markers
);
1990 defsubr (&Sinsert_and_inherit
);
1991 defsubr (&Sinsert_and_inherit_before_markers
);
1992 defsubr (&Sinsert_char
);
1994 defsubr (&Suser_login_name
);
1995 defsubr (&Suser_real_login_name
);
1996 defsubr (&Suser_uid
);
1997 defsubr (&Suser_real_uid
);
1998 defsubr (&Suser_full_name
);
1999 defsubr (&Semacs_pid
);
2000 defsubr (&Scurrent_time
);
2001 defsubr (&Scurrent_time_string
);
2002 defsubr (&Scurrent_time_zone
);
2003 defsubr (&Ssystem_name
);
2004 defsubr (&Smessage
);
2007 defsubr (&Sinsert_buffer_substring
);
2008 defsubr (&Scompare_buffer_substrings
);
2009 defsubr (&Ssubst_char_in_region
);
2010 defsubr (&Stranslate_region
);
2011 defsubr (&Sdelete_region
);
2013 defsubr (&Snarrow_to_region
);
2014 defsubr (&Ssave_restriction
);
2015 defsubr (&Stranspose_regions
);