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 will return 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)
648 struct tm gmt
= *t
; /* Make a copy, in case localtime modifies *t. */
651 t
= localtime(&value
);
652 offset
= difftm(t
, &gmt
);
660 /* No local time zone name is available; use "+-NNNN" instead. */
661 long am
= (offset
< 0 ? -offset
: offset
) / 60;
662 sprintf (buf
, "%c%02d%02d", (offset
< 0 ? '-' : '+'), am
/60, am
%60);
665 return Fcons (make_number (offset
), Fcons (build_string (s
), Qnil
));
668 return Fmake_list (2, Qnil
);
680 /* Callers passing one argument to Finsert need not gcpro the
681 argument "array", since the only element of the array will
682 not be used after calling insert or insert_from_string, so
683 we don't care if it gets trashed. */
685 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
686 "Insert the arguments, either strings or characters, at point.\n\
687 Point moves forward so that it ends up after the inserted text.\n\
688 Any other markers at the point of insertion remain before the text.")
691 register Lisp_Object
*args
;
694 register Lisp_Object tem
;
697 for (argnum
= 0; argnum
< nargs
; argnum
++)
701 if (XTYPE (tem
) == Lisp_Int
)
706 else if (XTYPE (tem
) == Lisp_String
)
708 insert_from_string (tem
, 0, XSTRING (tem
)->size
);
712 tem
= wrong_type_argument (Qchar_or_string_p
, tem
);
720 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
721 "Insert strings or characters at point, relocating markers after the text.\n\
722 Point moves forward so that it ends up after the inserted text.\n\
723 Any other markers at the point of insertion also end up after the text.")
726 register Lisp_Object
*args
;
729 register Lisp_Object tem
;
732 for (argnum
= 0; argnum
< nargs
; argnum
++)
736 if (XTYPE (tem
) == Lisp_Int
)
739 insert_before_markers (str
, 1);
741 else if (XTYPE (tem
) == Lisp_String
)
743 insert_from_string_before_markers (tem
, 0, XSTRING (tem
)->size
);
747 tem
= wrong_type_argument (Qchar_or_string_p
, tem
);
755 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 2, 2, 0,
756 "Insert COUNT (second arg) copies of CHAR (first arg).\n\
757 Point and all markers are affected as in the function `insert'.\n\
758 Both arguments are required.")
760 Lisp_Object chr
, count
;
762 register unsigned char *string
;
766 CHECK_NUMBER (chr
, 0);
767 CHECK_NUMBER (count
, 1);
772 strlen
= min (n
, 256);
773 string
= (unsigned char *) alloca (strlen
);
774 for (i
= 0; i
< strlen
; i
++)
775 string
[i
] = XFASTINT (chr
);
778 insert (string
, strlen
);
787 /* Making strings from buffer contents. */
789 /* Return a Lisp_String containing the text of the current buffer from
790 START to END. If text properties are in use and the current buffer
791 has properties in the range specifed, the resulting string will also
794 We don't want to use plain old make_string here, because it calls
795 make_uninit_string, which can cause the buffer arena to be
796 compacted. make_string has no way of knowing that the data has
797 been moved, and thus copies the wrong data into the string. This
798 doesn't effect most of the other users of make_string, so it should
799 be left as is. But we should use this function when conjuring
800 buffer substrings. */
803 make_buffer_string (start
, end
)
808 if (start
< GPT
&& GPT
< end
)
811 result
= make_uninit_string (end
- start
);
812 bcopy (&FETCH_CHAR (start
), XSTRING (result
)->data
, end
- start
);
814 /* Only defined if Emacs is compiled with USE_TEXT_PROPERTIES */
815 copy_intervals_to_string (result
, current_buffer
, start
, end
- start
);
820 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
821 "Return the contents of part of the current buffer as a string.\n\
822 The two arguments START and END are character positions;\n\
823 they can be in either order.")
827 register int beg
, end
;
829 validate_region (&b
, &e
);
833 return make_buffer_string (beg
, end
);
836 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
837 "Return the contents of the current buffer as a string.")
840 return make_buffer_string (BEGV
, ZV
);
843 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
845 "Insert before point a substring of the contents buffer BUFFER.\n\
846 BUFFER may be a buffer or a buffer name.\n\
847 Arguments START and END are character numbers specifying the substring.\n\
848 They default to the beginning and the end of BUFFER.")
850 Lisp_Object buf
, b
, e
;
852 register int beg
, end
, temp
, len
, opoint
, start
;
853 register struct buffer
*bp
;
856 buffer
= Fget_buffer (buf
);
859 bp
= XBUFFER (buffer
);
865 CHECK_NUMBER_COERCE_MARKER (b
, 0);
872 CHECK_NUMBER_COERCE_MARKER (e
, 1);
877 temp
= beg
, beg
= end
, end
= temp
;
879 /* Move the gap or create enough gap in the current buffer. */
883 if (GAP_SIZE
< end
- beg
)
884 make_gap (end
- beg
- GAP_SIZE
);
890 if (!(BUF_BEGV (bp
) <= beg
892 && end
<= BUF_ZV (bp
)))
893 args_out_of_range (b
, e
);
895 /* Now the actual insertion will not do any gap motion,
896 so it matters not if BUF is the current buffer. */
897 if (beg
< BUF_GPT (bp
))
899 insert (BUF_CHAR_ADDRESS (bp
, beg
), min (end
, BUF_GPT (bp
)) - beg
);
900 beg
= min (end
, BUF_GPT (bp
));
903 insert (BUF_CHAR_ADDRESS (bp
, beg
), end
- beg
);
905 /* Only defined if Emacs is compiled with USE_TEXT_PROPERTIES */
906 graft_intervals_into_buffer (copy_intervals (bp
->intervals
, start
, len
),
912 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
914 "Compare two substrings of two buffers; return result as number.\n\
915 the value is -N if first string is less after N-1 chars,\n\
916 +N if first string is greater after N-1 chars, or 0 if strings match.\n\
917 Each substring is represented as three arguments: BUFFER, START and END.\n\
918 That makes six args in all, three for each substring.\n\n\
919 The value of `case-fold-search' in the current buffer\n\
920 determines whether case is significant or ignored.")
921 (buffer1
, start1
, end1
, buffer2
, start2
, end2
)
922 Lisp_Object buffer1
, start1
, end1
, buffer2
, start2
, end2
;
924 register int begp1
, endp1
, begp2
, endp2
, temp
, len1
, len2
, length
, i
;
925 register struct buffer
*bp1
, *bp2
;
926 register unsigned char *trt
927 = (!NILP (current_buffer
->case_fold_search
)
928 ? XSTRING (current_buffer
->case_canon_table
)->data
: 0);
930 /* Find the first buffer and its substring. */
933 bp1
= current_buffer
;
937 buf1
= Fget_buffer (buffer1
);
940 bp1
= XBUFFER (buf1
);
944 begp1
= BUF_BEGV (bp1
);
947 CHECK_NUMBER_COERCE_MARKER (start1
, 1);
948 begp1
= XINT (start1
);
951 endp1
= BUF_ZV (bp1
);
954 CHECK_NUMBER_COERCE_MARKER (end1
, 2);
959 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
961 if (!(BUF_BEGV (bp1
) <= begp1
963 && endp1
<= BUF_ZV (bp1
)))
964 args_out_of_range (start1
, end1
);
966 /* Likewise for second substring. */
969 bp2
= current_buffer
;
973 buf2
= Fget_buffer (buffer2
);
976 bp2
= XBUFFER (buffer2
);
980 begp2
= BUF_BEGV (bp2
);
983 CHECK_NUMBER_COERCE_MARKER (start2
, 4);
984 begp2
= XINT (start2
);
987 endp2
= BUF_ZV (bp2
);
990 CHECK_NUMBER_COERCE_MARKER (end2
, 5);
995 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
997 if (!(BUF_BEGV (bp2
) <= begp2
999 && endp2
<= BUF_ZV (bp2
)))
1000 args_out_of_range (start2
, end2
);
1002 len1
= endp1
- begp1
;
1003 len2
= endp2
- begp2
;
1008 for (i
= 0; i
< length
; i
++)
1010 int c1
= *BUF_CHAR_ADDRESS (bp1
, begp1
+ i
);
1011 int c2
= *BUF_CHAR_ADDRESS (bp2
, begp2
+ i
);
1018 return make_number (- 1 - i
);
1020 return make_number (i
+ 1);
1023 /* The strings match as far as they go.
1024 If one is shorter, that one is less. */
1026 return make_number (length
+ 1);
1027 else if (length
< len2
)
1028 return make_number (- length
- 1);
1030 /* Same length too => they are equal. */
1031 return make_number (0);
1034 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
1035 Ssubst_char_in_region
, 4, 5, 0,
1036 "From START to END, replace FROMCHAR with TOCHAR each time it occurs.\n\
1037 If optional arg NOUNDO is non-nil, don't record this change for undo\n\
1038 and don't mark the buffer as really changed.")
1039 (start
, end
, fromchar
, tochar
, noundo
)
1040 Lisp_Object start
, end
, fromchar
, tochar
, noundo
;
1042 register int pos
, stop
, look
;
1044 validate_region (&start
, &end
);
1045 CHECK_NUMBER (fromchar
, 2);
1046 CHECK_NUMBER (tochar
, 3);
1050 look
= XINT (fromchar
);
1052 modify_region (current_buffer
, pos
, stop
);
1053 if (! NILP (noundo
))
1055 if (MODIFF
- 1 == current_buffer
->save_modified
)
1056 current_buffer
->save_modified
++;
1057 if (MODIFF
- 1 == current_buffer
->auto_save_modified
)
1058 current_buffer
->auto_save_modified
++;
1063 if (FETCH_CHAR (pos
) == look
)
1066 record_change (pos
, 1);
1067 FETCH_CHAR (pos
) = XINT (tochar
);
1069 signal_after_change (pos
, 1, 1);
1077 DEFUN ("translate-region", Ftranslate_region
, Stranslate_region
, 3, 3, 0,
1078 "From START to END, translate characters according to TABLE.\n\
1079 TABLE is a string; the Nth character in it is the mapping\n\
1080 for the character with code N. Returns the number of characters changed.")
1084 register Lisp_Object table
;
1086 register int pos
, stop
; /* Limits of the region. */
1087 register unsigned char *tt
; /* Trans table. */
1088 register int oc
; /* Old character. */
1089 register int nc
; /* New character. */
1090 int cnt
; /* Number of changes made. */
1091 Lisp_Object z
; /* Return. */
1092 int size
; /* Size of translate table. */
1094 validate_region (&start
, &end
);
1095 CHECK_STRING (table
, 2);
1097 size
= XSTRING (table
)->size
;
1098 tt
= XSTRING (table
)->data
;
1102 modify_region (current_buffer
, pos
, stop
);
1105 for (; pos
< stop
; ++pos
)
1107 oc
= FETCH_CHAR (pos
);
1113 record_change (pos
, 1);
1114 FETCH_CHAR (pos
) = nc
;
1115 signal_after_change (pos
, 1, 1);
1125 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
1126 "Delete the text between point and mark.\n\
1127 When called from a program, expects two arguments,\n\
1128 positions (integers or markers) specifying the stretch to be deleted.")
1132 validate_region (&b
, &e
);
1133 del_range (XINT (b
), XINT (e
));
1137 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
1138 "Remove restrictions (narrowing) from current buffer.\n\
1139 This allows the buffer's full text to be seen and edited.")
1143 SET_BUF_ZV (current_buffer
, Z
);
1145 /* Changing the buffer bounds invalidates any recorded current column. */
1146 invalidate_current_column ();
1150 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
1151 "Restrict editing in this buffer to the current region.\n\
1152 The rest of the text becomes temporarily invisible and untouchable\n\
1153 but is not deleted; if you save the buffer in a file, the invisible\n\
1154 text is included in the file. \\[widen] makes all visible again.\n\
1155 See also `save-restriction'.\n\
1157 When calling from a program, pass two arguments; positions (integers\n\
1158 or markers) bounding the text that should remain visible.")
1160 register Lisp_Object b
, e
;
1164 CHECK_NUMBER_COERCE_MARKER (b
, 0);
1165 CHECK_NUMBER_COERCE_MARKER (e
, 1);
1167 if (XINT (b
) > XINT (e
))
1174 if (!(BEG
<= XINT (b
) && XINT (b
) <= XINT (e
) && XINT (e
) <= Z
))
1175 args_out_of_range (b
, e
);
1177 BEGV
= XFASTINT (b
);
1178 SET_BUF_ZV (current_buffer
, XFASTINT (e
));
1179 if (point
< XFASTINT (b
))
1180 SET_PT (XFASTINT (b
));
1181 if (point
> XFASTINT (e
))
1182 SET_PT (XFASTINT (e
));
1184 /* Changing the buffer bounds invalidates any recorded current column. */
1185 invalidate_current_column ();
1190 save_restriction_save ()
1192 register Lisp_Object bottom
, top
;
1193 /* Note: I tried using markers here, but it does not win
1194 because insertion at the end of the saved region
1195 does not advance mh and is considered "outside" the saved region. */
1196 XFASTINT (bottom
) = BEGV
- BEG
;
1197 XFASTINT (top
) = Z
- ZV
;
1199 return Fcons (Fcurrent_buffer (), Fcons (bottom
, top
));
1203 save_restriction_restore (data
)
1206 register struct buffer
*buf
;
1207 register int newhead
, newtail
;
1208 register Lisp_Object tem
;
1210 buf
= XBUFFER (XCONS (data
)->car
);
1212 data
= XCONS (data
)->cdr
;
1214 tem
= XCONS (data
)->car
;
1215 newhead
= XINT (tem
);
1216 tem
= XCONS (data
)->cdr
;
1217 newtail
= XINT (tem
);
1218 if (newhead
+ newtail
> BUF_Z (buf
) - BUF_BEG (buf
))
1223 BUF_BEGV (buf
) = BUF_BEG (buf
) + newhead
;
1224 SET_BUF_ZV (buf
, BUF_Z (buf
) - newtail
);
1227 /* If point is outside the new visible range, move it inside. */
1229 clip_to_bounds (BUF_BEGV (buf
), BUF_PT (buf
), BUF_ZV (buf
)));
1234 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
1235 "Execute BODY, saving and restoring current buffer's restrictions.\n\
1236 The buffer's restrictions make parts of the beginning and end invisible.\n\
1237 \(They are set up with `narrow-to-region' and eliminated with `widen'.)\n\
1238 This special form, `save-restriction', saves the current buffer's restrictions\n\
1239 when it is entered, and restores them when it is exited.\n\
1240 So any `narrow-to-region' within BODY lasts only until the end of the form.\n\
1241 The old restrictions settings are restored\n\
1242 even in case of abnormal exit (throw or error).\n\
1244 The value returned is the value of the last form in BODY.\n\
1246 `save-restriction' can get confused if, within the BODY, you widen\n\
1247 and then make changes outside the area within the saved restrictions.\n\
1249 Note: if you are using both `save-excursion' and `save-restriction',\n\
1250 use `save-excursion' outermost:\n\
1251 (save-excursion (save-restriction ...))")
1255 register Lisp_Object val
;
1256 int count
= specpdl_ptr
- specpdl
;
1258 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
1259 val
= Fprogn (body
);
1260 return unbind_to (count
, val
);
1263 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
1264 "Print a one-line message at the bottom of the screen.\n\
1265 The first argument is a control string.\n\
1266 It may contain %s or %d or %c to print successive following arguments.\n\
1267 %s means print an argument as a string, %d means print as number in decimal,\n\
1268 %c means print a number as a single character.\n\
1269 The argument used by %s must be a string or a symbol;\n\
1270 the argument used by %d or %c must be a number.\n\
1271 If the first argument is nil, clear any existing message; let the\n\
1272 minibuffer contents show.")
1284 register Lisp_Object val
;
1285 val
= Fformat (nargs
, args
);
1286 message ("%s", XSTRING (val
)->data
);
1291 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
1292 "Format a string out of a control-string and arguments.\n\
1293 The first argument is a control string.\n\
1294 The other arguments are substituted into it to make the result, a string.\n\
1295 It may contain %-sequences meaning to substitute the next argument.\n\
1296 %s means print a string argument. Actually, prints any object, with `princ'.\n\
1297 %d means print as number in decimal (%o octal, %x hex).\n\
1298 %c means print a number as a single character.\n\
1299 %S means print any object as an s-expression (using prin1).\n\
1300 The argument used for %d, %o, %x or %c must be a number.\n\
1301 Use %% to put a single % into the output.")
1304 register Lisp_Object
*args
;
1306 register int n
; /* The number of the next arg to substitute */
1307 register int total
= 5; /* An estimate of the final length */
1309 register unsigned char *format
, *end
;
1311 extern char *index ();
1312 /* It should not be necessary to GCPRO ARGS, because
1313 the caller in the interpreter should take care of that. */
1315 CHECK_STRING (args
[0], 0);
1316 format
= XSTRING (args
[0])->data
;
1317 end
= format
+ XSTRING (args
[0])->size
;
1320 while (format
!= end
)
1321 if (*format
++ == '%')
1325 /* Process a numeric arg and skip it. */
1326 minlen
= atoi (format
);
1331 while ((*format
>= '0' && *format
<= '9')
1332 || *format
== '-' || *format
== ' ' || *format
== '.')
1337 else if (++n
>= nargs
)
1339 else if (*format
== 'S')
1341 /* For `S', prin1 the argument and then treat like a string. */
1342 register Lisp_Object tem
;
1343 tem
= Fprin1_to_string (args
[n
], Qnil
);
1347 else if (XTYPE (args
[n
]) == Lisp_Symbol
)
1349 XSET (args
[n
], Lisp_String
, XSYMBOL (args
[n
])->name
);
1352 else if (XTYPE (args
[n
]) == Lisp_String
)
1355 total
+= XSTRING (args
[n
])->size
;
1357 /* Would get MPV otherwise, since Lisp_Int's `point' to low memory. */
1358 else if (XTYPE (args
[n
]) == Lisp_Int
&& *format
!= 's')
1360 #ifdef LISP_FLOAT_TYPE
1361 /* The following loop issumes the Lisp type indicates
1362 the proper way to pass the argument.
1363 So make sure we have a flonum if the argument should
1365 if (*format
== 'e' || *format
== 'f' || *format
== 'g')
1366 args
[n
] = Ffloat (args
[n
]);
1370 #ifdef LISP_FLOAT_TYPE
1371 else if (XTYPE (args
[n
]) == Lisp_Float
&& *format
!= 's')
1373 if (! (*format
== 'e' || *format
== 'f' || *format
== 'g'))
1374 args
[n
] = Ftruncate (args
[n
]);
1380 /* Anything but a string, convert to a string using princ. */
1381 register Lisp_Object tem
;
1382 tem
= Fprin1_to_string (args
[n
], Qt
);
1389 register int nstrings
= n
+ 1;
1390 register unsigned char **strings
1391 = (unsigned char **) alloca (nstrings
* sizeof (unsigned char *));
1393 for (n
= 0; n
< nstrings
; n
++)
1396 strings
[n
] = (unsigned char *) "";
1397 else if (XTYPE (args
[n
]) == Lisp_Int
)
1398 /* We checked above that the corresponding format effector
1399 isn't %s, which would cause MPV. */
1400 strings
[n
] = (unsigned char *) XINT (args
[n
]);
1401 #ifdef LISP_FLOAT_TYPE
1402 else if (XTYPE (args
[n
]) == Lisp_Float
)
1404 union { double d
; int half
[2]; } u
;
1406 u
.d
= XFLOAT (args
[n
])->data
;
1407 strings
[n
++] = (unsigned char *) u
.half
[0];
1408 strings
[n
] = (unsigned char *) u
.half
[1];
1412 strings
[n
] = XSTRING (args
[n
])->data
;
1415 /* Format it in bigger and bigger buf's until it all fits. */
1418 buf
= (char *) alloca (total
+ 1);
1421 length
= doprnt (buf
, total
+ 1, strings
[0], end
, nargs
, strings
+ 1);
1422 if (buf
[total
- 1] == 0)
1430 return make_string (buf
, length
);
1436 format1 (string1
, arg0
, arg1
, arg2
, arg3
, arg4
)
1437 int arg0
, arg1
, arg2
, arg3
, arg4
;
1451 doprnt (buf
, sizeof buf
, string1
, 0, 5, args
);
1453 doprnt (buf
, sizeof buf
, string1
, 0, 5, &string1
+ 1);
1455 return build_string (buf
);
1458 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
1459 "Return t if two characters match, optionally ignoring case.\n\
1460 Both arguments must be characters (i.e. integers).\n\
1461 Case is ignored if `case-fold-search' is non-nil in the current buffer.")
1463 register Lisp_Object c1
, c2
;
1465 unsigned char *downcase
= DOWNCASE_TABLE
;
1466 CHECK_NUMBER (c1
, 0);
1467 CHECK_NUMBER (c2
, 1);
1469 if (!NILP (current_buffer
->case_fold_search
)
1470 ? (downcase
[0xff & XFASTINT (c1
)] == downcase
[0xff & XFASTINT (c2
)]
1471 && (XFASTINT (c1
) & ~0xff) == (XFASTINT (c2
) & ~0xff))
1472 : XINT (c1
) == XINT (c2
))
1481 DEFVAR_LISP ("system-name", &Vsystem_name
,
1482 "The name of the machine Emacs is running on.");
1484 DEFVAR_LISP ("user-full-name", &Vuser_full_name
,
1485 "The full name of the user logged in.");
1487 DEFVAR_LISP ("user-name", &Vuser_name
,
1488 "The user's name, based on the effective uid.");
1490 DEFVAR_LISP ("user-real-name", &Vuser_real_name
,
1491 "The user's name, base upon the real uid.");
1493 defsubr (&Schar_equal
);
1494 defsubr (&Sgoto_char
);
1495 defsubr (&Sstring_to_char
);
1496 defsubr (&Schar_to_string
);
1497 defsubr (&Sbuffer_substring
);
1498 defsubr (&Sbuffer_string
);
1500 defsubr (&Spoint_marker
);
1501 defsubr (&Smark_marker
);
1503 defsubr (&Sregion_beginning
);
1504 defsubr (&Sregion_end
);
1505 /* defsubr (&Smark); */
1506 /* defsubr (&Sset_mark); */
1507 defsubr (&Ssave_excursion
);
1509 defsubr (&Sbufsize
);
1510 defsubr (&Spoint_max
);
1511 defsubr (&Spoint_min
);
1512 defsubr (&Spoint_min_marker
);
1513 defsubr (&Spoint_max_marker
);
1519 defsubr (&Sfollowing_char
);
1520 defsubr (&Sprevious_char
);
1521 defsubr (&Schar_after
);
1523 defsubr (&Sinsert_before_markers
);
1524 defsubr (&Sinsert_char
);
1526 defsubr (&Suser_login_name
);
1527 defsubr (&Suser_real_login_name
);
1528 defsubr (&Suser_uid
);
1529 defsubr (&Suser_real_uid
);
1530 defsubr (&Suser_full_name
);
1531 defsubr (&Scurrent_time
);
1532 defsubr (&Scurrent_time_string
);
1533 defsubr (&Scurrent_time_zone
);
1534 defsubr (&Ssystem_name
);
1535 defsubr (&Smessage
);
1538 defsubr (&Sinsert_buffer_substring
);
1539 defsubr (&Scompare_buffer_substrings
);
1540 defsubr (&Ssubst_char_in_region
);
1541 defsubr (&Stranslate_region
);
1542 defsubr (&Sdelete_region
);
1544 defsubr (&Snarrow_to_region
);
1545 defsubr (&Ssave_restriction
);