1 /* Lisp functions pertaining to editing.
2 Copyright (C) 1985, 1986, 1987, 1989, 1993 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 USER or LOGNAME. */
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. */
59 Vsystem_name
= build_string (get_system_name ());
60 p
= XSTRING (Vsystem_name
)->data
;
63 if (*p
== ' ' || *p
== '\t')
69 /* Don't bother with this on initial start when just dumping out */
72 #endif /* not CANNOT_DUMP */
74 pw
= (struct passwd
*) getpwuid (getuid ());
75 Vuser_real_name
= build_string (pw
? pw
->pw_name
: "unknown");
77 /* Get the effective user name, by consulting environment variables,
78 or the effective uid if those are unset. */
79 user_name
= (char *) getenv ("USER");
81 user_name
= (char *) getenv ("LOGNAME");
84 pw
= (struct passwd
*) getpwuid (geteuid ());
85 user_name
= (char *) (pw
? pw
->pw_name
: "unknown");
87 Vuser_name
= build_string (user_name
);
89 /* If the user name claimed in the environment vars differs from
90 the real uid, use the claimed name to find the full name. */
91 tem
= Fstring_equal (Vuser_name
, Vuser_real_name
);
93 pw
= (struct passwd
*) getpwnam (XSTRING (Vuser_name
)->data
);
95 p
= (unsigned char *) (pw
? USER_FULL_NAME
: "unknown");
96 q
= (unsigned char *) index (p
, ',');
97 Vuser_full_name
= make_string (p
, q
? q
- p
: strlen (p
));
99 #ifdef AMPERSAND_FULL_NAME
100 p
= XSTRING (Vuser_full_name
)->data
;
101 q
= (char *) index (p
, '&');
102 /* Substitute the login name for the &, upcasing the first character. */
105 r
= (char *) alloca (strlen (p
) + XSTRING (Vuser_name
)->size
+ 1);
108 strcat (r
, XSTRING (Vuser_name
)->data
);
109 r
[q
- p
] = UPCASE (r
[q
- p
]);
111 Vuser_full_name
= build_string (r
);
113 #endif /* AMPERSAND_FULL_NAME */
116 DEFUN ("char-to-string", Fchar_to_string
, Schar_to_string
, 1, 1, 0,
117 "Convert arg CHAR to a one-character string containing that character.")
125 return make_string (&c
, 1);
128 DEFUN ("string-to-char", Fstring_to_char
, Sstring_to_char
, 1, 1, 0,
129 "Convert arg STRING to a character, the first character of that string.")
131 register Lisp_Object str
;
133 register Lisp_Object val
;
134 register struct Lisp_String
*p
;
135 CHECK_STRING (str
, 0);
139 XFASTINT (val
) = ((unsigned char *) p
->data
)[0];
149 register Lisp_Object mark
;
150 mark
= Fmake_marker ();
151 Fset_marker (mark
, make_number (val
), Qnil
);
155 DEFUN ("point", Fpoint
, Spoint
, 0, 0, 0,
156 "Return value of point, as an integer.\n\
157 Beginning of buffer is position (point-min)")
161 XFASTINT (temp
) = point
;
165 DEFUN ("point-marker", Fpoint_marker
, Spoint_marker
, 0, 0, 0,
166 "Return value of point, as a marker object.")
169 return buildmark (point
);
173 clip_to_bounds (lower
, num
, upper
)
174 int lower
, num
, upper
;
178 else if (num
> upper
)
184 DEFUN ("goto-char", Fgoto_char
, Sgoto_char
, 1, 1, "NGoto char: ",
185 "Set point to POSITION, a number or marker.\n\
186 Beginning of buffer is position (point-min), end is (point-max).")
188 register Lisp_Object n
;
190 CHECK_NUMBER_COERCE_MARKER (n
, 0);
192 SET_PT (clip_to_bounds (BEGV
, XINT (n
), ZV
));
197 region_limit (beginningp
)
200 register Lisp_Object m
;
201 if (!NILP (Vtransient_mark_mode
) && NILP (current_buffer
->mark_active
))
202 error ("There is no region now");
203 m
= Fmarker_position (current_buffer
->mark
);
204 if (NILP (m
)) error ("There is no region now");
205 if ((point
< XFASTINT (m
)) == beginningp
)
206 return (make_number (point
));
211 DEFUN ("region-beginning", Fregion_beginning
, Sregion_beginning
, 0, 0, 0,
212 "Return position of beginning of region, as an integer.")
215 return (region_limit (1));
218 DEFUN ("region-end", Fregion_end
, Sregion_end
, 0, 0, 0,
219 "Return position of end of region, as an integer.")
222 return (region_limit (0));
225 #if 0 /* now in lisp code */
226 DEFUN ("mark", Fmark
, Smark
, 0, 0, 0,
227 "Return this buffer's mark value as integer, or nil if no mark.\n\
228 If you are using this in an editing command, you are most likely making\n\
229 a mistake; see the documentation of `set-mark'.")
232 return Fmarker_position (current_buffer
->mark
);
234 #endif /* commented out code */
236 DEFUN ("mark-marker", Fmark_marker
, Smark_marker
, 0, 0, 0,
237 "Return this buffer's mark, as a marker object.\n\
238 Watch out! Moving this marker changes the mark position.\n\
239 If you set the marker not to point anywhere, the buffer will have no mark.")
242 return current_buffer
->mark
;
245 #if 0 /* this is now in lisp code */
246 DEFUN ("set-mark", Fset_mark
, Sset_mark
, 1, 1, 0,
247 "Set this buffer's mark to POS. Don't use this function!\n\
248 That is to say, don't use this function unless you want\n\
249 the user to see that the mark has moved, and you want the previous\n\
250 mark position to be lost.\n\
252 Normally, when a new mark is set, the old one should go on the stack.\n\
253 This is why most applications should use push-mark, not set-mark.\n\
255 Novice programmers often try to use the mark for the wrong purposes.\n\
256 The mark saves a location for the user's convenience.\n\
257 Most editing commands should not alter the mark.\n\
258 To remember a location for internal use in the Lisp program,\n\
259 store it in a Lisp variable. Example:\n\
261 (let ((beg (point))) (forward-line 1) (delete-region beg (point))).")
267 current_buffer
->mark
= Qnil
;
270 CHECK_NUMBER_COERCE_MARKER (pos
, 0);
272 if (NILP (current_buffer
->mark
))
273 current_buffer
->mark
= Fmake_marker ();
275 Fset_marker (current_buffer
->mark
, pos
, Qnil
);
278 #endif /* commented-out code */
281 save_excursion_save ()
283 register int visible
= (XBUFFER (XWINDOW (selected_window
)->buffer
)
286 return Fcons (Fpoint_marker (),
287 Fcons (Fcopy_marker (current_buffer
->mark
),
288 Fcons (visible
? Qt
: Qnil
,
289 current_buffer
->mark_active
)));
293 save_excursion_restore (info
)
294 register Lisp_Object info
;
296 register Lisp_Object tem
, tem1
;
298 tem
= Fmarker_buffer (Fcar (info
));
299 /* If buffer being returned to is now deleted, avoid error */
300 /* Otherwise could get error here while unwinding to top level
302 /* In that case, Fmarker_buffer returns nil now. */
308 unchain_marker (tem
);
309 tem
= Fcar (Fcdr (info
));
310 Fset_marker (current_buffer
->mark
, tem
, Fcurrent_buffer ());
311 unchain_marker (tem
);
312 tem
= Fcdr (Fcdr (info
));
315 && current_buffer
!= XBUFFER (XWINDOW (selected_window
)->buffer
))
316 Fswitch_to_buffer (Fcurrent_buffer (), Qnil
);
318 tem1
= current_buffer
->mark_active
;
319 current_buffer
->mark_active
= Fcdr (tem
);
320 if (! NILP (current_buffer
->mark_active
))
321 call1 (Vrun_hooks
, intern ("activate-mark-hook"));
322 else if (! NILP (tem1
))
323 call1 (Vrun_hooks
, intern ("deactivate-mark-hook"));
327 DEFUN ("save-excursion", Fsave_excursion
, Ssave_excursion
, 0, UNEVALLED
, 0,
328 "Save point, mark, and current buffer; execute BODY; restore those things.\n\
329 Executes BODY just like `progn'.\n\
330 The values of point, mark and the current buffer are restored\n\
331 even in case of abnormal exit (throw or error).\n\
332 The state of activation of the mark is also restored.")
336 register Lisp_Object val
;
337 int count
= specpdl_ptr
- specpdl
;
339 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
342 return unbind_to (count
, val
);
345 DEFUN ("buffer-size", Fbufsize
, Sbufsize
, 0, 0, 0,
346 "Return the number of characters in the current buffer.")
350 XFASTINT (temp
) = Z
- BEG
;
354 DEFUN ("point-min", Fpoint_min
, Spoint_min
, 0, 0, 0,
355 "Return the minimum permissible value of point in the current buffer.\n\
356 This is 1, unless a clipping restriction is in effect.")
360 XFASTINT (temp
) = BEGV
;
364 DEFUN ("point-min-marker", Fpoint_min_marker
, Spoint_min_marker
, 0, 0, 0,
365 "Return a marker to the minimum permissible value of point in this buffer.\n\
366 This is the beginning, unless a clipping restriction is in effect.")
369 return buildmark (BEGV
);
372 DEFUN ("point-max", Fpoint_max
, Spoint_max
, 0, 0, 0,
373 "Return the maximum permissible value of point in the current buffer.\n\
374 This is (1+ (buffer-size)), unless a clipping restriction is in effect,\n\
375 in which case it is less.")
379 XFASTINT (temp
) = ZV
;
383 DEFUN ("point-max-marker", Fpoint_max_marker
, Spoint_max_marker
, 0, 0, 0,
384 "Return a marker to the maximum permissible value of point in this buffer.\n\
385 This is (1+ (buffer-size)), unless a clipping restriction is in effect,\n\
386 in which case it is less.")
389 return buildmark (ZV
);
392 DEFUN ("following-char", Ffollowing_char
, Sfollowing_char
, 0, 0, 0,
393 "Return the character following point, as a number.\n\
394 At the end of the buffer or accessible region, return 0.")
401 XFASTINT (temp
) = FETCH_CHAR (point
);
405 DEFUN ("preceding-char", Fprevious_char
, Sprevious_char
, 0, 0, 0,
406 "Return the character preceding point, as a number.\n\
407 At the beginning of the buffer or accessible region, return 0.")
414 XFASTINT (temp
) = FETCH_CHAR (point
- 1);
418 DEFUN ("bobp", Fbobp
, Sbobp
, 0, 0, 0,
419 "Return T if point is at the beginning of the buffer.\n\
420 If the buffer is narrowed, this means the beginning of the narrowed part.")
428 DEFUN ("eobp", Feobp
, Seobp
, 0, 0, 0,
429 "Return T if point is at the end of the buffer.\n\
430 If the buffer is narrowed, this means the end of the narrowed part.")
438 DEFUN ("bolp", Fbolp
, Sbolp
, 0, 0, 0,
439 "Return T if point is at the beginning of a line.")
442 if (point
== BEGV
|| FETCH_CHAR (point
- 1) == '\n')
447 DEFUN ("eolp", Feolp
, Seolp
, 0, 0, 0,
448 "Return T if point is at the end of a line.\n\
449 `End of a line' includes point being at the end of the buffer.")
452 if (point
== ZV
|| FETCH_CHAR (point
) == '\n')
457 DEFUN ("char-after", Fchar_after
, Schar_after
, 1, 1, 0,
458 "Return character in current buffer at position POS.\n\
459 POS is an integer or a buffer pointer.\n\
460 If POS is out of range, the value is nil.")
464 register Lisp_Object val
;
467 CHECK_NUMBER_COERCE_MARKER (pos
, 0);
470 if (n
< BEGV
|| n
>= ZV
) return Qnil
;
472 XFASTINT (val
) = FETCH_CHAR (n
);
476 DEFUN ("user-login-name", Fuser_login_name
, Suser_login_name
, 0, 0, 0,
477 "Return the name under which the user logged in, as a string.\n\
478 This is based on the effective uid, not the real uid.\n\
479 Also, if the environment variable USER or LOGNAME is set,\n\
480 that determines the value of this function.")
486 DEFUN ("user-real-login-name", Fuser_real_login_name
, Suser_real_login_name
,
488 "Return the name of the user's real uid, as a string.\n\
489 Differs from `user-login-name' when running under `su'.")
492 return Vuser_real_name
;
495 DEFUN ("user-uid", Fuser_uid
, Suser_uid
, 0, 0, 0,
496 "Return the effective uid of Emacs, as an integer.")
499 return make_number (geteuid ());
502 DEFUN ("user-real-uid", Fuser_real_uid
, Suser_real_uid
, 0, 0, 0,
503 "Return the real uid of Emacs, as an integer.")
506 return make_number (getuid ());
509 DEFUN ("user-full-name", Fuser_full_name
, Suser_full_name
, 0, 0, 0,
510 "Return the full name of the user logged in, as a string.")
513 return Vuser_full_name
;
516 DEFUN ("system-name", Fsystem_name
, Ssystem_name
, 0, 0, 0,
517 "Return the name of the machine you are running on, as a string.")
523 DEFUN ("current-time", Fcurrent_time
, Scurrent_time
, 0, 0, 0,
524 "Return the current time, as the number of seconds since 12:00 AM January 1970.\n\
525 The time is returned as a list of three integers. The first has the\n\
526 most significant 16 bits of the seconds, while the second has the\n\
527 least significant 16 bits. The third integer gives the microsecond\n\
530 The microsecond count is zero on systems that do not provide\n\
531 resolution finer than a second.")
535 Lisp_Object result
[3];
538 XSET (result
[0], Lisp_Int
, (EMACS_SECS (t
) >> 16) & 0xffff);
539 XSET (result
[1], Lisp_Int
, (EMACS_SECS (t
) >> 0) & 0xffff);
540 XSET (result
[2], Lisp_Int
, EMACS_USECS (t
));
542 return Flist (3, result
);
547 lisp_time_argument (specified_time
, result
)
548 Lisp_Object specified_time
;
551 if (NILP (specified_time
))
552 return time (result
) != -1;
555 Lisp_Object high
, low
;
556 high
= Fcar (specified_time
);
557 CHECK_NUMBER (high
, 0);
558 low
= Fcdr (specified_time
);
559 if (XTYPE (low
) == Lisp_Cons
)
561 CHECK_NUMBER (low
, 0);
562 *result
= (XINT (high
) << 16) + (XINT (low
) & 0xffff);
563 return *result
>> 16 == XINT (high
);
567 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
, 0, 1, 0,
568 "Return the current time, as a human-readable string.\n\
569 Programs can use this function to decode a time,\n\
570 since the number of columns in each field is fixed.\n\
571 The format is `Sun Sep 16 01:03:52 1973'.\n\
572 If an argument is given, it specifies a time to format\n\
573 instead of the current time. The argument should have the form:\n\
576 (HIGH LOW . IGNORED).\n\
577 Thus, you can use times obtained from `current-time'\n\
578 and from `file-attributes'.")
580 Lisp_Object specified_time
;
586 if (! lisp_time_argument (specified_time
, &value
))
588 tem
= (char *) ctime (&value
);
590 strncpy (buf
, tem
, 24);
593 return build_string (buf
);
596 #define TM_YEAR_ORIGIN 1900
598 /* Yield A - B, measured in seconds. */
603 int ay
= a
->tm_year
+ (TM_YEAR_ORIGIN
- 1);
604 int by
= b
->tm_year
+ (TM_YEAR_ORIGIN
- 1);
609 /* difference in day of year */
610 a
->tm_yday
- b
->tm_yday
611 /* + intervening leap days */
612 + ((ay
>> 2) - (by
>> 2))
614 + ((ay
/100 >> 2) - (by
/100 >> 2))
615 /* + difference in years * 365 */
616 + (long)(ay
-by
) * 365
617 )*24 + (a
->tm_hour
- b
->tm_hour
)
618 )*60 + (a
->tm_min
- b
->tm_min
)
619 )*60 + (a
->tm_sec
- b
->tm_sec
);
622 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 1, 0,
623 "Return the offset and name for the local time zone.\n\
624 This returns a list of the form (OFFSET NAME).\n\
625 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).\n\
626 A negative value means west of Greenwich.\n\
627 NAME is a string giving the name of the time zone.\n\
628 If an argument is given, it specifies when the time zone offset is determined\n\
629 instead of using the current time. The argument should have the form:\n\
632 (HIGH LOW . IGNORED).\n\
633 Thus, you can use times obtained from `current-time'\n\
634 and from `file-attributes'.\n\
636 Some operating systems cannot provide all this information to Emacs;\n\
637 in this case, `current-time-zone' returns a list containing nil for\n\
638 the data it can't find.")
640 Lisp_Object specified_time
;
645 if (lisp_time_argument (specified_time
, &value
)
646 && (t
= gmtime (&value
)) != 0)
652 gmt
= *t
; /* Make a copy, in case localtime modifies *t. */
653 t
= localtime (&value
);
654 offset
= difftm (t
, &gmt
);
659 #else /* not HAVE_TM_ZONE */
661 if (t
->tm_isdst
== 0 || t
->tm_isdst
== 1)
662 s
= tzname
[t
->tm_isdst
];
664 #endif /* not HAVE_TM_ZONE */
667 /* No local time zone name is available; use "+-NNNN" instead. */
668 int am
= (offset
< 0 ? -offset
: offset
) / 60;
669 sprintf (buf
, "%c%02d%02d", (offset
< 0 ? '-' : '+'), am
/60, am
%60);
672 return Fcons (make_number (offset
), Fcons (build_string (s
), Qnil
));
675 return Fmake_list (2, Qnil
);
687 /* Callers passing one argument to Finsert need not gcpro the
688 argument "array", since the only element of the array will
689 not be used after calling insert or insert_from_string, so
690 we don't care if it gets trashed. */
692 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
693 "Insert the arguments, either strings or characters, at point.\n\
694 Point moves forward so that it ends up after the inserted text.\n\
695 Any other markers at the point of insertion remain before the text.")
698 register Lisp_Object
*args
;
701 register Lisp_Object tem
;
704 for (argnum
= 0; argnum
< nargs
; argnum
++)
708 if (XTYPE (tem
) == Lisp_Int
)
713 else if (XTYPE (tem
) == Lisp_String
)
715 insert_from_string (tem
, 0, XSTRING (tem
)->size
);
719 tem
= wrong_type_argument (Qchar_or_string_p
, tem
);
727 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
728 "Insert strings or characters at point, relocating markers after the text.\n\
729 Point moves forward so that it ends up after the inserted text.\n\
730 Any other markers at the point of insertion also end up after the text.")
733 register Lisp_Object
*args
;
736 register Lisp_Object tem
;
739 for (argnum
= 0; argnum
< nargs
; argnum
++)
743 if (XTYPE (tem
) == Lisp_Int
)
746 insert_before_markers (str
, 1);
748 else if (XTYPE (tem
) == Lisp_String
)
750 insert_from_string_before_markers (tem
, 0, XSTRING (tem
)->size
);
754 tem
= wrong_type_argument (Qchar_or_string_p
, tem
);
762 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 2, 2, 0,
763 "Insert COUNT (second arg) copies of CHAR (first arg).\n\
764 Point and all markers are affected as in the function `insert'.\n\
765 Both arguments are required.")
767 Lisp_Object chr
, count
;
769 register unsigned char *string
;
773 CHECK_NUMBER (chr
, 0);
774 CHECK_NUMBER (count
, 1);
779 strlen
= min (n
, 256);
780 string
= (unsigned char *) alloca (strlen
);
781 for (i
= 0; i
< strlen
; i
++)
782 string
[i
] = XFASTINT (chr
);
785 insert (string
, strlen
);
794 /* Making strings from buffer contents. */
796 /* Return a Lisp_String containing the text of the current buffer from
797 START to END. If text properties are in use and the current buffer
798 has properties in the range specified, the resulting string will also
801 We don't want to use plain old make_string here, because it calls
802 make_uninit_string, which can cause the buffer arena to be
803 compacted. make_string has no way of knowing that the data has
804 been moved, and thus copies the wrong data into the string. This
805 doesn't effect most of the other users of make_string, so it should
806 be left as is. But we should use this function when conjuring
807 buffer substrings. */
810 make_buffer_string (start
, end
)
815 if (start
< GPT
&& GPT
< end
)
818 result
= make_uninit_string (end
- start
);
819 bcopy (&FETCH_CHAR (start
), XSTRING (result
)->data
, end
- start
);
821 /* Only defined if Emacs is compiled with USE_TEXT_PROPERTIES */
822 copy_intervals_to_string (result
, current_buffer
, start
, end
- start
);
827 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
828 "Return the contents of part of the current buffer as a string.\n\
829 The two arguments START and END are character positions;\n\
830 they can be in either order.")
834 register int beg
, end
;
836 validate_region (&b
, &e
);
840 return make_buffer_string (beg
, end
);
843 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
844 "Return the contents of the current buffer as a string.")
847 return make_buffer_string (BEGV
, ZV
);
850 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
852 "Insert before point a substring of the contents of buffer BUFFER.\n\
853 BUFFER may be a buffer or a buffer name.\n\
854 Arguments START and END are character numbers specifying the substring.\n\
855 They default to the beginning and the end of BUFFER.")
857 Lisp_Object buf
, b
, e
;
859 register int beg
, end
, temp
, len
, opoint
, start
;
860 register struct buffer
*bp
;
863 buffer
= Fget_buffer (buf
);
866 bp
= XBUFFER (buffer
);
872 CHECK_NUMBER_COERCE_MARKER (b
, 0);
879 CHECK_NUMBER_COERCE_MARKER (e
, 1);
884 temp
= beg
, beg
= end
, end
= temp
;
886 /* Move the gap or create enough gap in the current buffer. */
890 if (GAP_SIZE
< end
- beg
)
891 make_gap (end
- beg
- GAP_SIZE
);
897 if (!(BUF_BEGV (bp
) <= beg
899 && end
<= BUF_ZV (bp
)))
900 args_out_of_range (b
, e
);
902 /* Now the actual insertion will not do any gap motion,
903 so it matters not if BUF is the current buffer. */
904 if (beg
< BUF_GPT (bp
))
906 insert (BUF_CHAR_ADDRESS (bp
, beg
), min (end
, BUF_GPT (bp
)) - beg
);
907 beg
= min (end
, BUF_GPT (bp
));
910 insert (BUF_CHAR_ADDRESS (bp
, beg
), end
- beg
);
912 /* Only defined if Emacs is compiled with USE_TEXT_PROPERTIES */
913 graft_intervals_into_buffer (copy_intervals (bp
->intervals
, start
, len
),
919 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
921 "Compare two substrings of two buffers; return result as number.\n\
922 the value is -N if first string is less after N-1 chars,\n\
923 +N if first string is greater after N-1 chars, or 0 if strings match.\n\
924 Each substring is represented as three arguments: BUFFER, START and END.\n\
925 That makes six args in all, three for each substring.\n\n\
926 The value of `case-fold-search' in the current buffer\n\
927 determines whether case is significant or ignored.")
928 (buffer1
, start1
, end1
, buffer2
, start2
, end2
)
929 Lisp_Object buffer1
, start1
, end1
, buffer2
, start2
, end2
;
931 register int begp1
, endp1
, begp2
, endp2
, temp
, len1
, len2
, length
, i
;
932 register struct buffer
*bp1
, *bp2
;
933 register unsigned char *trt
934 = (!NILP (current_buffer
->case_fold_search
)
935 ? XSTRING (current_buffer
->case_canon_table
)->data
: 0);
937 /* Find the first buffer and its substring. */
940 bp1
= current_buffer
;
944 buf1
= Fget_buffer (buffer1
);
947 bp1
= XBUFFER (buf1
);
951 begp1
= BUF_BEGV (bp1
);
954 CHECK_NUMBER_COERCE_MARKER (start1
, 1);
955 begp1
= XINT (start1
);
958 endp1
= BUF_ZV (bp1
);
961 CHECK_NUMBER_COERCE_MARKER (end1
, 2);
966 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
968 if (!(BUF_BEGV (bp1
) <= begp1
970 && endp1
<= BUF_ZV (bp1
)))
971 args_out_of_range (start1
, end1
);
973 /* Likewise for second substring. */
976 bp2
= current_buffer
;
980 buf2
= Fget_buffer (buffer2
);
983 bp2
= XBUFFER (buffer2
);
987 begp2
= BUF_BEGV (bp2
);
990 CHECK_NUMBER_COERCE_MARKER (start2
, 4);
991 begp2
= XINT (start2
);
994 endp2
= BUF_ZV (bp2
);
997 CHECK_NUMBER_COERCE_MARKER (end2
, 5);
1002 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
1004 if (!(BUF_BEGV (bp2
) <= begp2
1006 && endp2
<= BUF_ZV (bp2
)))
1007 args_out_of_range (start2
, end2
);
1009 len1
= endp1
- begp1
;
1010 len2
= endp2
- begp2
;
1015 for (i
= 0; i
< length
; i
++)
1017 int c1
= *BUF_CHAR_ADDRESS (bp1
, begp1
+ i
);
1018 int c2
= *BUF_CHAR_ADDRESS (bp2
, begp2
+ i
);
1025 return make_number (- 1 - i
);
1027 return make_number (i
+ 1);
1030 /* The strings match as far as they go.
1031 If one is shorter, that one is less. */
1033 return make_number (length
+ 1);
1034 else if (length
< len2
)
1035 return make_number (- length
- 1);
1037 /* Same length too => they are equal. */
1038 return make_number (0);
1041 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
1042 Ssubst_char_in_region
, 4, 5, 0,
1043 "From START to END, replace FROMCHAR with TOCHAR each time it occurs.\n\
1044 If optional arg NOUNDO is non-nil, don't record this change for undo\n\
1045 and don't mark the buffer as really changed.")
1046 (start
, end
, fromchar
, tochar
, noundo
)
1047 Lisp_Object start
, end
, fromchar
, tochar
, noundo
;
1049 register int pos
, stop
, look
;
1051 validate_region (&start
, &end
);
1052 CHECK_NUMBER (fromchar
, 2);
1053 CHECK_NUMBER (tochar
, 3);
1057 look
= XINT (fromchar
);
1059 modify_region (current_buffer
, pos
, stop
);
1060 if (! NILP (noundo
))
1062 if (MODIFF
- 1 == current_buffer
->save_modified
)
1063 current_buffer
->save_modified
++;
1064 if (MODIFF
- 1 == current_buffer
->auto_save_modified
)
1065 current_buffer
->auto_save_modified
++;
1070 if (FETCH_CHAR (pos
) == look
)
1073 record_change (pos
, 1);
1074 FETCH_CHAR (pos
) = XINT (tochar
);
1076 signal_after_change (pos
, 1, 1);
1084 DEFUN ("translate-region", Ftranslate_region
, Stranslate_region
, 3, 3, 0,
1085 "From START to END, translate characters according to TABLE.\n\
1086 TABLE is a string; the Nth character in it is the mapping\n\
1087 for the character with code N. Returns the number of characters changed.")
1091 register Lisp_Object table
;
1093 register int pos
, stop
; /* Limits of the region. */
1094 register unsigned char *tt
; /* Trans table. */
1095 register int oc
; /* Old character. */
1096 register int nc
; /* New character. */
1097 int cnt
; /* Number of changes made. */
1098 Lisp_Object z
; /* Return. */
1099 int size
; /* Size of translate table. */
1101 validate_region (&start
, &end
);
1102 CHECK_STRING (table
, 2);
1104 size
= XSTRING (table
)->size
;
1105 tt
= XSTRING (table
)->data
;
1109 modify_region (current_buffer
, pos
, stop
);
1112 for (; pos
< stop
; ++pos
)
1114 oc
= FETCH_CHAR (pos
);
1120 record_change (pos
, 1);
1121 FETCH_CHAR (pos
) = nc
;
1122 signal_after_change (pos
, 1, 1);
1132 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
1133 "Delete the text between point and mark.\n\
1134 When called from a program, expects two arguments,\n\
1135 positions (integers or markers) specifying the stretch to be deleted.")
1139 validate_region (&b
, &e
);
1140 del_range (XINT (b
), XINT (e
));
1144 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
1145 "Remove restrictions (narrowing) from current buffer.\n\
1146 This allows the buffer's full text to be seen and edited.")
1150 SET_BUF_ZV (current_buffer
, Z
);
1152 /* Changing the buffer bounds invalidates any recorded current column. */
1153 invalidate_current_column ();
1157 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
1158 "Restrict editing in this buffer to the current region.\n\
1159 The rest of the text becomes temporarily invisible and untouchable\n\
1160 but is not deleted; if you save the buffer in a file, the invisible\n\
1161 text is included in the file. \\[widen] makes all visible again.\n\
1162 See also `save-restriction'.\n\
1164 When calling from a program, pass two arguments; positions (integers\n\
1165 or markers) bounding the text that should remain visible.")
1167 register Lisp_Object b
, e
;
1171 CHECK_NUMBER_COERCE_MARKER (b
, 0);
1172 CHECK_NUMBER_COERCE_MARKER (e
, 1);
1174 if (XINT (b
) > XINT (e
))
1181 if (!(BEG
<= XINT (b
) && XINT (b
) <= XINT (e
) && XINT (e
) <= Z
))
1182 args_out_of_range (b
, e
);
1184 BEGV
= XFASTINT (b
);
1185 SET_BUF_ZV (current_buffer
, XFASTINT (e
));
1186 if (point
< XFASTINT (b
))
1187 SET_PT (XFASTINT (b
));
1188 if (point
> XFASTINT (e
))
1189 SET_PT (XFASTINT (e
));
1191 /* Changing the buffer bounds invalidates any recorded current column. */
1192 invalidate_current_column ();
1197 save_restriction_save ()
1199 register Lisp_Object bottom
, top
;
1200 /* Note: I tried using markers here, but it does not win
1201 because insertion at the end of the saved region
1202 does not advance mh and is considered "outside" the saved region. */
1203 XFASTINT (bottom
) = BEGV
- BEG
;
1204 XFASTINT (top
) = Z
- ZV
;
1206 return Fcons (Fcurrent_buffer (), Fcons (bottom
, top
));
1210 save_restriction_restore (data
)
1213 register struct buffer
*buf
;
1214 register int newhead
, newtail
;
1215 register Lisp_Object tem
;
1217 buf
= XBUFFER (XCONS (data
)->car
);
1219 data
= XCONS (data
)->cdr
;
1221 tem
= XCONS (data
)->car
;
1222 newhead
= XINT (tem
);
1223 tem
= XCONS (data
)->cdr
;
1224 newtail
= XINT (tem
);
1225 if (newhead
+ newtail
> BUF_Z (buf
) - BUF_BEG (buf
))
1230 BUF_BEGV (buf
) = BUF_BEG (buf
) + newhead
;
1231 SET_BUF_ZV (buf
, BUF_Z (buf
) - newtail
);
1234 /* If point is outside the new visible range, move it inside. */
1236 clip_to_bounds (BUF_BEGV (buf
), BUF_PT (buf
), BUF_ZV (buf
)));
1241 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
1242 "Execute BODY, saving and restoring current buffer's restrictions.\n\
1243 The buffer's restrictions make parts of the beginning and end invisible.\n\
1244 \(They are set up with `narrow-to-region' and eliminated with `widen'.)\n\
1245 This special form, `save-restriction', saves the current buffer's restrictions\n\
1246 when it is entered, and restores them when it is exited.\n\
1247 So any `narrow-to-region' within BODY lasts only until the end of the form.\n\
1248 The old restrictions settings are restored\n\
1249 even in case of abnormal exit (throw or error).\n\
1251 The value returned is the value of the last form in BODY.\n\
1253 `save-restriction' can get confused if, within the BODY, you widen\n\
1254 and then make changes outside the area within the saved restrictions.\n\
1256 Note: if you are using both `save-excursion' and `save-restriction',\n\
1257 use `save-excursion' outermost:\n\
1258 (save-excursion (save-restriction ...))")
1262 register Lisp_Object val
;
1263 int count
= specpdl_ptr
- specpdl
;
1265 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
1266 val
= Fprogn (body
);
1267 return unbind_to (count
, val
);
1270 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
1271 "Print a one-line message at the bottom of the screen.\n\
1272 The first argument is a control string.\n\
1273 It may contain %s or %d or %c to print successive following arguments.\n\
1274 %s means print an argument as a string, %d means print as number in decimal,\n\
1275 %c means print a number as a single character.\n\
1276 The argument used by %s must be a string or a symbol;\n\
1277 the argument used by %d or %c must be a number.\n\
1278 If the first argument is nil, clear any existing message; let the\n\
1279 minibuffer contents show.")
1291 register Lisp_Object val
;
1292 val
= Fformat (nargs
, args
);
1293 message ("%s", XSTRING (val
)->data
);
1298 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
1299 "Format a string out of a control-string and arguments.\n\
1300 The first argument is a control string.\n\
1301 The other arguments are substituted into it to make the result, a string.\n\
1302 It may contain %-sequences meaning to substitute the next argument.\n\
1303 %s means print a string argument. Actually, prints any object, with `princ'.\n\
1304 %d means print as number in decimal (%o octal, %x hex).\n\
1305 %c means print a number as a single character.\n\
1306 %S means print any object as an s-expression (using prin1).\n\
1307 The argument used for %d, %o, %x or %c must be a number.\n\
1308 Use %% to put a single % into the output.")
1311 register Lisp_Object
*args
;
1313 register int n
; /* The number of the next arg to substitute */
1314 register int total
= 5; /* An estimate of the final length */
1316 register unsigned char *format
, *end
;
1318 extern char *index ();
1319 /* It should not be necessary to GCPRO ARGS, because
1320 the caller in the interpreter should take care of that. */
1322 CHECK_STRING (args
[0], 0);
1323 format
= XSTRING (args
[0])->data
;
1324 end
= format
+ XSTRING (args
[0])->size
;
1327 while (format
!= end
)
1328 if (*format
++ == '%')
1332 /* Process a numeric arg and skip it. */
1333 minlen
= atoi (format
);
1338 while ((*format
>= '0' && *format
<= '9')
1339 || *format
== '-' || *format
== ' ' || *format
== '.')
1344 else if (++n
>= nargs
)
1346 else if (*format
== 'S')
1348 /* For `S', prin1 the argument and then treat like a string. */
1349 register Lisp_Object tem
;
1350 tem
= Fprin1_to_string (args
[n
], Qnil
);
1354 else if (XTYPE (args
[n
]) == Lisp_Symbol
)
1356 XSET (args
[n
], Lisp_String
, XSYMBOL (args
[n
])->name
);
1359 else if (XTYPE (args
[n
]) == Lisp_String
)
1362 total
+= XSTRING (args
[n
])->size
;
1364 /* Would get MPV otherwise, since Lisp_Int's `point' to low memory. */
1365 else if (XTYPE (args
[n
]) == Lisp_Int
&& *format
!= 's')
1367 #ifdef LISP_FLOAT_TYPE
1368 /* The following loop assumes the Lisp type indicates
1369 the proper way to pass the argument.
1370 So make sure we have a flonum if the argument should
1372 if (*format
== 'e' || *format
== 'f' || *format
== 'g')
1373 args
[n
] = Ffloat (args
[n
]);
1377 #ifdef LISP_FLOAT_TYPE
1378 else if (XTYPE (args
[n
]) == Lisp_Float
&& *format
!= 's')
1380 if (! (*format
== 'e' || *format
== 'f' || *format
== 'g'))
1381 args
[n
] = Ftruncate (args
[n
]);
1387 /* Anything but a string, convert to a string using princ. */
1388 register Lisp_Object tem
;
1389 tem
= Fprin1_to_string (args
[n
], Qt
);
1396 register int nstrings
= n
+ 1;
1397 register unsigned char **strings
1398 = (unsigned char **) alloca (nstrings
* sizeof (unsigned char *));
1400 for (n
= 0; n
< nstrings
; n
++)
1403 strings
[n
] = (unsigned char *) "";
1404 else if (XTYPE (args
[n
]) == Lisp_Int
)
1405 /* We checked above that the corresponding format effector
1406 isn't %s, which would cause MPV. */
1407 strings
[n
] = (unsigned char *) XINT (args
[n
]);
1408 #ifdef LISP_FLOAT_TYPE
1409 else if (XTYPE (args
[n
]) == Lisp_Float
)
1411 union { double d
; int half
[2]; } u
;
1413 u
.d
= XFLOAT (args
[n
])->data
;
1414 strings
[n
++] = (unsigned char *) u
.half
[0];
1415 strings
[n
] = (unsigned char *) u
.half
[1];
1419 strings
[n
] = XSTRING (args
[n
])->data
;
1422 /* Format it in bigger and bigger buf's until it all fits. */
1425 buf
= (char *) alloca (total
+ 1);
1428 length
= doprnt (buf
, total
+ 1, strings
[0], end
, nargs
, strings
+ 1);
1429 if (buf
[total
- 1] == 0)
1437 return make_string (buf
, length
);
1443 format1 (string1
, arg0
, arg1
, arg2
, arg3
, arg4
)
1444 int arg0
, arg1
, arg2
, arg3
, arg4
;
1458 doprnt (buf
, sizeof buf
, string1
, 0, 5, args
);
1460 doprnt (buf
, sizeof buf
, string1
, 0, 5, &string1
+ 1);
1462 return build_string (buf
);
1465 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
1466 "Return t if two characters match, optionally ignoring case.\n\
1467 Both arguments must be characters (i.e. integers).\n\
1468 Case is ignored if `case-fold-search' is non-nil in the current buffer.")
1470 register Lisp_Object c1
, c2
;
1472 unsigned char *downcase
= DOWNCASE_TABLE
;
1473 CHECK_NUMBER (c1
, 0);
1474 CHECK_NUMBER (c2
, 1);
1476 if (!NILP (current_buffer
->case_fold_search
)
1477 ? (downcase
[0xff & XFASTINT (c1
)] == downcase
[0xff & XFASTINT (c2
)]
1478 && (XFASTINT (c1
) & ~0xff) == (XFASTINT (c2
) & ~0xff))
1479 : XINT (c1
) == XINT (c2
))
1488 DEFVAR_LISP ("system-name", &Vsystem_name
,
1489 "The name of the machine Emacs is running on.");
1491 DEFVAR_LISP ("user-full-name", &Vuser_full_name
,
1492 "The full name of the user logged in.");
1494 DEFVAR_LISP ("user-name", &Vuser_name
,
1495 "The user's name, based on the effective uid.");
1497 DEFVAR_LISP ("user-real-name", &Vuser_real_name
,
1498 "The user's name, base upon the real uid.");
1500 defsubr (&Schar_equal
);
1501 defsubr (&Sgoto_char
);
1502 defsubr (&Sstring_to_char
);
1503 defsubr (&Schar_to_string
);
1504 defsubr (&Sbuffer_substring
);
1505 defsubr (&Sbuffer_string
);
1507 defsubr (&Spoint_marker
);
1508 defsubr (&Smark_marker
);
1510 defsubr (&Sregion_beginning
);
1511 defsubr (&Sregion_end
);
1512 /* defsubr (&Smark); */
1513 /* defsubr (&Sset_mark); */
1514 defsubr (&Ssave_excursion
);
1516 defsubr (&Sbufsize
);
1517 defsubr (&Spoint_max
);
1518 defsubr (&Spoint_min
);
1519 defsubr (&Spoint_min_marker
);
1520 defsubr (&Spoint_max_marker
);
1526 defsubr (&Sfollowing_char
);
1527 defsubr (&Sprevious_char
);
1528 defsubr (&Schar_after
);
1530 defsubr (&Sinsert_before_markers
);
1531 defsubr (&Sinsert_char
);
1533 defsubr (&Suser_login_name
);
1534 defsubr (&Suser_real_login_name
);
1535 defsubr (&Suser_uid
);
1536 defsubr (&Suser_real_uid
);
1537 defsubr (&Suser_full_name
);
1538 defsubr (&Scurrent_time
);
1539 defsubr (&Scurrent_time_string
);
1540 defsubr (&Scurrent_time_zone
);
1541 defsubr (&Ssystem_name
);
1542 defsubr (&Smessage
);
1545 defsubr (&Sinsert_buffer_substring
);
1546 defsubr (&Scompare_buffer_substrings
);
1547 defsubr (&Ssubst_char_in_region
);
1548 defsubr (&Stranslate_region
);
1549 defsubr (&Sdelete_region
);
1551 defsubr (&Snarrow_to_region
);
1552 defsubr (&Ssave_restriction
);