1 /* Lisp functions pertaining to editing.
2 Copyright (C) 1985, 1986, 1987, 1989, 1992 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. */
30 #include "intervals.h"
36 #define min(a, b) ((a) < (b) ? (a) : (b))
37 #define max(a, b) ((a) > (b) ? (a) : (b))
39 /* Some static data, and a function to initialize it for each run */
41 Lisp_Object Vsystem_name
;
42 Lisp_Object Vuser_real_name
; /* login name of current user ID */
43 Lisp_Object Vuser_full_name
; /* full name of current user */
44 Lisp_Object Vuser_name
; /* user name from USER or LOGNAME. */
50 register unsigned char *p
, *q
, *r
;
51 struct passwd
*pw
; /* password entry for the current user */
52 extern char *index ();
55 /* Set up system_name even when dumping. */
57 Vsystem_name
= build_string (get_system_name ());
58 p
= XSTRING (Vsystem_name
)->data
;
61 if (*p
== ' ' || *p
== '\t')
67 /* Don't bother with this on initial start when just dumping out */
70 #endif /* not CANNOT_DUMP */
72 pw
= (struct passwd
*) getpwuid (getuid ());
73 Vuser_real_name
= build_string (pw
? pw
->pw_name
: "unknown");
75 /* Get the effective user name, by consulting environment variables,
76 or the effective uid if those are unset. */
77 user_name
= (char *) getenv ("USER");
79 user_name
= (char *) getenv ("LOGNAME");
82 pw
= (struct passwd
*) getpwuid (geteuid ());
83 user_name
= (char *) (pw
? pw
->pw_name
: "unknown");
85 Vuser_name
= build_string (user_name
);
87 /* If the user name claimed in the environment vars differs from
88 the real uid, use the claimed name to find the full name. */
89 tem
= Fstring_equal (Vuser_name
, Vuser_real_name
);
91 pw
= (struct passwd
*) getpwnam (XSTRING (Vuser_name
)->data
);
93 p
= (unsigned char *) (pw
? USER_FULL_NAME
: "unknown");
94 q
= (unsigned char *) index (p
, ',');
95 Vuser_full_name
= make_string (p
, q
? q
- p
: strlen (p
));
97 #ifdef AMPERSAND_FULL_NAME
98 p
= XSTRING (Vuser_full_name
)->data
;
99 q
= (char *) index (p
, '&');
100 /* Substitute the login name for the &, upcasing the first character. */
103 r
= (char *) alloca (strlen (p
) + XSTRING (Vuser_name
)->size
+ 1);
106 strcat (r
, XSTRING (Vuser_name
)->data
);
107 r
[q
- p
] = UPCASE (r
[q
- p
]);
109 Vuser_full_name
= build_string (r
);
111 #endif /* AMPERSAND_FULL_NAME */
114 DEFUN ("char-to-string", Fchar_to_string
, Schar_to_string
, 1, 1, 0,
115 "Convert arg CHAR to a one-character string containing that character.")
123 return make_string (&c
, 1);
126 DEFUN ("string-to-char", Fstring_to_char
, Sstring_to_char
, 1, 1, 0,
127 "Convert arg STRING to a character, the first character of that string.")
129 register Lisp_Object str
;
131 register Lisp_Object val
;
132 register struct Lisp_String
*p
;
133 CHECK_STRING (str
, 0);
137 XFASTINT (val
) = ((unsigned char *) p
->data
)[0];
147 register Lisp_Object mark
;
148 mark
= Fmake_marker ();
149 Fset_marker (mark
, make_number (val
), Qnil
);
153 DEFUN ("point", Fpoint
, Spoint
, 0, 0, 0,
154 "Return value of point, as an integer.\n\
155 Beginning of buffer is position (point-min)")
159 XFASTINT (temp
) = point
;
163 DEFUN ("point-marker", Fpoint_marker
, Spoint_marker
, 0, 0, 0,
164 "Return value of point, as a marker object.")
167 return buildmark (point
);
171 clip_to_bounds (lower
, num
, upper
)
172 int lower
, num
, upper
;
176 else if (num
> upper
)
182 DEFUN ("goto-char", Fgoto_char
, Sgoto_char
, 1, 1, "NGoto char: ",
183 "Set point to POSITION, a number or marker.\n\
184 Beginning of buffer is position (point-min), end is (point-max).")
186 register Lisp_Object n
;
188 CHECK_NUMBER_COERCE_MARKER (n
, 0);
190 SET_PT (clip_to_bounds (BEGV
, XINT (n
), ZV
));
195 region_limit (beginningp
)
198 register Lisp_Object m
;
199 m
= Fmarker_position (current_buffer
->mark
);
200 if (NILP (m
)) error ("There is no region now");
201 if ((point
< XFASTINT (m
)) == beginningp
)
202 return (make_number (point
));
207 DEFUN ("region-beginning", Fregion_beginning
, Sregion_beginning
, 0, 0, 0,
208 "Return position of beginning of region, as an integer.")
211 return (region_limit (1));
214 DEFUN ("region-end", Fregion_end
, Sregion_end
, 0, 0, 0,
215 "Return position of end of region, as an integer.")
218 return (region_limit (0));
221 #if 0 /* now in lisp code */
222 DEFUN ("mark", Fmark
, Smark
, 0, 0, 0,
223 "Return this buffer's mark value as integer, or nil if no mark.\n\
224 If you are using this in an editing command, you are most likely making\n\
225 a mistake; see the documentation of `set-mark'.")
228 return Fmarker_position (current_buffer
->mark
);
230 #endif /* commented out code */
232 DEFUN ("mark-marker", Fmark_marker
, Smark_marker
, 0, 0, 0,
233 "Return this buffer's mark, as a marker object.\n\
234 Watch out! Moving this marker changes the mark position.\n\
235 If you set the marker not to point anywhere, the buffer will have no mark.")
238 return current_buffer
->mark
;
241 #if 0 /* this is now in lisp code */
242 DEFUN ("set-mark", Fset_mark
, Sset_mark
, 1, 1, 0,
243 "Set this buffer's mark to POS. Don't use this function!\n\
244 That is to say, don't use this function unless you want\n\
245 the user to see that the mark has moved, and you want the previous\n\
246 mark position to be lost.\n\
248 Normally, when a new mark is set, the old one should go on the stack.\n\
249 This is why most applications should use push-mark, not set-mark.\n\
251 Novice programmers often try to use the mark for the wrong purposes.\n\
252 The mark saves a location for the user's convenience.\n\
253 Most editing commands should not alter the mark.\n\
254 To remember a location for internal use in the Lisp program,\n\
255 store it in a Lisp variable. Example:\n\
257 (let ((beg (point))) (forward-line 1) (delete-region beg (point))).")
263 current_buffer
->mark
= Qnil
;
266 CHECK_NUMBER_COERCE_MARKER (pos
, 0);
268 if (NILP (current_buffer
->mark
))
269 current_buffer
->mark
= Fmake_marker ();
271 Fset_marker (current_buffer
->mark
, pos
, Qnil
);
274 #endif /* commented-out code */
277 save_excursion_save ()
279 register int visible
= (XBUFFER (XWINDOW (selected_window
)->buffer
)
282 return Fcons (Fpoint_marker (),
283 Fcons (Fcopy_marker (current_buffer
->mark
),
284 visible
? Qt
: Qnil
));
288 save_excursion_restore (info
)
289 register Lisp_Object info
;
291 register Lisp_Object tem
;
293 tem
= Fmarker_buffer (Fcar (info
));
294 /* If buffer being returned to is now deleted, avoid error */
295 /* Otherwise could get error here while unwinding to top level
297 /* In that case, Fmarker_buffer returns nil now. */
303 unchain_marker (tem
);
304 tem
= Fcar (Fcdr (info
));
305 Fset_marker (current_buffer
->mark
, tem
, Fcurrent_buffer ());
306 unchain_marker (tem
);
307 tem
= Fcdr (Fcdr (info
));
309 && current_buffer
!= XBUFFER (XWINDOW (selected_window
)->buffer
))
310 Fswitch_to_buffer (Fcurrent_buffer (), Qnil
);
314 DEFUN ("save-excursion", Fsave_excursion
, Ssave_excursion
, 0, UNEVALLED
, 0,
315 "Save point, mark, and current buffer; execute BODY; restore those things.\n\
316 Executes BODY just like `progn'.\n\
317 The values of point, mark and the current buffer are restored\n\
318 even in case of abnormal exit (throw or error).")
322 register Lisp_Object val
;
323 int count
= specpdl_ptr
- specpdl
;
325 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
328 return unbind_to (count
, val
);
331 DEFUN ("buffer-size", Fbufsize
, Sbufsize
, 0, 0, 0,
332 "Return the number of characters in the current buffer.")
336 XFASTINT (temp
) = Z
- BEG
;
340 DEFUN ("point-min", Fpoint_min
, Spoint_min
, 0, 0, 0,
341 "Return the minimum permissible value of point in the current buffer.\n\
342 This is 1, unless a clipping restriction is in effect.")
346 XFASTINT (temp
) = BEGV
;
350 DEFUN ("point-min-marker", Fpoint_min_marker
, Spoint_min_marker
, 0, 0, 0,
351 "Return a marker to the minimum permissible value of point in this buffer.\n\
352 This is the beginning, unless a clipping restriction is in effect.")
355 return buildmark (BEGV
);
358 DEFUN ("point-max", Fpoint_max
, Spoint_max
, 0, 0, 0,
359 "Return the maximum permissible value of point in the current buffer.\n\
360 This is (1+ (buffer-size)), unless a clipping restriction is in effect,\n\
361 in which case it is less.")
365 XFASTINT (temp
) = ZV
;
369 DEFUN ("point-max-marker", Fpoint_max_marker
, Spoint_max_marker
, 0, 0, 0,
370 "Return a marker to the maximum permissible value of point in this buffer.\n\
371 This is (1+ (buffer-size)), unless a clipping restriction is in effect,\n\
372 in which case it is less.")
375 return buildmark (ZV
);
378 DEFUN ("following-char", Ffollowing_char
, Sfollowing_char
, 0, 0, 0,
379 "Return the character following point, as a number.\n\
380 At the end of the buffer or accessible region, return 0.")
387 XFASTINT (temp
) = FETCH_CHAR (point
);
391 DEFUN ("preceding-char", Fprevious_char
, Sprevious_char
, 0, 0, 0,
392 "Return the character preceding point, as a number.\n\
393 At the beginning of the buffer or accessible region, return 0.")
400 XFASTINT (temp
) = FETCH_CHAR (point
- 1);
404 DEFUN ("bobp", Fbobp
, Sbobp
, 0, 0, 0,
405 "Return T if point is at the beginning of the buffer.\n\
406 If the buffer is narrowed, this means the beginning of the narrowed part.")
414 DEFUN ("eobp", Feobp
, Seobp
, 0, 0, 0,
415 "Return T if point is at the end of the buffer.\n\
416 If the buffer is narrowed, this means the end of the narrowed part.")
424 DEFUN ("bolp", Fbolp
, Sbolp
, 0, 0, 0,
425 "Return T if point is at the beginning of a line.")
428 if (point
== BEGV
|| FETCH_CHAR (point
- 1) == '\n')
433 DEFUN ("eolp", Feolp
, Seolp
, 0, 0, 0,
434 "Return T if point is at the end of a line.\n\
435 `End of a line' includes point being at the end of the buffer.")
438 if (point
== ZV
|| FETCH_CHAR (point
) == '\n')
443 DEFUN ("char-after", Fchar_after
, Schar_after
, 1, 1, 0,
444 "Return character in current buffer at position POS.\n\
445 POS is an integer or a buffer pointer.\n\
446 If POS is out of range, the value is nil.")
450 register Lisp_Object val
;
453 CHECK_NUMBER_COERCE_MARKER (pos
, 0);
456 if (n
< BEGV
|| n
>= ZV
) return Qnil
;
458 XFASTINT (val
) = FETCH_CHAR (n
);
462 DEFUN ("user-login-name", Fuser_login_name
, Suser_login_name
, 0, 0, 0,
463 "Return the name under which the user logged in, as a string.\n\
464 This is based on the effective uid, not the real uid.\n\
465 Also, if the environment variable USER or LOGNAME is set,\n\
466 that determines the value of this function.")
472 DEFUN ("user-real-login-name", Fuser_real_login_name
, Suser_real_login_name
,
474 "Return the name of the user's real uid, as a string.\n\
475 Differs from `user-login-name' when running under `su'.")
478 return Vuser_real_name
;
481 DEFUN ("user-uid", Fuser_uid
, Suser_uid
, 0, 0, 0,
482 "Return the effective uid of Emacs, as an integer.")
485 return make_number (geteuid ());
488 DEFUN ("user-real-uid", Fuser_real_uid
, Suser_real_uid
, 0, 0, 0,
489 "Return the real uid of Emacs, as an integer.")
492 return make_number (getuid ());
495 DEFUN ("user-full-name", Fuser_full_name
, Suser_full_name
, 0, 0, 0,
496 "Return the full name of the user logged in, as a string.")
499 return Vuser_full_name
;
502 DEFUN ("system-name", Fsystem_name
, Ssystem_name
, 0, 0, 0,
503 "Return the name of the machine you are running on, as a string.")
509 DEFUN ("current-time", Fcurrent_time
, Scurrent_time
, 0, 0, 0,
510 "Return the current time, as the number of seconds since 12:00 AM January 1970.\n\
511 The time is returned as a list of three integers. The first has the\n\
512 most significant 16 bits of the seconds, while the second has the\n\
513 least significant 16 bits. The third integer gives the microsecond\n\
516 The microsecond count is zero on systems that do not provide\n\
517 resolution finer than a second.")
521 Lisp_Object result
[3];
524 XSET (result
[0], Lisp_Int
, (EMACS_SECS (t
) >> 16) & 0xffff);
525 XSET (result
[1], Lisp_Int
, (EMACS_SECS (t
) >> 0) & 0xffff);
526 XSET (result
[2], Lisp_Int
, EMACS_USECS (t
));
528 return Flist (3, result
);
532 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
, 0, 0, 0,
533 "Return the current time, as a human-readable string.\n\
534 Programs can use it too, since the number of columns in each field is fixed.\n\
535 The format is `Sun Sep 16 01:03:52 1973'.")
538 long current_time
= time ((long *) 0);
540 register char *tem
= (char *) ctime (¤t_time
);
542 strncpy (buf
, tem
, 24);
545 return build_string (buf
);
548 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 0, 0,
549 "Return the offset, savings state, and names for the current time zone.\n\
550 This returns a list of the form (OFFSET SAVINGS-FLAG STANDARD SAVINGS).\n\
551 OFFSET is an integer specifying how many minutes east of Greenwich the\n\
552 current time zone is located. A negative value means west of\n\
553 Greenwich. Note that this describes the standard time; if daylight\n\
554 savings time is in effect, it does not affect this value.\n\
555 SAVINGS-FLAG is non-nil iff daylight savings time or some other sort\n\
556 of seasonal time adjustment is in effect.\n\
557 STANDARD is a string giving the name of the time zone when no seasonal\n\
558 time adjustment is in effect.\n\
559 SAVINGS is a string giving the name of the time zone when there is a\n\
560 seasonal time adjustment in effect.\n\
561 If the local area does not use a seasonal time adjustment,\n\
562 SAVINGS-FLAG is always nil, and STANDARD and SAVINGS are equal.")
565 #ifdef EMACS_CURRENT_TIME_ZONE
566 int offset
, savings_flag
;
570 EMACS_CURRENT_TIME_ZONE (&offset
, &savings_flag
, standard
, savings
);
572 return Fcons (make_number (offset
),
573 Fcons ((savings_flag
? Qt
: Qnil
),
574 Fcons (build_string (standard
),
575 Fcons (build_string (savings
),
579 ("current-time-zone has not been implemented on this operating system.");
592 /* Callers passing one argument to Finsert need not gcpro the
593 argument "array", since the only element of the array will
594 not be used after calling insert or insert_from_string, so
595 we don't care if it gets trashed. */
597 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
598 "Insert the arguments, either strings or characters, at point.\n\
599 Point moves forward so that it ends up after the inserted text.\n\
600 Any other markers at the point of insertion remain before the text.")
603 register Lisp_Object
*args
;
606 register Lisp_Object tem
;
609 for (argnum
= 0; argnum
< nargs
; argnum
++)
613 if (XTYPE (tem
) == Lisp_Int
)
618 else if (XTYPE (tem
) == Lisp_String
)
620 insert_from_string (tem
, 0, XSTRING (tem
)->size
);
624 tem
= wrong_type_argument (Qchar_or_string_p
, tem
);
632 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
633 "Insert strings or characters at point, relocating markers after the text.\n\
634 Point moves forward so that it ends up after the inserted text.\n\
635 Any other markers at the point of insertion also end up after the text.")
638 register Lisp_Object
*args
;
641 register Lisp_Object tem
;
644 for (argnum
= 0; argnum
< nargs
; argnum
++)
648 if (XTYPE (tem
) == Lisp_Int
)
651 insert_before_markers (str
, 1);
653 else if (XTYPE (tem
) == Lisp_String
)
655 insert_from_string_before_markers (tem
, 0, XSTRING (tem
)->size
);
659 tem
= wrong_type_argument (Qchar_or_string_p
, tem
);
667 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 2, 2, 0,
668 "Insert COUNT (second arg) copies of CHAR (first arg).\n\
669 Point and all markers are affected as in the function `insert'.\n\
670 Both arguments are required.")
672 Lisp_Object chr
, count
;
674 register unsigned char *string
;
678 CHECK_NUMBER (chr
, 0);
679 CHECK_NUMBER (count
, 1);
684 strlen
= min (n
, 256);
685 string
= (unsigned char *) alloca (strlen
);
686 for (i
= 0; i
< strlen
; i
++)
687 string
[i
] = XFASTINT (chr
);
690 insert (string
, strlen
);
699 /* Making strings from buffer contents. */
701 /* Return a Lisp_String containing the text of the current buffer from
702 START to END. If text properties are in use and the current buffer
703 has properties in the range specifed, the resulting string will also
706 We don't want to use plain old make_string here, because it calls
707 make_uninit_string, which can cause the buffer arena to be
708 compacted. make_string has no way of knowing that the data has
709 been moved, and thus copies the wrong data into the string. This
710 doesn't effect most of the other users of make_string, so it should
711 be left as is. But we should use this function when conjuring
712 buffer substrings. */
715 make_buffer_string (start
, end
)
720 if (start
< GPT
&& GPT
< end
)
723 result
= make_uninit_string (end
- start
);
724 bcopy (&FETCH_CHAR (start
), XSTRING (result
)->data
, end
- start
);
726 /* Only defined if Emacs is compiled with USE_TEXT_PROPERTIES */
727 copy_intervals_to_string (result
, current_buffer
, start
, end
- start
);
732 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
733 "Return the contents of part of the current buffer as a string.\n\
734 The two arguments START and END are character positions;\n\
735 they can be in either order.")
739 register int beg
, end
;
741 validate_region (&b
, &e
);
745 return make_buffer_string (beg
, end
);
748 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
749 "Return the contents of the current buffer as a string.")
752 return make_buffer_string (BEGV
, ZV
);
755 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
757 "Insert before point a substring of the contents buffer BUFFER.\n\
758 BUFFER may be a buffer or a buffer name.\n\
759 Arguments START and END are character numbers specifying the substring.\n\
760 They default to the beginning and the end of BUFFER.")
762 Lisp_Object buf
, b
, e
;
764 register int beg
, end
, temp
, len
, opoint
, start
;
765 register struct buffer
*bp
;
768 buffer
= Fget_buffer (buf
);
771 bp
= XBUFFER (buffer
);
777 CHECK_NUMBER_COERCE_MARKER (b
, 0);
784 CHECK_NUMBER_COERCE_MARKER (e
, 1);
789 temp
= beg
, beg
= end
, end
= temp
;
791 /* Move the gap or create enough gap in the current buffer. */
795 if (GAP_SIZE
< end
- beg
)
796 make_gap (end
- beg
- GAP_SIZE
);
802 if (!(BUF_BEGV (bp
) <= beg
804 && end
<= BUF_ZV (bp
)))
805 args_out_of_range (b
, e
);
807 /* Now the actual insertion will not do any gap motion,
808 so it matters not if BUF is the current buffer. */
809 if (beg
< BUF_GPT (bp
))
811 insert (BUF_CHAR_ADDRESS (bp
, beg
), min (end
, BUF_GPT (bp
)) - beg
);
812 beg
= min (end
, BUF_GPT (bp
));
815 insert (BUF_CHAR_ADDRESS (bp
, beg
), end
- beg
);
817 /* Only defined if Emacs is compiled with USE_TEXT_PROPERTIES */
818 graft_intervals_into_buffer (copy_intervals (bp
->intervals
, start
, len
),
824 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
826 "Compare two substrings of two buffers; return result as number.\n\
827 the value is -N if first string is less after N-1 chars,\n\
828 +N if first string is greater after N-1 chars, or 0 if strings match.\n\
829 Each substring is represented as three arguments: BUFFER, START and END.\n\
830 That makes six args in all, three for each substring.\n\n\
831 The value of `case-fold-search' in the current buffer\n\
832 determines whether case is significant or ignored.")
833 (buffer1
, start1
, end1
, buffer2
, start2
, end2
)
834 Lisp_Object buffer1
, start1
, end1
, buffer2
, start2
, end2
;
836 register int begp1
, endp1
, begp2
, endp2
, temp
, len1
, len2
, length
, i
;
837 register struct buffer
*bp1
, *bp2
;
838 register unsigned char *trt
839 = (!NILP (current_buffer
->case_fold_search
)
840 ? XSTRING (current_buffer
->case_canon_table
)->data
: 0);
842 /* Find the first buffer and its substring. */
845 bp1
= current_buffer
;
849 buf1
= Fget_buffer (buffer1
);
852 bp1
= XBUFFER (buf1
);
856 begp1
= BUF_BEGV (bp1
);
859 CHECK_NUMBER_COERCE_MARKER (start1
, 1);
860 begp1
= XINT (start1
);
863 endp1
= BUF_ZV (bp1
);
866 CHECK_NUMBER_COERCE_MARKER (end1
, 2);
871 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
873 if (!(BUF_BEGV (bp1
) <= begp1
875 && endp1
<= BUF_ZV (bp1
)))
876 args_out_of_range (start1
, end1
);
878 /* Likewise for second substring. */
881 bp2
= current_buffer
;
885 buf2
= Fget_buffer (buffer2
);
888 bp2
= XBUFFER (buffer2
);
892 begp2
= BUF_BEGV (bp2
);
895 CHECK_NUMBER_COERCE_MARKER (start2
, 4);
896 begp2
= XINT (start2
);
899 endp2
= BUF_ZV (bp2
);
902 CHECK_NUMBER_COERCE_MARKER (end2
, 5);
907 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
909 if (!(BUF_BEGV (bp2
) <= begp2
911 && endp2
<= BUF_ZV (bp2
)))
912 args_out_of_range (start2
, end2
);
914 len1
= endp1
- begp1
;
915 len2
= endp2
- begp2
;
920 for (i
= 0; i
< length
; i
++)
922 int c1
= *BUF_CHAR_ADDRESS (bp1
, begp1
+ i
);
923 int c2
= *BUF_CHAR_ADDRESS (bp2
, begp2
+ i
);
930 return make_number (- 1 - i
);
932 return make_number (i
+ 1);
935 /* The strings match as far as they go.
936 If one is shorter, that one is less. */
938 return make_number (length
+ 1);
939 else if (length
< len2
)
940 return make_number (- length
- 1);
942 /* Same length too => they are equal. */
943 return make_number (0);
946 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
947 Ssubst_char_in_region
, 4, 5, 0,
948 "From START to END, replace FROMCHAR with TOCHAR each time it occurs.\n\
949 If optional arg NOUNDO is non-nil, don't record this change for undo\n\
950 and don't mark the buffer as really changed.")
951 (start
, end
, fromchar
, tochar
, noundo
)
952 Lisp_Object start
, end
, fromchar
, tochar
, noundo
;
954 register int pos
, stop
, look
;
956 validate_region (&start
, &end
);
957 CHECK_NUMBER (fromchar
, 2);
958 CHECK_NUMBER (tochar
, 3);
962 look
= XINT (fromchar
);
964 modify_region (pos
, stop
);
967 if (MODIFF
- 1 == current_buffer
->save_modified
)
968 current_buffer
->save_modified
++;
969 if (MODIFF
- 1 == current_buffer
->auto_save_modified
)
970 current_buffer
->auto_save_modified
++;
975 if (FETCH_CHAR (pos
) == look
)
978 record_change (pos
, 1);
979 FETCH_CHAR (pos
) = XINT (tochar
);
981 signal_after_change (pos
, 1, 1);
989 DEFUN ("translate-region", Ftranslate_region
, Stranslate_region
, 3, 3, 0,
990 "From START to END, translate characters according to TABLE.\n\
991 TABLE is a string; the Nth character in it is the mapping\n\
992 for the character with code N. Returns the number of characters changed.")
996 register Lisp_Object table
;
998 register int pos
, stop
; /* Limits of the region. */
999 register unsigned char *tt
; /* Trans table. */
1000 register int oc
; /* Old character. */
1001 register int nc
; /* New character. */
1002 int cnt
; /* Number of changes made. */
1003 Lisp_Object z
; /* Return. */
1004 int size
; /* Size of translate table. */
1006 validate_region (&start
, &end
);
1007 CHECK_STRING (table
, 2);
1009 size
= XSTRING (table
)->size
;
1010 tt
= XSTRING (table
)->data
;
1014 modify_region (pos
, stop
);
1017 for (; pos
< stop
; ++pos
)
1019 oc
= FETCH_CHAR (pos
);
1025 record_change (pos
, 1);
1026 FETCH_CHAR (pos
) = nc
;
1027 signal_after_change (pos
, 1, 1);
1037 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
1038 "Delete the text between point and mark.\n\
1039 When called from a program, expects two arguments,\n\
1040 positions (integers or markers) specifying the stretch to be deleted.")
1044 validate_region (&b
, &e
);
1045 del_range (XINT (b
), XINT (e
));
1049 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
1050 "Remove restrictions (narrowing) from current buffer.\n\
1051 This allows the buffer's full text to be seen and edited.")
1055 SET_BUF_ZV (current_buffer
, Z
);
1057 /* Changing the buffer bounds invalidates any recorded current column. */
1058 invalidate_current_column ();
1062 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
1063 "Restrict editing in this buffer to the current region.\n\
1064 The rest of the text becomes temporarily invisible and untouchable\n\
1065 but is not deleted; if you save the buffer in a file, the invisible\n\
1066 text is included in the file. \\[widen] makes all visible again.\n\
1067 See also `save-restriction'.\n\
1069 When calling from a program, pass two arguments; positions (integers\n\
1070 or markers) bounding the text that should remain visible.")
1072 register Lisp_Object b
, e
;
1076 CHECK_NUMBER_COERCE_MARKER (b
, 0);
1077 CHECK_NUMBER_COERCE_MARKER (e
, 1);
1079 if (XINT (b
) > XINT (e
))
1086 if (!(BEG
<= XINT (b
) && XINT (b
) <= XINT (e
) && XINT (e
) <= Z
))
1087 args_out_of_range (b
, e
);
1089 BEGV
= XFASTINT (b
);
1090 SET_BUF_ZV (current_buffer
, XFASTINT (e
));
1091 if (point
< XFASTINT (b
))
1092 SET_PT (XFASTINT (b
));
1093 if (point
> XFASTINT (e
))
1094 SET_PT (XFASTINT (e
));
1096 /* Changing the buffer bounds invalidates any recorded current column. */
1097 invalidate_current_column ();
1102 save_restriction_save ()
1104 register Lisp_Object bottom
, top
;
1105 /* Note: I tried using markers here, but it does not win
1106 because insertion at the end of the saved region
1107 does not advance mh and is considered "outside" the saved region. */
1108 XFASTINT (bottom
) = BEGV
- BEG
;
1109 XFASTINT (top
) = Z
- ZV
;
1111 return Fcons (Fcurrent_buffer (), Fcons (bottom
, top
));
1115 save_restriction_restore (data
)
1118 register struct buffer
*buf
;
1119 register int newhead
, newtail
;
1120 register Lisp_Object tem
;
1122 buf
= XBUFFER (XCONS (data
)->car
);
1124 data
= XCONS (data
)->cdr
;
1126 tem
= XCONS (data
)->car
;
1127 newhead
= XINT (tem
);
1128 tem
= XCONS (data
)->cdr
;
1129 newtail
= XINT (tem
);
1130 if (newhead
+ newtail
> BUF_Z (buf
) - BUF_BEG (buf
))
1135 BUF_BEGV (buf
) = BUF_BEG (buf
) + newhead
;
1136 SET_BUF_ZV (buf
, BUF_Z (buf
) - newtail
);
1139 /* If point is outside the new visible range, move it inside. */
1141 clip_to_bounds (BUF_BEGV (buf
), BUF_PT (buf
), BUF_ZV (buf
)));
1146 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
1147 "Execute BODY, saving and restoring current buffer's restrictions.\n\
1148 The buffer's restrictions make parts of the beginning and end invisible.\n\
1149 \(They are set up with `narrow-to-region' and eliminated with `widen'.)\n\
1150 This special form, `save-restriction', saves the current buffer's restrictions\n\
1151 when it is entered, and restores them when it is exited.\n\
1152 So any `narrow-to-region' within BODY lasts only until the end of the form.\n\
1153 The old restrictions settings are restored\n\
1154 even in case of abnormal exit (throw or error).\n\
1156 The value returned is the value of the last form in BODY.\n\
1158 `save-restriction' can get confused if, within the BODY, you widen\n\
1159 and then make changes outside the area within the saved restrictions.\n\
1161 Note: if you are using both `save-excursion' and `save-restriction',\n\
1162 use `save-excursion' outermost:\n\
1163 (save-excursion (save-restriction ...))")
1167 register Lisp_Object val
;
1168 int count
= specpdl_ptr
- specpdl
;
1170 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
1171 val
= Fprogn (body
);
1172 return unbind_to (count
, val
);
1175 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
1176 "Print a one-line message at the bottom of the screen.\n\
1177 The first argument is a control string.\n\
1178 It may contain %s or %d or %c to print successive following arguments.\n\
1179 %s means print an argument as a string, %d means print as number in decimal,\n\
1180 %c means print a number as a single character.\n\
1181 The argument used by %s must be a string or a symbol;\n\
1182 the argument used by %d or %c must be a number.\n\
1183 If the first argument is nil, clear any existing message; let the\n\
1184 minibuffer contents show.")
1193 register Lisp_Object val
;
1194 val
= Fformat (nargs
, args
);
1195 message ("%s", XSTRING (val
)->data
);
1200 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
1201 "Format a string out of a control-string and arguments.\n\
1202 The first argument is a control string.\n\
1203 The other arguments are substituted into it to make the result, a string.\n\
1204 It may contain %-sequences meaning to substitute the next argument.\n\
1205 %s means print a string argument. Actually, prints any object, with `princ'.\n\
1206 %d means print as number in decimal (%o octal, %x hex).\n\
1207 %c means print a number as a single character.\n\
1208 %S means print any object as an s-expression (using prin1).\n\
1209 The argument used for %d, %o, %x or %c must be a number.\n\
1210 Use %% to put a single % into the output.")
1213 register Lisp_Object
*args
;
1215 register int n
; /* The number of the next arg to substitute */
1216 register int total
= 5; /* An estimate of the final length */
1218 register unsigned char *format
, *end
;
1220 extern char *index ();
1221 /* It should not be necessary to GCPRO ARGS, because
1222 the caller in the interpreter should take care of that. */
1224 CHECK_STRING (args
[0], 0);
1225 format
= XSTRING (args
[0])->data
;
1226 end
= format
+ XSTRING (args
[0])->size
;
1229 while (format
!= end
)
1230 if (*format
++ == '%')
1234 /* Process a numeric arg and skip it. */
1235 minlen
= atoi (format
);
1240 while ((*format
>= '0' && *format
<= '9')
1241 || *format
== '-' || *format
== ' ' || *format
== '.')
1246 else if (++n
>= nargs
)
1248 else if (*format
== 'S')
1250 /* For `S', prin1 the argument and then treat like a string. */
1251 register Lisp_Object tem
;
1252 tem
= Fprin1_to_string (args
[n
], Qnil
);
1256 else if (XTYPE (args
[n
]) == Lisp_Symbol
)
1258 XSET (args
[n
], Lisp_String
, XSYMBOL (args
[n
])->name
);
1261 else if (XTYPE (args
[n
]) == Lisp_String
)
1264 total
+= XSTRING (args
[n
])->size
;
1266 /* Would get MPV otherwise, since Lisp_Int's `point' to low memory. */
1267 else if (XTYPE (args
[n
]) == Lisp_Int
&& *format
!= 's')
1269 #ifdef LISP_FLOAT_TYPE
1270 /* The following loop issumes the Lisp type indicates
1271 the proper way to pass the argument.
1272 So make sure we have a flonum if the argument should
1274 if (*format
== 'e' || *format
== 'f' || *format
== 'g')
1275 args
[n
] = Ffloat (args
[n
]);
1279 #ifdef LISP_FLOAT_TYPE
1280 else if (XTYPE (args
[n
]) == Lisp_Float
&& *format
!= 's')
1282 if (! (*format
== 'e' || *format
== 'f' || *format
== 'g'))
1283 args
[n
] = Ftruncate (args
[n
]);
1289 /* Anything but a string, convert to a string using princ. */
1290 register Lisp_Object tem
;
1291 tem
= Fprin1_to_string (args
[n
], Qt
);
1298 register int nstrings
= n
+ 1;
1299 register unsigned char **strings
1300 = (unsigned char **) alloca (nstrings
* sizeof (unsigned char *));
1302 for (n
= 0; n
< nstrings
; n
++)
1305 strings
[n
] = (unsigned char *) "";
1306 else if (XTYPE (args
[n
]) == Lisp_Int
)
1307 /* We checked above that the corresponding format effector
1308 isn't %s, which would cause MPV. */
1309 strings
[n
] = (unsigned char *) XINT (args
[n
]);
1310 #ifdef LISP_FLOAT_TYPE
1311 else if (XTYPE (args
[n
]) == Lisp_Float
)
1313 union { double d
; int half
[2]; } u
;
1315 u
.d
= XFLOAT (args
[n
])->data
;
1316 strings
[n
++] = (unsigned char *) u
.half
[0];
1317 strings
[n
] = (unsigned char *) u
.half
[1];
1321 strings
[n
] = XSTRING (args
[n
])->data
;
1324 /* Format it in bigger and bigger buf's until it all fits. */
1327 buf
= (char *) alloca (total
+ 1);
1330 length
= doprnt (buf
, total
+ 1, strings
[0], end
, nargs
, strings
+ 1);
1331 if (buf
[total
- 1] == 0)
1339 return make_string (buf
, length
);
1345 format1 (string1
, arg0
, arg1
, arg2
, arg3
, arg4
)
1346 int arg0
, arg1
, arg2
, arg3
, arg4
;
1360 doprnt (buf
, sizeof buf
, string1
, 0, 5, args
);
1362 doprnt (buf
, sizeof buf
, string1
, 0, 5, &string1
+ 1);
1364 return build_string (buf
);
1367 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
1368 "Return t if two characters match, optionally ignoring case.\n\
1369 Both arguments must be characters (i.e. integers).\n\
1370 Case is ignored if `case-fold-search' is non-nil in the current buffer.")
1372 register Lisp_Object c1
, c2
;
1374 unsigned char *downcase
= DOWNCASE_TABLE
;
1375 CHECK_NUMBER (c1
, 0);
1376 CHECK_NUMBER (c2
, 1);
1378 if (!NILP (current_buffer
->case_fold_search
)
1379 ? downcase
[0xff & XFASTINT (c1
)] == downcase
[0xff & XFASTINT (c2
)]
1380 : XINT (c1
) == XINT (c2
))
1389 DEFVAR_LISP ("system-name", &Vsystem_name
,
1390 "The name of the machine Emacs is running on.");
1392 DEFVAR_LISP ("user-full-name", &Vuser_full_name
,
1393 "The full name of the user logged in.");
1395 DEFVAR_LISP ("user-name", &Vuser_name
,
1396 "The user's name, based on the effective uid.");
1398 DEFVAR_LISP ("user-real-name", &Vuser_real_name
,
1399 "The user's name, base upon the real uid.");
1401 defsubr (&Schar_equal
);
1402 defsubr (&Sgoto_char
);
1403 defsubr (&Sstring_to_char
);
1404 defsubr (&Schar_to_string
);
1405 defsubr (&Sbuffer_substring
);
1406 defsubr (&Sbuffer_string
);
1408 defsubr (&Spoint_marker
);
1409 defsubr (&Smark_marker
);
1411 defsubr (&Sregion_beginning
);
1412 defsubr (&Sregion_end
);
1413 /* defsubr (&Smark); */
1414 /* defsubr (&Sset_mark); */
1415 defsubr (&Ssave_excursion
);
1417 defsubr (&Sbufsize
);
1418 defsubr (&Spoint_max
);
1419 defsubr (&Spoint_min
);
1420 defsubr (&Spoint_min_marker
);
1421 defsubr (&Spoint_max_marker
);
1427 defsubr (&Sfollowing_char
);
1428 defsubr (&Sprevious_char
);
1429 defsubr (&Schar_after
);
1431 defsubr (&Sinsert_before_markers
);
1432 defsubr (&Sinsert_char
);
1434 defsubr (&Suser_login_name
);
1435 defsubr (&Suser_real_login_name
);
1436 defsubr (&Suser_uid
);
1437 defsubr (&Suser_real_uid
);
1438 defsubr (&Suser_full_name
);
1439 defsubr (&Scurrent_time
);
1440 defsubr (&Scurrent_time_string
);
1441 defsubr (&Scurrent_time_zone
);
1442 defsubr (&Ssystem_name
);
1443 defsubr (&Smessage
);
1446 defsubr (&Sinsert_buffer_substring
);
1447 defsubr (&Scompare_buffer_substrings
);
1448 defsubr (&Ssubst_char_in_region
);
1449 defsubr (&Stranslate_region
);
1450 defsubr (&Sdelete_region
);
1452 defsubr (&Snarrow_to_region
);
1453 defsubr (&Ssave_restriction
);