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. */
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 if (!NILP (Vtransient_mark_mode
) && NILP (current_buffer
->mark_active
))
200 error ("There is no region now");
201 m
= Fmarker_position (current_buffer
->mark
);
202 if (NILP (m
)) error ("There is no region now");
203 if ((point
< XFASTINT (m
)) == beginningp
)
204 return (make_number (point
));
209 DEFUN ("region-beginning", Fregion_beginning
, Sregion_beginning
, 0, 0, 0,
210 "Return position of beginning of region, as an integer.")
213 return (region_limit (1));
216 DEFUN ("region-end", Fregion_end
, Sregion_end
, 0, 0, 0,
217 "Return position of end of region, as an integer.")
220 return (region_limit (0));
223 #if 0 /* now in lisp code */
224 DEFUN ("mark", Fmark
, Smark
, 0, 0, 0,
225 "Return this buffer's mark value as integer, or nil if no mark.\n\
226 If you are using this in an editing command, you are most likely making\n\
227 a mistake; see the documentation of `set-mark'.")
230 return Fmarker_position (current_buffer
->mark
);
232 #endif /* commented out code */
234 DEFUN ("mark-marker", Fmark_marker
, Smark_marker
, 0, 0, 0,
235 "Return this buffer's mark, as a marker object.\n\
236 Watch out! Moving this marker changes the mark position.\n\
237 If you set the marker not to point anywhere, the buffer will have no mark.")
240 return current_buffer
->mark
;
243 #if 0 /* this is now in lisp code */
244 DEFUN ("set-mark", Fset_mark
, Sset_mark
, 1, 1, 0,
245 "Set this buffer's mark to POS. Don't use this function!\n\
246 That is to say, don't use this function unless you want\n\
247 the user to see that the mark has moved, and you want the previous\n\
248 mark position to be lost.\n\
250 Normally, when a new mark is set, the old one should go on the stack.\n\
251 This is why most applications should use push-mark, not set-mark.\n\
253 Novice programmers often try to use the mark for the wrong purposes.\n\
254 The mark saves a location for the user's convenience.\n\
255 Most editing commands should not alter the mark.\n\
256 To remember a location for internal use in the Lisp program,\n\
257 store it in a Lisp variable. Example:\n\
259 (let ((beg (point))) (forward-line 1) (delete-region beg (point))).")
265 current_buffer
->mark
= Qnil
;
268 CHECK_NUMBER_COERCE_MARKER (pos
, 0);
270 if (NILP (current_buffer
->mark
))
271 current_buffer
->mark
= Fmake_marker ();
273 Fset_marker (current_buffer
->mark
, pos
, Qnil
);
276 #endif /* commented-out code */
279 save_excursion_save ()
281 register int visible
= (XBUFFER (XWINDOW (selected_window
)->buffer
)
284 return Fcons (Fpoint_marker (),
285 Fcons (Fcopy_marker (current_buffer
->mark
),
286 Fcons (visible
? Qt
: Qnil
,
287 current_buffer
->mark_active
)));
291 save_excursion_restore (info
)
292 register Lisp_Object info
;
294 register Lisp_Object tem
, tem1
;
296 tem
= Fmarker_buffer (Fcar (info
));
297 /* If buffer being returned to is now deleted, avoid error */
298 /* Otherwise could get error here while unwinding to top level
300 /* In that case, Fmarker_buffer returns nil now. */
306 unchain_marker (tem
);
307 tem
= Fcar (Fcdr (info
));
308 Fset_marker (current_buffer
->mark
, tem
, Fcurrent_buffer ());
309 unchain_marker (tem
);
310 tem
= Fcdr (Fcdr (info
));
313 && current_buffer
!= XBUFFER (XWINDOW (selected_window
)->buffer
))
314 Fswitch_to_buffer (Fcurrent_buffer (), Qnil
);
316 tem1
= current_buffer
->mark_active
;
317 current_buffer
->mark_active
= Fcdr (tem
);
318 if (! NILP (current_buffer
->mark_active
))
319 call1 (Vrun_hooks
, intern ("activate-mark-hook"));
320 else if (! NILP (tem1
))
321 call1 (Vrun_hooks
, intern ("deactivate-mark-hook"));
325 DEFUN ("save-excursion", Fsave_excursion
, Ssave_excursion
, 0, UNEVALLED
, 0,
326 "Save point, mark, and current buffer; execute BODY; restore those things.\n\
327 Executes BODY just like `progn'.\n\
328 The values of point, mark and the current buffer are restored\n\
329 even in case of abnormal exit (throw or error).\n\
330 The state of activation of the mark is also restored.")
334 register Lisp_Object val
;
335 int count
= specpdl_ptr
- specpdl
;
337 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
340 return unbind_to (count
, val
);
343 DEFUN ("buffer-size", Fbufsize
, Sbufsize
, 0, 0, 0,
344 "Return the number of characters in the current buffer.")
348 XFASTINT (temp
) = Z
- BEG
;
352 DEFUN ("point-min", Fpoint_min
, Spoint_min
, 0, 0, 0,
353 "Return the minimum permissible value of point in the current buffer.\n\
354 This is 1, unless a clipping restriction is in effect.")
358 XFASTINT (temp
) = BEGV
;
362 DEFUN ("point-min-marker", Fpoint_min_marker
, Spoint_min_marker
, 0, 0, 0,
363 "Return a marker to the minimum permissible value of point in this buffer.\n\
364 This is the beginning, unless a clipping restriction is in effect.")
367 return buildmark (BEGV
);
370 DEFUN ("point-max", Fpoint_max
, Spoint_max
, 0, 0, 0,
371 "Return the maximum permissible value of point in the current buffer.\n\
372 This is (1+ (buffer-size)), unless a clipping restriction is in effect,\n\
373 in which case it is less.")
377 XFASTINT (temp
) = ZV
;
381 DEFUN ("point-max-marker", Fpoint_max_marker
, Spoint_max_marker
, 0, 0, 0,
382 "Return a marker to the maximum permissible value of point in this buffer.\n\
383 This is (1+ (buffer-size)), unless a clipping restriction is in effect,\n\
384 in which case it is less.")
387 return buildmark (ZV
);
390 DEFUN ("following-char", Ffollowing_char
, Sfollowing_char
, 0, 0, 0,
391 "Return the character following point, as a number.\n\
392 At the end of the buffer or accessible region, return 0.")
399 XFASTINT (temp
) = FETCH_CHAR (point
);
403 DEFUN ("preceding-char", Fprevious_char
, Sprevious_char
, 0, 0, 0,
404 "Return the character preceding point, as a number.\n\
405 At the beginning of the buffer or accessible region, return 0.")
412 XFASTINT (temp
) = FETCH_CHAR (point
- 1);
416 DEFUN ("bobp", Fbobp
, Sbobp
, 0, 0, 0,
417 "Return T if point is at the beginning of the buffer.\n\
418 If the buffer is narrowed, this means the beginning of the narrowed part.")
426 DEFUN ("eobp", Feobp
, Seobp
, 0, 0, 0,
427 "Return T if point is at the end of the buffer.\n\
428 If the buffer is narrowed, this means the end of the narrowed part.")
436 DEFUN ("bolp", Fbolp
, Sbolp
, 0, 0, 0,
437 "Return T if point is at the beginning of a line.")
440 if (point
== BEGV
|| FETCH_CHAR (point
- 1) == '\n')
445 DEFUN ("eolp", Feolp
, Seolp
, 0, 0, 0,
446 "Return T if point is at the end of a line.\n\
447 `End of a line' includes point being at the end of the buffer.")
450 if (point
== ZV
|| FETCH_CHAR (point
) == '\n')
455 DEFUN ("char-after", Fchar_after
, Schar_after
, 1, 1, 0,
456 "Return character in current buffer at position POS.\n\
457 POS is an integer or a buffer pointer.\n\
458 If POS is out of range, the value is nil.")
462 register Lisp_Object val
;
465 CHECK_NUMBER_COERCE_MARKER (pos
, 0);
468 if (n
< BEGV
|| n
>= ZV
) return Qnil
;
470 XFASTINT (val
) = FETCH_CHAR (n
);
474 DEFUN ("user-login-name", Fuser_login_name
, Suser_login_name
, 0, 0, 0,
475 "Return the name under which the user logged in, as a string.\n\
476 This is based on the effective uid, not the real uid.\n\
477 Also, if the environment variable USER or LOGNAME is set,\n\
478 that determines the value of this function.")
484 DEFUN ("user-real-login-name", Fuser_real_login_name
, Suser_real_login_name
,
486 "Return the name of the user's real uid, as a string.\n\
487 Differs from `user-login-name' when running under `su'.")
490 return Vuser_real_name
;
493 DEFUN ("user-uid", Fuser_uid
, Suser_uid
, 0, 0, 0,
494 "Return the effective uid of Emacs, as an integer.")
497 return make_number (geteuid ());
500 DEFUN ("user-real-uid", Fuser_real_uid
, Suser_real_uid
, 0, 0, 0,
501 "Return the real uid of Emacs, as an integer.")
504 return make_number (getuid ());
507 DEFUN ("user-full-name", Fuser_full_name
, Suser_full_name
, 0, 0, 0,
508 "Return the full name of the user logged in, as a string.")
511 return Vuser_full_name
;
514 DEFUN ("system-name", Fsystem_name
, Ssystem_name
, 0, 0, 0,
515 "Return the name of the machine you are running on, as a string.")
521 DEFUN ("current-time", Fcurrent_time
, Scurrent_time
, 0, 0, 0,
522 "Return the current time, as the number of seconds since 12:00 AM January 1970.\n\
523 The time is returned as a list of three integers. The first has the\n\
524 most significant 16 bits of the seconds, while the second has the\n\
525 least significant 16 bits. The third integer gives the microsecond\n\
528 The microsecond count is zero on systems that do not provide\n\
529 resolution finer than a second.")
533 Lisp_Object result
[3];
536 XSET (result
[0], Lisp_Int
, (EMACS_SECS (t
) >> 16) & 0xffff);
537 XSET (result
[1], Lisp_Int
, (EMACS_SECS (t
) >> 0) & 0xffff);
538 XSET (result
[2], Lisp_Int
, EMACS_USECS (t
));
540 return Flist (3, result
);
544 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
, 0, 0, 0,
545 "Return the current time, as a human-readable string.\n\
546 Programs can use it too, since the number of columns in each field is fixed.\n\
547 The format is `Sun Sep 16 01:03:52 1973'.")
550 long current_time
= time ((long *) 0);
552 register char *tem
= (char *) ctime (¤t_time
);
554 strncpy (buf
, tem
, 24);
557 return build_string (buf
);
560 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 0, 0,
561 "Return the offset, savings state, and names for the current time zone.\n\
562 This returns a list of the form (OFFSET SAVINGS-FLAG STANDARD SAVINGS).\n\
563 OFFSET is an integer specifying how many minutes east of Greenwich the\n\
564 current time zone is located. A negative value means west of\n\
565 Greenwich. Note that this describes the standard time; if daylight\n\
566 savings time is in effect, it does not affect this value.\n\
567 SAVINGS-FLAG is non-nil iff daylight savings time or some other sort\n\
568 of seasonal time adjustment is in effect.\n\
569 STANDARD is a string giving the name of the time zone when no seasonal\n\
570 time adjustment is in effect.\n\
571 SAVINGS is a string giving the name of the time zone when there is a\n\
572 seasonal time adjustment in effect.\n\
573 If the local area does not use a seasonal time adjustment,\n\
574 SAVINGS-FLAG is always nil, and STANDARD and SAVINGS are equal.")
577 #ifdef EMACS_CURRENT_TIME_ZONE
578 int offset
, savings_flag
;
582 EMACS_CURRENT_TIME_ZONE (&offset
, &savings_flag
, standard
, savings
);
584 return Fcons (make_number (offset
),
585 Fcons ((savings_flag
? Qt
: Qnil
),
586 Fcons (build_string (standard
),
587 Fcons (build_string (savings
),
591 ("current-time-zone has not been implemented on this operating system.");
604 /* Callers passing one argument to Finsert need not gcpro the
605 argument "array", since the only element of the array will
606 not be used after calling insert or insert_from_string, so
607 we don't care if it gets trashed. */
609 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
610 "Insert the arguments, either strings or characters, at point.\n\
611 Point moves forward so that it ends up after the inserted text.\n\
612 Any other markers at the point of insertion remain before the text.")
615 register Lisp_Object
*args
;
618 register Lisp_Object tem
;
621 for (argnum
= 0; argnum
< nargs
; argnum
++)
625 if (XTYPE (tem
) == Lisp_Int
)
630 else if (XTYPE (tem
) == Lisp_String
)
632 insert_from_string (tem
, 0, XSTRING (tem
)->size
);
636 tem
= wrong_type_argument (Qchar_or_string_p
, tem
);
644 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
645 "Insert strings or characters at point, relocating markers after the text.\n\
646 Point moves forward so that it ends up after the inserted text.\n\
647 Any other markers at the point of insertion also end up after the text.")
650 register Lisp_Object
*args
;
653 register Lisp_Object tem
;
656 for (argnum
= 0; argnum
< nargs
; argnum
++)
660 if (XTYPE (tem
) == Lisp_Int
)
663 insert_before_markers (str
, 1);
665 else if (XTYPE (tem
) == Lisp_String
)
667 insert_from_string_before_markers (tem
, 0, XSTRING (tem
)->size
);
671 tem
= wrong_type_argument (Qchar_or_string_p
, tem
);
679 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 2, 2, 0,
680 "Insert COUNT (second arg) copies of CHAR (first arg).\n\
681 Point and all markers are affected as in the function `insert'.\n\
682 Both arguments are required.")
684 Lisp_Object chr
, count
;
686 register unsigned char *string
;
690 CHECK_NUMBER (chr
, 0);
691 CHECK_NUMBER (count
, 1);
696 strlen
= min (n
, 256);
697 string
= (unsigned char *) alloca (strlen
);
698 for (i
= 0; i
< strlen
; i
++)
699 string
[i
] = XFASTINT (chr
);
702 insert (string
, strlen
);
711 /* Making strings from buffer contents. */
713 /* Return a Lisp_String containing the text of the current buffer from
714 START to END. If text properties are in use and the current buffer
715 has properties in the range specifed, the resulting string will also
718 We don't want to use plain old make_string here, because it calls
719 make_uninit_string, which can cause the buffer arena to be
720 compacted. make_string has no way of knowing that the data has
721 been moved, and thus copies the wrong data into the string. This
722 doesn't effect most of the other users of make_string, so it should
723 be left as is. But we should use this function when conjuring
724 buffer substrings. */
727 make_buffer_string (start
, end
)
732 if (start
< GPT
&& GPT
< end
)
735 result
= make_uninit_string (end
- start
);
736 bcopy (&FETCH_CHAR (start
), XSTRING (result
)->data
, end
- start
);
738 /* Only defined if Emacs is compiled with USE_TEXT_PROPERTIES */
739 copy_intervals_to_string (result
, current_buffer
, start
, end
- start
);
744 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
745 "Return the contents of part of the current buffer as a string.\n\
746 The two arguments START and END are character positions;\n\
747 they can be in either order.")
751 register int beg
, end
;
753 validate_region (&b
, &e
);
757 return make_buffer_string (beg
, end
);
760 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
761 "Return the contents of the current buffer as a string.")
764 return make_buffer_string (BEGV
, ZV
);
767 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
769 "Insert before point a substring of the contents buffer BUFFER.\n\
770 BUFFER may be a buffer or a buffer name.\n\
771 Arguments START and END are character numbers specifying the substring.\n\
772 They default to the beginning and the end of BUFFER.")
774 Lisp_Object buf
, b
, e
;
776 register int beg
, end
, temp
, len
, opoint
, start
;
777 register struct buffer
*bp
;
780 buffer
= Fget_buffer (buf
);
783 bp
= XBUFFER (buffer
);
789 CHECK_NUMBER_COERCE_MARKER (b
, 0);
796 CHECK_NUMBER_COERCE_MARKER (e
, 1);
801 temp
= beg
, beg
= end
, end
= temp
;
803 /* Move the gap or create enough gap in the current buffer. */
807 if (GAP_SIZE
< end
- beg
)
808 make_gap (end
- beg
- GAP_SIZE
);
814 if (!(BUF_BEGV (bp
) <= beg
816 && end
<= BUF_ZV (bp
)))
817 args_out_of_range (b
, e
);
819 /* Now the actual insertion will not do any gap motion,
820 so it matters not if BUF is the current buffer. */
821 if (beg
< BUF_GPT (bp
))
823 insert (BUF_CHAR_ADDRESS (bp
, beg
), min (end
, BUF_GPT (bp
)) - beg
);
824 beg
= min (end
, BUF_GPT (bp
));
827 insert (BUF_CHAR_ADDRESS (bp
, beg
), end
- beg
);
829 /* Only defined if Emacs is compiled with USE_TEXT_PROPERTIES */
830 graft_intervals_into_buffer (copy_intervals (bp
->intervals
, start
, len
),
836 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
838 "Compare two substrings of two buffers; return result as number.\n\
839 the value is -N if first string is less after N-1 chars,\n\
840 +N if first string is greater after N-1 chars, or 0 if strings match.\n\
841 Each substring is represented as three arguments: BUFFER, START and END.\n\
842 That makes six args in all, three for each substring.\n\n\
843 The value of `case-fold-search' in the current buffer\n\
844 determines whether case is significant or ignored.")
845 (buffer1
, start1
, end1
, buffer2
, start2
, end2
)
846 Lisp_Object buffer1
, start1
, end1
, buffer2
, start2
, end2
;
848 register int begp1
, endp1
, begp2
, endp2
, temp
, len1
, len2
, length
, i
;
849 register struct buffer
*bp1
, *bp2
;
850 register unsigned char *trt
851 = (!NILP (current_buffer
->case_fold_search
)
852 ? XSTRING (current_buffer
->case_canon_table
)->data
: 0);
854 /* Find the first buffer and its substring. */
857 bp1
= current_buffer
;
861 buf1
= Fget_buffer (buffer1
);
864 bp1
= XBUFFER (buf1
);
868 begp1
= BUF_BEGV (bp1
);
871 CHECK_NUMBER_COERCE_MARKER (start1
, 1);
872 begp1
= XINT (start1
);
875 endp1
= BUF_ZV (bp1
);
878 CHECK_NUMBER_COERCE_MARKER (end1
, 2);
883 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
885 if (!(BUF_BEGV (bp1
) <= begp1
887 && endp1
<= BUF_ZV (bp1
)))
888 args_out_of_range (start1
, end1
);
890 /* Likewise for second substring. */
893 bp2
= current_buffer
;
897 buf2
= Fget_buffer (buffer2
);
900 bp2
= XBUFFER (buffer2
);
904 begp2
= BUF_BEGV (bp2
);
907 CHECK_NUMBER_COERCE_MARKER (start2
, 4);
908 begp2
= XINT (start2
);
911 endp2
= BUF_ZV (bp2
);
914 CHECK_NUMBER_COERCE_MARKER (end2
, 5);
919 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
921 if (!(BUF_BEGV (bp2
) <= begp2
923 && endp2
<= BUF_ZV (bp2
)))
924 args_out_of_range (start2
, end2
);
926 len1
= endp1
- begp1
;
927 len2
= endp2
- begp2
;
932 for (i
= 0; i
< length
; i
++)
934 int c1
= *BUF_CHAR_ADDRESS (bp1
, begp1
+ i
);
935 int c2
= *BUF_CHAR_ADDRESS (bp2
, begp2
+ i
);
942 return make_number (- 1 - i
);
944 return make_number (i
+ 1);
947 /* The strings match as far as they go.
948 If one is shorter, that one is less. */
950 return make_number (length
+ 1);
951 else if (length
< len2
)
952 return make_number (- length
- 1);
954 /* Same length too => they are equal. */
955 return make_number (0);
958 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
959 Ssubst_char_in_region
, 4, 5, 0,
960 "From START to END, replace FROMCHAR with TOCHAR each time it occurs.\n\
961 If optional arg NOUNDO is non-nil, don't record this change for undo\n\
962 and don't mark the buffer as really changed.")
963 (start
, end
, fromchar
, tochar
, noundo
)
964 Lisp_Object start
, end
, fromchar
, tochar
, noundo
;
966 register int pos
, stop
, look
;
968 validate_region (&start
, &end
);
969 CHECK_NUMBER (fromchar
, 2);
970 CHECK_NUMBER (tochar
, 3);
974 look
= XINT (fromchar
);
976 modify_region (pos
, stop
);
979 if (MODIFF
- 1 == current_buffer
->save_modified
)
980 current_buffer
->save_modified
++;
981 if (MODIFF
- 1 == current_buffer
->auto_save_modified
)
982 current_buffer
->auto_save_modified
++;
987 if (FETCH_CHAR (pos
) == look
)
990 record_change (pos
, 1);
991 FETCH_CHAR (pos
) = XINT (tochar
);
993 signal_after_change (pos
, 1, 1);
1001 DEFUN ("translate-region", Ftranslate_region
, Stranslate_region
, 3, 3, 0,
1002 "From START to END, translate characters according to TABLE.\n\
1003 TABLE is a string; the Nth character in it is the mapping\n\
1004 for the character with code N. Returns the number of characters changed.")
1008 register Lisp_Object table
;
1010 register int pos
, stop
; /* Limits of the region. */
1011 register unsigned char *tt
; /* Trans table. */
1012 register int oc
; /* Old character. */
1013 register int nc
; /* New character. */
1014 int cnt
; /* Number of changes made. */
1015 Lisp_Object z
; /* Return. */
1016 int size
; /* Size of translate table. */
1018 validate_region (&start
, &end
);
1019 CHECK_STRING (table
, 2);
1021 size
= XSTRING (table
)->size
;
1022 tt
= XSTRING (table
)->data
;
1026 modify_region (pos
, stop
);
1029 for (; pos
< stop
; ++pos
)
1031 oc
= FETCH_CHAR (pos
);
1037 record_change (pos
, 1);
1038 FETCH_CHAR (pos
) = nc
;
1039 signal_after_change (pos
, 1, 1);
1049 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
1050 "Delete the text between point and mark.\n\
1051 When called from a program, expects two arguments,\n\
1052 positions (integers or markers) specifying the stretch to be deleted.")
1056 validate_region (&b
, &e
);
1057 del_range (XINT (b
), XINT (e
));
1061 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
1062 "Remove restrictions (narrowing) from current buffer.\n\
1063 This allows the buffer's full text to be seen and edited.")
1067 SET_BUF_ZV (current_buffer
, Z
);
1069 /* Changing the buffer bounds invalidates any recorded current column. */
1070 invalidate_current_column ();
1074 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
1075 "Restrict editing in this buffer to the current region.\n\
1076 The rest of the text becomes temporarily invisible and untouchable\n\
1077 but is not deleted; if you save the buffer in a file, the invisible\n\
1078 text is included in the file. \\[widen] makes all visible again.\n\
1079 See also `save-restriction'.\n\
1081 When calling from a program, pass two arguments; positions (integers\n\
1082 or markers) bounding the text that should remain visible.")
1084 register Lisp_Object b
, e
;
1088 CHECK_NUMBER_COERCE_MARKER (b
, 0);
1089 CHECK_NUMBER_COERCE_MARKER (e
, 1);
1091 if (XINT (b
) > XINT (e
))
1098 if (!(BEG
<= XINT (b
) && XINT (b
) <= XINT (e
) && XINT (e
) <= Z
))
1099 args_out_of_range (b
, e
);
1101 BEGV
= XFASTINT (b
);
1102 SET_BUF_ZV (current_buffer
, XFASTINT (e
));
1103 if (point
< XFASTINT (b
))
1104 SET_PT (XFASTINT (b
));
1105 if (point
> XFASTINT (e
))
1106 SET_PT (XFASTINT (e
));
1108 /* Changing the buffer bounds invalidates any recorded current column. */
1109 invalidate_current_column ();
1114 save_restriction_save ()
1116 register Lisp_Object bottom
, top
;
1117 /* Note: I tried using markers here, but it does not win
1118 because insertion at the end of the saved region
1119 does not advance mh and is considered "outside" the saved region. */
1120 XFASTINT (bottom
) = BEGV
- BEG
;
1121 XFASTINT (top
) = Z
- ZV
;
1123 return Fcons (Fcurrent_buffer (), Fcons (bottom
, top
));
1127 save_restriction_restore (data
)
1130 register struct buffer
*buf
;
1131 register int newhead
, newtail
;
1132 register Lisp_Object tem
;
1134 buf
= XBUFFER (XCONS (data
)->car
);
1136 data
= XCONS (data
)->cdr
;
1138 tem
= XCONS (data
)->car
;
1139 newhead
= XINT (tem
);
1140 tem
= XCONS (data
)->cdr
;
1141 newtail
= XINT (tem
);
1142 if (newhead
+ newtail
> BUF_Z (buf
) - BUF_BEG (buf
))
1147 BUF_BEGV (buf
) = BUF_BEG (buf
) + newhead
;
1148 SET_BUF_ZV (buf
, BUF_Z (buf
) - newtail
);
1151 /* If point is outside the new visible range, move it inside. */
1153 clip_to_bounds (BUF_BEGV (buf
), BUF_PT (buf
), BUF_ZV (buf
)));
1158 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
1159 "Execute BODY, saving and restoring current buffer's restrictions.\n\
1160 The buffer's restrictions make parts of the beginning and end invisible.\n\
1161 \(They are set up with `narrow-to-region' and eliminated with `widen'.)\n\
1162 This special form, `save-restriction', saves the current buffer's restrictions\n\
1163 when it is entered, and restores them when it is exited.\n\
1164 So any `narrow-to-region' within BODY lasts only until the end of the form.\n\
1165 The old restrictions settings are restored\n\
1166 even in case of abnormal exit (throw or error).\n\
1168 The value returned is the value of the last form in BODY.\n\
1170 `save-restriction' can get confused if, within the BODY, you widen\n\
1171 and then make changes outside the area within the saved restrictions.\n\
1173 Note: if you are using both `save-excursion' and `save-restriction',\n\
1174 use `save-excursion' outermost:\n\
1175 (save-excursion (save-restriction ...))")
1179 register Lisp_Object val
;
1180 int count
= specpdl_ptr
- specpdl
;
1182 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
1183 val
= Fprogn (body
);
1184 return unbind_to (count
, val
);
1187 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
1188 "Print a one-line message at the bottom of the screen.\n\
1189 The first argument is a control string.\n\
1190 It may contain %s or %d or %c to print successive following arguments.\n\
1191 %s means print an argument as a string, %d means print as number in decimal,\n\
1192 %c means print a number as a single character.\n\
1193 The argument used by %s must be a string or a symbol;\n\
1194 the argument used by %d or %c must be a number.\n\
1195 If the first argument is nil, clear any existing message; let the\n\
1196 minibuffer contents show.")
1208 register Lisp_Object val
;
1209 val
= Fformat (nargs
, args
);
1210 message ("%s", XSTRING (val
)->data
);
1215 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
1216 "Format a string out of a control-string and arguments.\n\
1217 The first argument is a control string.\n\
1218 The other arguments are substituted into it to make the result, a string.\n\
1219 It may contain %-sequences meaning to substitute the next argument.\n\
1220 %s means print a string argument. Actually, prints any object, with `princ'.\n\
1221 %d means print as number in decimal (%o octal, %x hex).\n\
1222 %c means print a number as a single character.\n\
1223 %S means print any object as an s-expression (using prin1).\n\
1224 The argument used for %d, %o, %x or %c must be a number.\n\
1225 Use %% to put a single % into the output.")
1228 register Lisp_Object
*args
;
1230 register int n
; /* The number of the next arg to substitute */
1231 register int total
= 5; /* An estimate of the final length */
1233 register unsigned char *format
, *end
;
1235 extern char *index ();
1236 /* It should not be necessary to GCPRO ARGS, because
1237 the caller in the interpreter should take care of that. */
1239 CHECK_STRING (args
[0], 0);
1240 format
= XSTRING (args
[0])->data
;
1241 end
= format
+ XSTRING (args
[0])->size
;
1244 while (format
!= end
)
1245 if (*format
++ == '%')
1249 /* Process a numeric arg and skip it. */
1250 minlen
= atoi (format
);
1255 while ((*format
>= '0' && *format
<= '9')
1256 || *format
== '-' || *format
== ' ' || *format
== '.')
1261 else if (++n
>= nargs
)
1263 else if (*format
== 'S')
1265 /* For `S', prin1 the argument and then treat like a string. */
1266 register Lisp_Object tem
;
1267 tem
= Fprin1_to_string (args
[n
], Qnil
);
1271 else if (XTYPE (args
[n
]) == Lisp_Symbol
)
1273 XSET (args
[n
], Lisp_String
, XSYMBOL (args
[n
])->name
);
1276 else if (XTYPE (args
[n
]) == Lisp_String
)
1279 total
+= XSTRING (args
[n
])->size
;
1281 /* Would get MPV otherwise, since Lisp_Int's `point' to low memory. */
1282 else if (XTYPE (args
[n
]) == Lisp_Int
&& *format
!= 's')
1284 #ifdef LISP_FLOAT_TYPE
1285 /* The following loop issumes the Lisp type indicates
1286 the proper way to pass the argument.
1287 So make sure we have a flonum if the argument should
1289 if (*format
== 'e' || *format
== 'f' || *format
== 'g')
1290 args
[n
] = Ffloat (args
[n
]);
1294 #ifdef LISP_FLOAT_TYPE
1295 else if (XTYPE (args
[n
]) == Lisp_Float
&& *format
!= 's')
1297 if (! (*format
== 'e' || *format
== 'f' || *format
== 'g'))
1298 args
[n
] = Ftruncate (args
[n
]);
1304 /* Anything but a string, convert to a string using princ. */
1305 register Lisp_Object tem
;
1306 tem
= Fprin1_to_string (args
[n
], Qt
);
1313 register int nstrings
= n
+ 1;
1314 register unsigned char **strings
1315 = (unsigned char **) alloca (nstrings
* sizeof (unsigned char *));
1317 for (n
= 0; n
< nstrings
; n
++)
1320 strings
[n
] = (unsigned char *) "";
1321 else if (XTYPE (args
[n
]) == Lisp_Int
)
1322 /* We checked above that the corresponding format effector
1323 isn't %s, which would cause MPV. */
1324 strings
[n
] = (unsigned char *) XINT (args
[n
]);
1325 #ifdef LISP_FLOAT_TYPE
1326 else if (XTYPE (args
[n
]) == Lisp_Float
)
1328 union { double d
; int half
[2]; } u
;
1330 u
.d
= XFLOAT (args
[n
])->data
;
1331 strings
[n
++] = (unsigned char *) u
.half
[0];
1332 strings
[n
] = (unsigned char *) u
.half
[1];
1336 strings
[n
] = XSTRING (args
[n
])->data
;
1339 /* Format it in bigger and bigger buf's until it all fits. */
1342 buf
= (char *) alloca (total
+ 1);
1345 length
= doprnt (buf
, total
+ 1, strings
[0], end
, nargs
, strings
+ 1);
1346 if (buf
[total
- 1] == 0)
1354 return make_string (buf
, length
);
1360 format1 (string1
, arg0
, arg1
, arg2
, arg3
, arg4
)
1361 int arg0
, arg1
, arg2
, arg3
, arg4
;
1375 doprnt (buf
, sizeof buf
, string1
, 0, 5, args
);
1377 doprnt (buf
, sizeof buf
, string1
, 0, 5, &string1
+ 1);
1379 return build_string (buf
);
1382 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
1383 "Return t if two characters match, optionally ignoring case.\n\
1384 Both arguments must be characters (i.e. integers).\n\
1385 Case is ignored if `case-fold-search' is non-nil in the current buffer.")
1387 register Lisp_Object c1
, c2
;
1389 unsigned char *downcase
= DOWNCASE_TABLE
;
1390 CHECK_NUMBER (c1
, 0);
1391 CHECK_NUMBER (c2
, 1);
1393 if (!NILP (current_buffer
->case_fold_search
)
1394 ? downcase
[0xff & XFASTINT (c1
)] == downcase
[0xff & XFASTINT (c2
)]
1395 : XINT (c1
) == XINT (c2
))
1404 DEFVAR_LISP ("system-name", &Vsystem_name
,
1405 "The name of the machine Emacs is running on.");
1407 DEFVAR_LISP ("user-full-name", &Vuser_full_name
,
1408 "The full name of the user logged in.");
1410 DEFVAR_LISP ("user-name", &Vuser_name
,
1411 "The user's name, based on the effective uid.");
1413 DEFVAR_LISP ("user-real-name", &Vuser_real_name
,
1414 "The user's name, base upon the real uid.");
1416 defsubr (&Schar_equal
);
1417 defsubr (&Sgoto_char
);
1418 defsubr (&Sstring_to_char
);
1419 defsubr (&Schar_to_string
);
1420 defsubr (&Sbuffer_substring
);
1421 defsubr (&Sbuffer_string
);
1423 defsubr (&Spoint_marker
);
1424 defsubr (&Smark_marker
);
1426 defsubr (&Sregion_beginning
);
1427 defsubr (&Sregion_end
);
1428 /* defsubr (&Smark); */
1429 /* defsubr (&Sset_mark); */
1430 defsubr (&Ssave_excursion
);
1432 defsubr (&Sbufsize
);
1433 defsubr (&Spoint_max
);
1434 defsubr (&Spoint_min
);
1435 defsubr (&Spoint_min_marker
);
1436 defsubr (&Spoint_max_marker
);
1442 defsubr (&Sfollowing_char
);
1443 defsubr (&Sprevious_char
);
1444 defsubr (&Schar_after
);
1446 defsubr (&Sinsert_before_markers
);
1447 defsubr (&Sinsert_char
);
1449 defsubr (&Suser_login_name
);
1450 defsubr (&Suser_real_login_name
);
1451 defsubr (&Suser_uid
);
1452 defsubr (&Suser_real_uid
);
1453 defsubr (&Suser_full_name
);
1454 defsubr (&Scurrent_time
);
1455 defsubr (&Scurrent_time_string
);
1456 defsubr (&Scurrent_time_zone
);
1457 defsubr (&Ssystem_name
);
1458 defsubr (&Smessage
);
1461 defsubr (&Sinsert_buffer_substring
);
1462 defsubr (&Scompare_buffer_substrings
);
1463 defsubr (&Ssubst_char_in_region
);
1464 defsubr (&Stranslate_region
);
1465 defsubr (&Sdelete_region
);
1467 defsubr (&Snarrow_to_region
);
1468 defsubr (&Ssave_restriction
);