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
)
771 insert_and_inherit (str
, 1);
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_and_inherit (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, 3, 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.\n\
863 The optional third arg INHERIT, if non-nil, says to inherit text properties\n\
864 from adjoining text, if those properties are sticky.")
865 (chr
, count
, inherit
)
866 Lisp_Object chr
, count
, inherit
;
868 register unsigned char *string
;
872 CHECK_NUMBER (chr
, 0);
873 CHECK_NUMBER (count
, 1);
878 strlen
= min (n
, 256);
879 string
= (unsigned char *) alloca (strlen
);
880 for (i
= 0; i
< strlen
; i
++)
881 string
[i
] = XFASTINT (chr
);
885 insert_and_inherit (string
, strlen
);
887 insert (string
, strlen
);
896 /* Making strings from buffer contents. */
898 /* Return a Lisp_String containing the text of the current buffer from
899 START to END. If text properties are in use and the current buffer
900 has properties in the range specified, the resulting string will also
903 We don't want to use plain old make_string here, because it calls
904 make_uninit_string, which can cause the buffer arena to be
905 compacted. make_string has no way of knowing that the data has
906 been moved, and thus copies the wrong data into the string. This
907 doesn't effect most of the other users of make_string, so it should
908 be left as is. But we should use this function when conjuring
909 buffer substrings. */
912 make_buffer_string (start
, end
)
915 Lisp_Object result
, tem
, tem1
;
917 if (start
< GPT
&& GPT
< end
)
920 result
= make_uninit_string (end
- start
);
921 bcopy (&FETCH_CHAR (start
), XSTRING (result
)->data
, end
- start
);
923 tem
= Fnext_property_change (make_number (start
), Qnil
, make_number (end
));
924 tem1
= Ftext_properties_at (make_number (start
), Qnil
);
926 #ifdef USE_TEXT_PROPERTIES
927 if (XINT (tem
) != end
|| !NILP (tem1
))
928 copy_intervals_to_string (result
, current_buffer
, start
, end
- start
);
934 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
935 "Return the contents of part of the current buffer as a string.\n\
936 The two arguments START and END are character positions;\n\
937 they can be in either order.")
941 register int beg
, end
;
943 validate_region (&b
, &e
);
947 return make_buffer_string (beg
, end
);
950 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
951 "Return the contents of the current buffer as a string.")
954 return make_buffer_string (BEGV
, ZV
);
957 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
959 "Insert before point a substring of the contents of buffer BUFFER.\n\
960 BUFFER may be a buffer or a buffer name.\n\
961 Arguments START and END are character numbers specifying the substring.\n\
962 They default to the beginning and the end of BUFFER.")
964 Lisp_Object buf
, b
, e
;
966 register int beg
, end
, temp
, len
, opoint
, start
;
967 register struct buffer
*bp
;
970 buffer
= Fget_buffer (buf
);
973 bp
= XBUFFER (buffer
);
979 CHECK_NUMBER_COERCE_MARKER (b
, 0);
986 CHECK_NUMBER_COERCE_MARKER (e
, 1);
991 temp
= beg
, beg
= end
, end
= temp
;
993 /* Move the gap or create enough gap in the current buffer. */
997 if (GAP_SIZE
< end
- beg
)
998 make_gap (end
- beg
- GAP_SIZE
);
1004 if (!(BUF_BEGV (bp
) <= beg
1006 && end
<= BUF_ZV (bp
)))
1007 args_out_of_range (b
, e
);
1009 /* Now the actual insertion will not do any gap motion,
1010 so it matters not if BUF is the current buffer. */
1011 if (beg
< BUF_GPT (bp
))
1013 insert (BUF_CHAR_ADDRESS (bp
, beg
), min (end
, BUF_GPT (bp
)) - beg
);
1014 beg
= min (end
, BUF_GPT (bp
));
1017 insert (BUF_CHAR_ADDRESS (bp
, beg
), end
- beg
);
1019 /* Only defined if Emacs is compiled with USE_TEXT_PROPERTIES */
1020 graft_intervals_into_buffer (copy_intervals (bp
->intervals
, start
, len
),
1021 opoint
, len
, current_buffer
, 0);
1026 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
1028 "Compare two substrings of two buffers; return result as number.\n\
1029 the value is -N if first string is less after N-1 chars,\n\
1030 +N if first string is greater after N-1 chars, or 0 if strings match.\n\
1031 Each substring is represented as three arguments: BUFFER, START and END.\n\
1032 That makes six args in all, three for each substring.\n\n\
1033 The value of `case-fold-search' in the current buffer\n\
1034 determines whether case is significant or ignored.")
1035 (buffer1
, start1
, end1
, buffer2
, start2
, end2
)
1036 Lisp_Object buffer1
, start1
, end1
, buffer2
, start2
, end2
;
1038 register int begp1
, endp1
, begp2
, endp2
, temp
, len1
, len2
, length
, i
;
1039 register struct buffer
*bp1
, *bp2
;
1040 register unsigned char *trt
1041 = (!NILP (current_buffer
->case_fold_search
)
1042 ? XSTRING (current_buffer
->case_canon_table
)->data
: 0);
1044 /* Find the first buffer and its substring. */
1047 bp1
= current_buffer
;
1051 buf1
= Fget_buffer (buffer1
);
1054 bp1
= XBUFFER (buf1
);
1058 begp1
= BUF_BEGV (bp1
);
1061 CHECK_NUMBER_COERCE_MARKER (start1
, 1);
1062 begp1
= XINT (start1
);
1065 endp1
= BUF_ZV (bp1
);
1068 CHECK_NUMBER_COERCE_MARKER (end1
, 2);
1069 endp1
= XINT (end1
);
1073 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
1075 if (!(BUF_BEGV (bp1
) <= begp1
1077 && endp1
<= BUF_ZV (bp1
)))
1078 args_out_of_range (start1
, end1
);
1080 /* Likewise for second substring. */
1083 bp2
= current_buffer
;
1087 buf2
= Fget_buffer (buffer2
);
1090 bp2
= XBUFFER (buffer2
);
1094 begp2
= BUF_BEGV (bp2
);
1097 CHECK_NUMBER_COERCE_MARKER (start2
, 4);
1098 begp2
= XINT (start2
);
1101 endp2
= BUF_ZV (bp2
);
1104 CHECK_NUMBER_COERCE_MARKER (end2
, 5);
1105 endp2
= XINT (end2
);
1109 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
1111 if (!(BUF_BEGV (bp2
) <= begp2
1113 && endp2
<= BUF_ZV (bp2
)))
1114 args_out_of_range (start2
, end2
);
1116 len1
= endp1
- begp1
;
1117 len2
= endp2
- begp2
;
1122 for (i
= 0; i
< length
; i
++)
1124 int c1
= *BUF_CHAR_ADDRESS (bp1
, begp1
+ i
);
1125 int c2
= *BUF_CHAR_ADDRESS (bp2
, begp2
+ i
);
1132 return make_number (- 1 - i
);
1134 return make_number (i
+ 1);
1137 /* The strings match as far as they go.
1138 If one is shorter, that one is less. */
1140 return make_number (length
+ 1);
1141 else if (length
< len2
)
1142 return make_number (- length
- 1);
1144 /* Same length too => they are equal. */
1145 return make_number (0);
1148 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
1149 Ssubst_char_in_region
, 4, 5, 0,
1150 "From START to END, replace FROMCHAR with TOCHAR each time it occurs.\n\
1151 If optional arg NOUNDO is non-nil, don't record this change for undo\n\
1152 and don't mark the buffer as really changed.")
1153 (start
, end
, fromchar
, tochar
, noundo
)
1154 Lisp_Object start
, end
, fromchar
, tochar
, noundo
;
1156 register int pos
, stop
, look
;
1159 validate_region (&start
, &end
);
1160 CHECK_NUMBER (fromchar
, 2);
1161 CHECK_NUMBER (tochar
, 3);
1165 look
= XINT (fromchar
);
1169 if (FETCH_CHAR (pos
) == look
)
1173 modify_region (current_buffer
, XINT (start
), stop
);
1175 if (! NILP (noundo
))
1177 if (MODIFF
- 1 == current_buffer
->save_modified
)
1178 current_buffer
->save_modified
++;
1179 if (MODIFF
- 1 == current_buffer
->auto_save_modified
)
1180 current_buffer
->auto_save_modified
++;
1187 record_change (pos
, 1);
1188 FETCH_CHAR (pos
) = XINT (tochar
);
1194 signal_after_change (XINT (start
),
1195 stop
- XINT (start
), stop
- XINT (start
));
1200 DEFUN ("translate-region", Ftranslate_region
, Stranslate_region
, 3, 3, 0,
1201 "From START to END, translate characters according to TABLE.\n\
1202 TABLE is a string; the Nth character in it is the mapping\n\
1203 for the character with code N. Returns the number of characters changed.")
1207 register Lisp_Object table
;
1209 register int pos
, stop
; /* Limits of the region. */
1210 register unsigned char *tt
; /* Trans table. */
1211 register int oc
; /* Old character. */
1212 register int nc
; /* New character. */
1213 int cnt
; /* Number of changes made. */
1214 Lisp_Object z
; /* Return. */
1215 int size
; /* Size of translate table. */
1217 validate_region (&start
, &end
);
1218 CHECK_STRING (table
, 2);
1220 size
= XSTRING (table
)->size
;
1221 tt
= XSTRING (table
)->data
;
1225 modify_region (current_buffer
, pos
, stop
);
1228 for (; pos
< stop
; ++pos
)
1230 oc
= FETCH_CHAR (pos
);
1236 record_change (pos
, 1);
1237 FETCH_CHAR (pos
) = nc
;
1238 signal_after_change (pos
, 1, 1);
1248 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
1249 "Delete the text between point and mark.\n\
1250 When called from a program, expects two arguments,\n\
1251 positions (integers or markers) specifying the stretch to be deleted.")
1255 validate_region (&b
, &e
);
1256 del_range (XINT (b
), XINT (e
));
1260 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
1261 "Remove restrictions (narrowing) from current buffer.\n\
1262 This allows the buffer's full text to be seen and edited.")
1266 SET_BUF_ZV (current_buffer
, Z
);
1268 /* Changing the buffer bounds invalidates any recorded current column. */
1269 invalidate_current_column ();
1273 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
1274 "Restrict editing in this buffer to the current region.\n\
1275 The rest of the text becomes temporarily invisible and untouchable\n\
1276 but is not deleted; if you save the buffer in a file, the invisible\n\
1277 text is included in the file. \\[widen] makes all visible again.\n\
1278 See also `save-restriction'.\n\
1280 When calling from a program, pass two arguments; positions (integers\n\
1281 or markers) bounding the text that should remain visible.")
1283 register Lisp_Object b
, e
;
1285 register EMACS_INT i
;
1287 CHECK_NUMBER_COERCE_MARKER (b
, 0);
1288 CHECK_NUMBER_COERCE_MARKER (e
, 1);
1290 if (XINT (b
) > XINT (e
))
1297 if (!(BEG
<= XINT (b
) && XINT (b
) <= XINT (e
) && XINT (e
) <= Z
))
1298 args_out_of_range (b
, e
);
1300 BEGV
= XFASTINT (b
);
1301 SET_BUF_ZV (current_buffer
, XFASTINT (e
));
1302 if (point
< XFASTINT (b
))
1303 SET_PT (XFASTINT (b
));
1304 if (point
> XFASTINT (e
))
1305 SET_PT (XFASTINT (e
));
1307 /* Changing the buffer bounds invalidates any recorded current column. */
1308 invalidate_current_column ();
1313 save_restriction_save ()
1315 register Lisp_Object bottom
, top
;
1316 /* Note: I tried using markers here, but it does not win
1317 because insertion at the end of the saved region
1318 does not advance mh and is considered "outside" the saved region. */
1319 XFASTINT (bottom
) = BEGV
- BEG
;
1320 XFASTINT (top
) = Z
- ZV
;
1322 return Fcons (Fcurrent_buffer (), Fcons (bottom
, top
));
1326 save_restriction_restore (data
)
1329 register struct buffer
*buf
;
1330 register int newhead
, newtail
;
1331 register Lisp_Object tem
;
1333 buf
= XBUFFER (XCONS (data
)->car
);
1335 data
= XCONS (data
)->cdr
;
1337 tem
= XCONS (data
)->car
;
1338 newhead
= XINT (tem
);
1339 tem
= XCONS (data
)->cdr
;
1340 newtail
= XINT (tem
);
1341 if (newhead
+ newtail
> BUF_Z (buf
) - BUF_BEG (buf
))
1346 BUF_BEGV (buf
) = BUF_BEG (buf
) + newhead
;
1347 SET_BUF_ZV (buf
, BUF_Z (buf
) - newtail
);
1350 /* If point is outside the new visible range, move it inside. */
1352 clip_to_bounds (BUF_BEGV (buf
), BUF_PT (buf
), BUF_ZV (buf
)));
1357 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
1358 "Execute BODY, saving and restoring current buffer's restrictions.\n\
1359 The buffer's restrictions make parts of the beginning and end invisible.\n\
1360 \(They are set up with `narrow-to-region' and eliminated with `widen'.)\n\
1361 This special form, `save-restriction', saves the current buffer's restrictions\n\
1362 when it is entered, and restores them when it is exited.\n\
1363 So any `narrow-to-region' within BODY lasts only until the end of the form.\n\
1364 The old restrictions settings are restored\n\
1365 even in case of abnormal exit (throw or error).\n\
1367 The value returned is the value of the last form in BODY.\n\
1369 `save-restriction' can get confused if, within the BODY, you widen\n\
1370 and then make changes outside the area within the saved restrictions.\n\
1372 Note: if you are using both `save-excursion' and `save-restriction',\n\
1373 use `save-excursion' outermost:\n\
1374 (save-excursion (save-restriction ...))")
1378 register Lisp_Object val
;
1379 int count
= specpdl_ptr
- specpdl
;
1381 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
1382 val
= Fprogn (body
);
1383 return unbind_to (count
, val
);
1386 /* Buffer for the most recent text displayed by Fmessage. */
1387 static char *message_text
;
1389 /* Allocated length of that buffer. */
1390 static int message_length
;
1392 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
1393 "Print a one-line message at the bottom of the screen.\n\
1394 The first argument is a control string.\n\
1395 It may contain %s or %d or %c to print successive following arguments.\n\
1396 %s means print an argument as a string, %d means print as number in decimal,\n\
1397 %c means print a number as a single character.\n\
1398 The argument used by %s must be a string or a symbol;\n\
1399 the argument used by %d or %c must be a number.\n\
1400 If the first argument is nil, clear any existing message; let the\n\
1401 minibuffer contents show.")
1413 register Lisp_Object val
;
1414 val
= Fformat (nargs
, args
);
1415 /* Copy the data so that it won't move when we GC. */
1418 message_text
= (char *)xmalloc (80);
1419 message_length
= 80;
1421 if (XSTRING (val
)->size
> message_length
)
1423 message_length
= XSTRING (val
)->size
;
1424 message_text
= (char *)xrealloc (message_text
, message_length
);
1426 bcopy (XSTRING (val
)->data
, message_text
, XSTRING (val
)->size
);
1427 message2 (message_text
, XSTRING (val
)->size
);
1432 DEFUN ("message-box", Fmessage_box
, Smessage_box
, 1, MANY
, 0,
1433 "Display a message, in a dialog box if possible.\n\
1434 If a dialog box is not available, use the echo area.\n\
1435 The first argument is a control string.\n\
1436 It may contain %s or %d or %c to print successive following arguments.\n\
1437 %s means print an argument as a string, %d means print as number in decimal,\n\
1438 %c means print a number as a single character.\n\
1439 The argument used by %s must be a string or a symbol;\n\
1440 the argument used by %d or %c must be a number.\n\
1441 If the first argument is nil, clear any existing message; let the\n\
1442 minibuffer contents show.")
1454 register Lisp_Object val
;
1455 val
= Fformat (nargs
, args
);
1458 Lisp_Object pane
, menu
, obj
;
1459 struct gcpro gcpro1
;
1460 pane
= Fcons (Fcons (build_string ("OK"), Qt
), Qnil
);
1462 menu
= Fcons (val
, pane
);
1463 obj
= Fx_popup_dialog (Qt
, menu
);
1468 /* Copy the data so that it won't move when we GC. */
1471 message_text
= (char *)xmalloc (80);
1472 message_length
= 80;
1474 if (XSTRING (val
)->size
> message_length
)
1476 message_length
= XSTRING (val
)->size
;
1477 message_text
= (char *)xrealloc (message_text
, message_length
);
1479 bcopy (XSTRING (val
)->data
, message_text
, XSTRING (val
)->size
);
1480 message2 (message_text
, XSTRING (val
)->size
);
1486 extern Lisp_Object last_nonmenu_event
;
1488 DEFUN ("message-or-box", Fmessage_or_box
, Smessage_or_box
, 1, MANY
, 0,
1489 "Display a message in a dialog box or in the echo area.\n\
1490 If this command was invoked with the mouse, use a dialog box.\n\
1491 Otherwise, use the echo area.\n\
1493 The first argument is a control string.\n\
1494 It may contain %s or %d or %c to print successive following arguments.\n\
1495 %s means print an argument as a string, %d means print as number in decimal,\n\
1496 %c means print a number as a single character.\n\
1497 The argument used by %s must be a string or a symbol;\n\
1498 the argument used by %d or %c must be a number.\n\
1499 If the first argument is nil, clear any existing message; let the\n\
1500 minibuffer contents show.")
1506 if (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
1507 return Fmessage_box (nargs
, args
);
1509 return Fmessage (nargs
, args
);
1512 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
1513 "Format a string out of a control-string and arguments.\n\
1514 The first argument is a control string.\n\
1515 The other arguments are substituted into it to make the result, a string.\n\
1516 It may contain %-sequences meaning to substitute the next argument.\n\
1517 %s means print a string argument. Actually, prints any object, with `princ'.\n\
1518 %d means print as number in decimal (%o octal, %x hex).\n\
1519 %c means print a number as a single character.\n\
1520 %S means print any object as an s-expression (using prin1).\n\
1521 The argument used for %d, %o, %x or %c must be a number.\n\
1522 Use %% to put a single % into the output.")
1525 register Lisp_Object
*args
;
1527 register int n
; /* The number of the next arg to substitute */
1528 register int total
= 5; /* An estimate of the final length */
1530 register unsigned char *format
, *end
;
1532 extern char *index ();
1533 /* It should not be necessary to GCPRO ARGS, because
1534 the caller in the interpreter should take care of that. */
1536 CHECK_STRING (args
[0], 0);
1537 format
= XSTRING (args
[0])->data
;
1538 end
= format
+ XSTRING (args
[0])->size
;
1541 while (format
!= end
)
1542 if (*format
++ == '%')
1546 /* Process a numeric arg and skip it. */
1547 minlen
= atoi (format
);
1552 while ((*format
>= '0' && *format
<= '9')
1553 || *format
== '-' || *format
== ' ' || *format
== '.')
1558 else if (++n
>= nargs
)
1559 error ("not enough arguments for format string");
1560 else if (*format
== 'S')
1562 /* For `S', prin1 the argument and then treat like a string. */
1563 register Lisp_Object tem
;
1564 tem
= Fprin1_to_string (args
[n
], Qnil
);
1568 else if (XTYPE (args
[n
]) == Lisp_Symbol
)
1570 XSET (args
[n
], Lisp_String
, XSYMBOL (args
[n
])->name
);
1573 else if (XTYPE (args
[n
]) == Lisp_String
)
1576 if (*format
!= 's' && *format
!= 'S')
1577 error ("format specifier doesn't match argument type");
1578 total
+= XSTRING (args
[n
])->size
;
1580 /* Would get MPV otherwise, since Lisp_Int's `point' to low memory. */
1581 else if (XTYPE (args
[n
]) == Lisp_Int
&& *format
!= 's')
1583 #ifdef LISP_FLOAT_TYPE
1584 /* The following loop assumes the Lisp type indicates
1585 the proper way to pass the argument.
1586 So make sure we have a flonum if the argument should
1588 if (*format
== 'e' || *format
== 'f' || *format
== 'g')
1589 args
[n
] = Ffloat (args
[n
]);
1593 #ifdef LISP_FLOAT_TYPE
1594 else if (XTYPE (args
[n
]) == Lisp_Float
&& *format
!= 's')
1596 if (! (*format
== 'e' || *format
== 'f' || *format
== 'g'))
1597 args
[n
] = Ftruncate (args
[n
]);
1603 /* Anything but a string, convert to a string using princ. */
1604 register Lisp_Object tem
;
1605 tem
= Fprin1_to_string (args
[n
], Qt
);
1612 register int nstrings
= n
+ 1;
1614 /* Allocate twice as many strings as we have %-escapes; floats occupy
1615 two slots, and we're not sure how many of those we have. */
1616 register unsigned char **strings
1617 = (unsigned char **) alloca (2 * nstrings
* sizeof (unsigned char *));
1621 for (n
= 0; n
< nstrings
; n
++)
1624 strings
[i
++] = (unsigned char *) "";
1625 else if (XTYPE (args
[n
]) == Lisp_Int
)
1626 /* We checked above that the corresponding format effector
1627 isn't %s, which would cause MPV. */
1628 strings
[i
++] = (unsigned char *) XINT (args
[n
]);
1629 #ifdef LISP_FLOAT_TYPE
1630 else if (XTYPE (args
[n
]) == Lisp_Float
)
1632 union { double d
; int half
[2]; } u
;
1634 u
.d
= XFLOAT (args
[n
])->data
;
1635 strings
[i
++] = (unsigned char *) u
.half
[0];
1636 strings
[i
++] = (unsigned char *) u
.half
[1];
1640 strings
[i
++] = XSTRING (args
[n
])->data
;
1643 /* Format it in bigger and bigger buf's until it all fits. */
1646 buf
= (char *) alloca (total
+ 1);
1649 length
= doprnt (buf
, total
+ 1, strings
[0], end
, i
-1, strings
+ 1);
1650 if (buf
[total
- 1] == 0)
1658 return make_string (buf
, length
);
1664 format1 (string1
, arg0
, arg1
, arg2
, arg3
, arg4
)
1665 EMACS_INT arg0
, arg1
, arg2
, arg3
, arg4
;
1679 doprnt (buf
, sizeof buf
, string1
, 0, 5, args
);
1681 doprnt (buf
, sizeof buf
, string1
, 0, 5, &string1
+ 1);
1683 return build_string (buf
);
1686 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
1687 "Return t if two characters match, optionally ignoring case.\n\
1688 Both arguments must be characters (i.e. integers).\n\
1689 Case is ignored if `case-fold-search' is non-nil in the current buffer.")
1691 register Lisp_Object c1
, c2
;
1693 unsigned char *downcase
= DOWNCASE_TABLE
;
1694 CHECK_NUMBER (c1
, 0);
1695 CHECK_NUMBER (c2
, 1);
1697 if (!NILP (current_buffer
->case_fold_search
)
1698 ? (downcase
[0xff & XFASTINT (c1
)] == downcase
[0xff & XFASTINT (c2
)]
1699 && (XFASTINT (c1
) & ~0xff) == (XFASTINT (c2
) & ~0xff))
1700 : XINT (c1
) == XINT (c2
))
1705 /* Transpose the markers in two regions of the current buffer, and
1706 adjust the ones between them if necessary (i.e.: if the regions
1709 Traverses the entire marker list of the buffer to do so, adding an
1710 appropriate amount to some, subtracting from some, and leaving the
1711 rest untouched. Most of this is copied from adjust_markers in insdel.c.
1713 It's the caller's job to see that (start1 <= end1 <= start2 <= end2). */
1716 transpose_markers (start1
, end1
, start2
, end2
)
1717 register int start1
, end1
, start2
, end2
;
1719 register int amt1
, amt2
, diff
, mpos
;
1720 register Lisp_Object marker
;
1722 /* Update point as if it were a marker. */
1726 TEMP_SET_PT (PT
+ (end2
- end1
));
1727 else if (PT
< start2
)
1728 TEMP_SET_PT (PT
+ (end2
- start2
) - (end1
- start1
));
1730 TEMP_SET_PT (PT
- (start2
- start1
));
1732 /* We used to adjust the endpoints here to account for the gap, but that
1733 isn't good enough. Even if we assume the caller has tried to move the
1734 gap out of our way, it might still be at start1 exactly, for example;
1735 and that places it `inside' the interval, for our purposes. The amount
1736 of adjustment is nontrivial if there's a `denormalized' marker whose
1737 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
1738 the dirty work to Fmarker_position, below. */
1740 /* The difference between the region's lengths */
1741 diff
= (end2
- start2
) - (end1
- start1
);
1743 /* For shifting each marker in a region by the length of the other
1744 * region plus the distance between the regions.
1746 amt1
= (end2
- start2
) + (start2
- end1
);
1747 amt2
= (end1
- start1
) + (start2
- end1
);
1749 for (marker
= current_buffer
->markers
; !NILP (marker
);
1750 marker
= XMARKER (marker
)->chain
)
1752 mpos
= Fmarker_position (marker
);
1753 if (mpos
>= start1
&& mpos
< end2
)
1757 else if (mpos
< start2
)
1761 if (mpos
> GPT
) mpos
+= GAP_SIZE
;
1762 XMARKER (marker
)->bufpos
= mpos
;
1767 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
1768 "Transpose region START1 to END1 with START2 to END2.\n\
1769 The regions may not be overlapping, because the size of the buffer is\n\
1770 never changed in a transposition.\n\
1772 Optional fifth arg LEAVE_MARKERS, if non-nil, means don't transpose\n\
1773 any markers that happen to be located in the regions.\n\
1775 Transposing beyond buffer boundaries is an error.")
1776 (startr1
, endr1
, startr2
, endr2
, leave_markers
)
1777 Lisp_Object startr1
, endr1
, startr2
, endr2
, leave_markers
;
1779 register int start1
, end1
, start2
, end2
,
1780 gap
, len1
, len_mid
, len2
;
1781 unsigned char *start1_addr
, *start2_addr
, *temp
;
1783 #ifdef USE_TEXT_PROPERTIES
1784 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
;
1785 cur_intv
= current_buffer
->intervals
;
1786 #endif /* USE_TEXT_PROPERTIES */
1788 validate_region (&startr1
, &endr1
);
1789 validate_region (&startr2
, &endr2
);
1791 start1
= XFASTINT (startr1
);
1792 end1
= XFASTINT (endr1
);
1793 start2
= XFASTINT (startr2
);
1794 end2
= XFASTINT (endr2
);
1797 /* Swap the regions if they're reversed. */
1800 register int glumph
= start1
;
1808 len1
= end1
- start1
;
1809 len2
= end2
- start2
;
1812 error ("transposed regions not properly ordered");
1813 else if (start1
== end1
|| start2
== end2
)
1814 error ("transposed region may not be of length 0");
1816 /* The possibilities are:
1817 1. Adjacent (contiguous) regions, or separate but equal regions
1818 (no, really equal, in this case!), or
1819 2. Separate regions of unequal size.
1821 The worst case is usually No. 2. It means that (aside from
1822 potential need for getting the gap out of the way), there also
1823 needs to be a shifting of the text between the two regions. So
1824 if they are spread far apart, we are that much slower... sigh. */
1826 /* It must be pointed out that the really studly thing to do would
1827 be not to move the gap at all, but to leave it in place and work
1828 around it if necessary. This would be extremely efficient,
1829 especially considering that people are likely to do
1830 transpositions near where they are working interactively, which
1831 is exactly where the gap would be found. However, such code
1832 would be much harder to write and to read. So, if you are
1833 reading this comment and are feeling squirrely, by all means have
1834 a go! I just didn't feel like doing it, so I will simply move
1835 the gap the minimum distance to get it out of the way, and then
1836 deal with an unbroken array. */
1838 /* Make sure the gap won't interfere, by moving it out of the text
1839 we will operate on. */
1840 if (start1
< gap
&& gap
< end2
)
1842 if (gap
- start1
< end2
- gap
)
1848 /* Hmmm... how about checking to see if the gap is large
1849 enough to use as the temporary storage? That would avoid an
1850 allocation... interesting. Later, don't fool with it now. */
1852 /* Working without memmove, for portability (sigh), so must be
1853 careful of overlapping subsections of the array... */
1855 if (end1
== start2
) /* adjacent regions */
1857 modify_region (current_buffer
, start1
, end2
);
1858 record_change (start1
, len1
+ len2
);
1860 #ifdef USE_TEXT_PROPERTIES
1861 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
1862 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
1863 Fset_text_properties (start1
, end2
, Qnil
, Qnil
);
1864 #endif /* USE_TEXT_PROPERTIES */
1866 /* First region smaller than second. */
1869 /* We use alloca only if it is small,
1870 because we want to avoid stack overflow. */
1872 temp
= (unsigned char *) xmalloc (len2
);
1874 temp
= (unsigned char *) alloca (len2
);
1876 /* Don't precompute these addresses. We have to compute them
1877 at the last minute, because the relocating allocator might
1878 have moved the buffer around during the xmalloc. */
1879 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1
);
1880 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2
);
1882 bcopy (start2_addr
, temp
, len2
);
1883 bcopy (start1_addr
, start1_addr
+ len2
, len1
);
1884 bcopy (temp
, start1_addr
, len2
);
1889 /* First region not smaller than second. */
1892 temp
= (unsigned char *) xmalloc (len1
);
1894 temp
= (unsigned char *) alloca (len1
);
1895 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1
);
1896 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2
);
1897 bcopy (start1_addr
, temp
, len1
);
1898 bcopy (start2_addr
, start1_addr
, len2
);
1899 bcopy (temp
, start1_addr
+ len2
, len1
);
1903 #ifdef USE_TEXT_PROPERTIES
1904 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
1905 len1
, current_buffer
, 0);
1906 graft_intervals_into_buffer (tmp_interval2
, start1
,
1907 len2
, current_buffer
, 0);
1908 #endif /* USE_TEXT_PROPERTIES */
1910 /* Non-adjacent regions, because end1 != start2, bleagh... */
1914 /* Regions are same size, though, how nice. */
1916 modify_region (current_buffer
, start1
, end1
);
1917 modify_region (current_buffer
, start2
, end2
);
1918 record_change (start1
, len1
);
1919 record_change (start2
, len2
);
1920 #ifdef USE_TEXT_PROPERTIES
1921 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
1922 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
1923 Fset_text_properties (start1
, end1
, Qnil
, Qnil
);
1924 Fset_text_properties (start2
, end2
, Qnil
, Qnil
);
1925 #endif /* USE_TEXT_PROPERTIES */
1928 temp
= (unsigned char *) xmalloc (len1
);
1930 temp
= (unsigned char *) alloca (len1
);
1931 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1
);
1932 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2
);
1933 bcopy (start1_addr
, temp
, len1
);
1934 bcopy (start2_addr
, start1_addr
, len2
);
1935 bcopy (temp
, start2_addr
, len1
);
1938 #ifdef USE_TEXT_PROPERTIES
1939 graft_intervals_into_buffer (tmp_interval1
, start2
,
1940 len1
, current_buffer
, 0);
1941 graft_intervals_into_buffer (tmp_interval2
, start1
,
1942 len2
, current_buffer
, 0);
1943 #endif /* USE_TEXT_PROPERTIES */
1946 else if (len1
< len2
) /* Second region larger than first */
1947 /* Non-adjacent & unequal size, area between must also be shifted. */
1949 len_mid
= start2
- end1
;
1950 modify_region (current_buffer
, start1
, end2
);
1951 record_change (start1
, (end2
- start1
));
1952 #ifdef USE_TEXT_PROPERTIES
1953 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
1954 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
1955 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
1956 Fset_text_properties (start1
, end2
, Qnil
, Qnil
);
1957 #endif /* USE_TEXT_PROPERTIES */
1959 /* holds region 2 */
1961 temp
= (unsigned char *) xmalloc (len2
);
1963 temp
= (unsigned char *) alloca (len2
);
1964 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1
);
1965 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2
);
1966 bcopy (start2_addr
, temp
, len2
);
1967 bcopy (start1_addr
, start1_addr
+ len_mid
+ len2
, len1
);
1968 safe_bcopy (start1_addr
+ len1
, start1_addr
+ len2
, len_mid
);
1969 bcopy (temp
, start1_addr
, len2
);
1972 #ifdef USE_TEXT_PROPERTIES
1973 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
1974 len1
, current_buffer
, 0);
1975 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
1976 len_mid
, current_buffer
, 0);
1977 graft_intervals_into_buffer (tmp_interval2
, start1
,
1978 len2
, current_buffer
, 0);
1979 #endif /* USE_TEXT_PROPERTIES */
1982 /* Second region smaller than first. */
1984 len_mid
= start2
- end1
;
1985 record_change (start1
, (end2
- start1
));
1986 modify_region (current_buffer
, start1
, end2
);
1988 #ifdef USE_TEXT_PROPERTIES
1989 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
1990 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
1991 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
1992 Fset_text_properties (start1
, end2
, Qnil
, Qnil
);
1993 #endif /* USE_TEXT_PROPERTIES */
1995 /* holds region 1 */
1997 temp
= (unsigned char *) xmalloc (len1
);
1999 temp
= (unsigned char *) alloca (len1
);
2000 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1
);
2001 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2
);
2002 bcopy (start1_addr
, temp
, len1
);
2003 bcopy (start2_addr
, start1_addr
, len2
);
2004 bcopy (start1_addr
+ len1
, start1_addr
+ len2
, len_mid
);
2005 bcopy (temp
, start1_addr
+ len2
+ len_mid
, len1
);
2008 #ifdef USE_TEXT_PROPERTIES
2009 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
2010 len1
, current_buffer
, 0);
2011 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
2012 len_mid
, current_buffer
, 0);
2013 graft_intervals_into_buffer (tmp_interval2
, start1
,
2014 len2
, current_buffer
, 0);
2015 #endif /* USE_TEXT_PROPERTIES */
2019 /* todo: this will be slow, because for every transposition, we
2020 traverse the whole friggin marker list. Possible solutions:
2021 somehow get a list of *all* the markers across multiple
2022 transpositions and do it all in one swell phoop. Or maybe modify
2023 Emacs' marker code to keep an ordered list or tree. This might
2024 be nicer, and more beneficial in the long run, but would be a
2025 bunch of work. Plus the way they're arranged now is nice. */
2026 if (NILP (leave_markers
))
2028 transpose_markers (start1
, end1
, start2
, end2
);
2029 fix_overlays_in_range (start1
, end2
);
2039 DEFVAR_LISP ("system-name", &Vsystem_name
,
2040 "The name of the machine Emacs is running on.");
2042 DEFVAR_LISP ("user-full-name", &Vuser_full_name
,
2043 "The full name of the user logged in.");
2045 DEFVAR_LISP ("user-name", &Vuser_name
,
2046 "The user's name, taken from environment variables if possible.");
2048 DEFVAR_LISP ("user-real-name", &Vuser_real_name
,
2049 "The user's name, based upon the real uid only.");
2051 defsubr (&Schar_equal
);
2052 defsubr (&Sgoto_char
);
2053 defsubr (&Sstring_to_char
);
2054 defsubr (&Schar_to_string
);
2055 defsubr (&Sbuffer_substring
);
2056 defsubr (&Sbuffer_string
);
2058 defsubr (&Spoint_marker
);
2059 defsubr (&Smark_marker
);
2061 defsubr (&Sregion_beginning
);
2062 defsubr (&Sregion_end
);
2063 /* defsubr (&Smark); */
2064 /* defsubr (&Sset_mark); */
2065 defsubr (&Ssave_excursion
);
2067 defsubr (&Sbufsize
);
2068 defsubr (&Spoint_max
);
2069 defsubr (&Spoint_min
);
2070 defsubr (&Spoint_min_marker
);
2071 defsubr (&Spoint_max_marker
);
2077 defsubr (&Sfollowing_char
);
2078 defsubr (&Sprevious_char
);
2079 defsubr (&Schar_after
);
2081 defsubr (&Sinsert_before_markers
);
2082 defsubr (&Sinsert_and_inherit
);
2083 defsubr (&Sinsert_and_inherit_before_markers
);
2084 defsubr (&Sinsert_char
);
2086 defsubr (&Suser_login_name
);
2087 defsubr (&Suser_real_login_name
);
2088 defsubr (&Suser_uid
);
2089 defsubr (&Suser_real_uid
);
2090 defsubr (&Suser_full_name
);
2091 defsubr (&Semacs_pid
);
2092 defsubr (&Scurrent_time
);
2093 defsubr (&Scurrent_time_string
);
2094 defsubr (&Scurrent_time_zone
);
2095 defsubr (&Ssystem_name
);
2096 defsubr (&Smessage
);
2097 defsubr (&Smessage_box
);
2098 defsubr (&Smessage_or_box
);
2101 defsubr (&Sinsert_buffer_substring
);
2102 defsubr (&Scompare_buffer_substrings
);
2103 defsubr (&Ssubst_char_in_region
);
2104 defsubr (&Stranslate_region
);
2105 defsubr (&Sdelete_region
);
2107 defsubr (&Snarrow_to_region
);
2108 defsubr (&Ssave_restriction
);
2109 defsubr (&Stranspose_regions
);