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
);
545 lisp_time_argument (specified_time
, result
)
546 Lisp_Object specified_time
;
549 if (NILP (specified_time
))
550 return time (result
) != -1;
553 Lisp_Object high
, low
;
554 high
= Fcar (specified_time
);
555 CHECK_NUMBER (high
, 0);
556 low
= Fcdr (specified_time
);
557 if (XTYPE (low
) == Lisp_Cons
)
559 CHECK_NUMBER (low
, 0);
560 *result
= (XINT (high
) << 16) + (XINT (low
) & 0xffff);
561 return *result
>> 16 == XINT (high
);
565 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
, 0, 1, 0,
566 "Return the current time, as a human-readable string.\n\
567 Programs can use this function to decode a time,\n\
568 since the number of columns in each field is fixed.\n\
569 The format is `Sun Sep 16 01:03:52 1973'.\n\
570 If an argument is given, it specifies a time to format\n\
571 instead of the current time. The argument should have the form:\n\
574 (HIGH LOW . IGNORED).\n\
575 Thus, you can use times obtained from `current-time'\n\
576 and from `file-attributes'.")
578 Lisp_Object specified_time
;
584 if (! lisp_time_argument (specified_time
, &value
))
586 tem
= (char *) ctime (&value
);
588 strncpy (buf
, tem
, 24);
591 return build_string (buf
);
594 #define TM_YEAR_ORIGIN 1900
596 /* Yield A - B, measured in seconds. */
601 int ay
= a
->tm_year
+ (TM_YEAR_ORIGIN
- 1);
602 int by
= b
->tm_year
+ (TM_YEAR_ORIGIN
- 1);
607 /* difference in day of year */
608 a
->tm_yday
- b
->tm_yday
609 /* + intervening leap days */
610 + ((ay
>> 2) - (by
>> 2))
612 + ((ay
/100 >> 2) - (by
/100 >> 2))
613 /* + difference in years * 365 */
614 + (long)(ay
-by
) * 365
615 )*24 + (a
->tm_hour
- b
->tm_hour
)
616 )*60 + (a
->tm_min
- b
->tm_min
)
617 )*60 + (a
->tm_sec
- b
->tm_sec
);
620 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 1, 0,
621 "Return the offset and name for the local time zone.\n\
622 This returns a list of the form (OFFSET NAME).\n\
623 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).\n\
624 A negative value means west of Greenwich.\n\
625 NAME is a string giving the name of the time zone.\n\
626 If an argument is given, it specifies when the time zone offset is determined\n\
627 instead of using the current time. The argument should have the form:\n\
630 (HIGH LOW . IGNORED).\n\
631 Thus, you can use times obtained from `current-time'\n\
632 and from `file-attributes'.\n\
634 Some operating systems cannot provide all this information to Emacs;\n\
635 in this case, current-time-zone will return a list containing nil for\n\
636 the data it can't find.")
638 Lisp_Object specified_time
;
643 if (lisp_time_argument (specified_time
, &value
)
644 && (t
= gmtime(&value
)) != 0)
646 struct tm gmt
= *t
; /* Make a copy, in case localtime modifies *t. */
649 t
= localtime(&value
);
650 offset
= difftm(t
, &gmt
);
658 /* No local time zone name is available; use "+-NNNN" instead. */
659 long am
= (offset
< 0 ? -offset
: offset
) / 60;
660 sprintf (buf
, "%c%02d%02d", (offset
< 0 ? '-' : '+'), am
/60, am
%60);
663 return Fcons (make_number (offset
), Fcons (build_string (s
), Qnil
));
666 return Fmake_list (2, Qnil
);
678 /* Callers passing one argument to Finsert need not gcpro the
679 argument "array", since the only element of the array will
680 not be used after calling insert or insert_from_string, so
681 we don't care if it gets trashed. */
683 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
684 "Insert the arguments, either strings or characters, at point.\n\
685 Point moves forward so that it ends up after the inserted text.\n\
686 Any other markers at the point of insertion remain before the text.")
689 register Lisp_Object
*args
;
692 register Lisp_Object tem
;
695 for (argnum
= 0; argnum
< nargs
; argnum
++)
699 if (XTYPE (tem
) == Lisp_Int
)
704 else if (XTYPE (tem
) == Lisp_String
)
706 insert_from_string (tem
, 0, XSTRING (tem
)->size
);
710 tem
= wrong_type_argument (Qchar_or_string_p
, tem
);
718 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
719 "Insert strings or characters at point, relocating markers after the text.\n\
720 Point moves forward so that it ends up after the inserted text.\n\
721 Any other markers at the point of insertion also end up after the text.")
724 register Lisp_Object
*args
;
727 register Lisp_Object tem
;
730 for (argnum
= 0; argnum
< nargs
; argnum
++)
734 if (XTYPE (tem
) == Lisp_Int
)
737 insert_before_markers (str
, 1);
739 else if (XTYPE (tem
) == Lisp_String
)
741 insert_from_string_before_markers (tem
, 0, XSTRING (tem
)->size
);
745 tem
= wrong_type_argument (Qchar_or_string_p
, tem
);
753 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 2, 2, 0,
754 "Insert COUNT (second arg) copies of CHAR (first arg).\n\
755 Point and all markers are affected as in the function `insert'.\n\
756 Both arguments are required.")
758 Lisp_Object chr
, count
;
760 register unsigned char *string
;
764 CHECK_NUMBER (chr
, 0);
765 CHECK_NUMBER (count
, 1);
770 strlen
= min (n
, 256);
771 string
= (unsigned char *) alloca (strlen
);
772 for (i
= 0; i
< strlen
; i
++)
773 string
[i
] = XFASTINT (chr
);
776 insert (string
, strlen
);
785 /* Making strings from buffer contents. */
787 /* Return a Lisp_String containing the text of the current buffer from
788 START to END. If text properties are in use and the current buffer
789 has properties in the range specifed, the resulting string will also
792 We don't want to use plain old make_string here, because it calls
793 make_uninit_string, which can cause the buffer arena to be
794 compacted. make_string has no way of knowing that the data has
795 been moved, and thus copies the wrong data into the string. This
796 doesn't effect most of the other users of make_string, so it should
797 be left as is. But we should use this function when conjuring
798 buffer substrings. */
801 make_buffer_string (start
, end
)
806 if (start
< GPT
&& GPT
< end
)
809 result
= make_uninit_string (end
- start
);
810 bcopy (&FETCH_CHAR (start
), XSTRING (result
)->data
, end
- start
);
812 /* Only defined if Emacs is compiled with USE_TEXT_PROPERTIES */
813 copy_intervals_to_string (result
, current_buffer
, start
, end
- start
);
818 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
819 "Return the contents of part of the current buffer as a string.\n\
820 The two arguments START and END are character positions;\n\
821 they can be in either order.")
825 register int beg
, end
;
827 validate_region (&b
, &e
);
831 return make_buffer_string (beg
, end
);
834 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
835 "Return the contents of the current buffer as a string.")
838 return make_buffer_string (BEGV
, ZV
);
841 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
843 "Insert before point a substring of the contents buffer BUFFER.\n\
844 BUFFER may be a buffer or a buffer name.\n\
845 Arguments START and END are character numbers specifying the substring.\n\
846 They default to the beginning and the end of BUFFER.")
848 Lisp_Object buf
, b
, e
;
850 register int beg
, end
, temp
, len
, opoint
, start
;
851 register struct buffer
*bp
;
854 buffer
= Fget_buffer (buf
);
857 bp
= XBUFFER (buffer
);
863 CHECK_NUMBER_COERCE_MARKER (b
, 0);
870 CHECK_NUMBER_COERCE_MARKER (e
, 1);
875 temp
= beg
, beg
= end
, end
= temp
;
877 /* Move the gap or create enough gap in the current buffer. */
881 if (GAP_SIZE
< end
- beg
)
882 make_gap (end
- beg
- GAP_SIZE
);
888 if (!(BUF_BEGV (bp
) <= beg
890 && end
<= BUF_ZV (bp
)))
891 args_out_of_range (b
, e
);
893 /* Now the actual insertion will not do any gap motion,
894 so it matters not if BUF is the current buffer. */
895 if (beg
< BUF_GPT (bp
))
897 insert (BUF_CHAR_ADDRESS (bp
, beg
), min (end
, BUF_GPT (bp
)) - beg
);
898 beg
= min (end
, BUF_GPT (bp
));
901 insert (BUF_CHAR_ADDRESS (bp
, beg
), end
- beg
);
903 /* Only defined if Emacs is compiled with USE_TEXT_PROPERTIES */
904 graft_intervals_into_buffer (copy_intervals (bp
->intervals
, start
, len
),
910 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
912 "Compare two substrings of two buffers; return result as number.\n\
913 the value is -N if first string is less after N-1 chars,\n\
914 +N if first string is greater after N-1 chars, or 0 if strings match.\n\
915 Each substring is represented as three arguments: BUFFER, START and END.\n\
916 That makes six args in all, three for each substring.\n\n\
917 The value of `case-fold-search' in the current buffer\n\
918 determines whether case is significant or ignored.")
919 (buffer1
, start1
, end1
, buffer2
, start2
, end2
)
920 Lisp_Object buffer1
, start1
, end1
, buffer2
, start2
, end2
;
922 register int begp1
, endp1
, begp2
, endp2
, temp
, len1
, len2
, length
, i
;
923 register struct buffer
*bp1
, *bp2
;
924 register unsigned char *trt
925 = (!NILP (current_buffer
->case_fold_search
)
926 ? XSTRING (current_buffer
->case_canon_table
)->data
: 0);
928 /* Find the first buffer and its substring. */
931 bp1
= current_buffer
;
935 buf1
= Fget_buffer (buffer1
);
938 bp1
= XBUFFER (buf1
);
942 begp1
= BUF_BEGV (bp1
);
945 CHECK_NUMBER_COERCE_MARKER (start1
, 1);
946 begp1
= XINT (start1
);
949 endp1
= BUF_ZV (bp1
);
952 CHECK_NUMBER_COERCE_MARKER (end1
, 2);
957 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
959 if (!(BUF_BEGV (bp1
) <= begp1
961 && endp1
<= BUF_ZV (bp1
)))
962 args_out_of_range (start1
, end1
);
964 /* Likewise for second substring. */
967 bp2
= current_buffer
;
971 buf2
= Fget_buffer (buffer2
);
974 bp2
= XBUFFER (buffer2
);
978 begp2
= BUF_BEGV (bp2
);
981 CHECK_NUMBER_COERCE_MARKER (start2
, 4);
982 begp2
= XINT (start2
);
985 endp2
= BUF_ZV (bp2
);
988 CHECK_NUMBER_COERCE_MARKER (end2
, 5);
993 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
995 if (!(BUF_BEGV (bp2
) <= begp2
997 && endp2
<= BUF_ZV (bp2
)))
998 args_out_of_range (start2
, end2
);
1000 len1
= endp1
- begp1
;
1001 len2
= endp2
- begp2
;
1006 for (i
= 0; i
< length
; i
++)
1008 int c1
= *BUF_CHAR_ADDRESS (bp1
, begp1
+ i
);
1009 int c2
= *BUF_CHAR_ADDRESS (bp2
, begp2
+ i
);
1016 return make_number (- 1 - i
);
1018 return make_number (i
+ 1);
1021 /* The strings match as far as they go.
1022 If one is shorter, that one is less. */
1024 return make_number (length
+ 1);
1025 else if (length
< len2
)
1026 return make_number (- length
- 1);
1028 /* Same length too => they are equal. */
1029 return make_number (0);
1032 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
1033 Ssubst_char_in_region
, 4, 5, 0,
1034 "From START to END, replace FROMCHAR with TOCHAR each time it occurs.\n\
1035 If optional arg NOUNDO is non-nil, don't record this change for undo\n\
1036 and don't mark the buffer as really changed.")
1037 (start
, end
, fromchar
, tochar
, noundo
)
1038 Lisp_Object start
, end
, fromchar
, tochar
, noundo
;
1040 register int pos
, stop
, look
;
1042 validate_region (&start
, &end
);
1043 CHECK_NUMBER (fromchar
, 2);
1044 CHECK_NUMBER (tochar
, 3);
1048 look
= XINT (fromchar
);
1050 modify_region (current_buffer
, pos
, stop
);
1051 if (! NILP (noundo
))
1053 if (MODIFF
- 1 == current_buffer
->save_modified
)
1054 current_buffer
->save_modified
++;
1055 if (MODIFF
- 1 == current_buffer
->auto_save_modified
)
1056 current_buffer
->auto_save_modified
++;
1061 if (FETCH_CHAR (pos
) == look
)
1064 record_change (pos
, 1);
1065 FETCH_CHAR (pos
) = XINT (tochar
);
1067 signal_after_change (pos
, 1, 1);
1075 DEFUN ("translate-region", Ftranslate_region
, Stranslate_region
, 3, 3, 0,
1076 "From START to END, translate characters according to TABLE.\n\
1077 TABLE is a string; the Nth character in it is the mapping\n\
1078 for the character with code N. Returns the number of characters changed.")
1082 register Lisp_Object table
;
1084 register int pos
, stop
; /* Limits of the region. */
1085 register unsigned char *tt
; /* Trans table. */
1086 register int oc
; /* Old character. */
1087 register int nc
; /* New character. */
1088 int cnt
; /* Number of changes made. */
1089 Lisp_Object z
; /* Return. */
1090 int size
; /* Size of translate table. */
1092 validate_region (&start
, &end
);
1093 CHECK_STRING (table
, 2);
1095 size
= XSTRING (table
)->size
;
1096 tt
= XSTRING (table
)->data
;
1100 modify_region (current_buffer
, pos
, stop
);
1103 for (; pos
< stop
; ++pos
)
1105 oc
= FETCH_CHAR (pos
);
1111 record_change (pos
, 1);
1112 FETCH_CHAR (pos
) = nc
;
1113 signal_after_change (pos
, 1, 1);
1123 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
1124 "Delete the text between point and mark.\n\
1125 When called from a program, expects two arguments,\n\
1126 positions (integers or markers) specifying the stretch to be deleted.")
1130 validate_region (&b
, &e
);
1131 del_range (XINT (b
), XINT (e
));
1135 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
1136 "Remove restrictions (narrowing) from current buffer.\n\
1137 This allows the buffer's full text to be seen and edited.")
1141 SET_BUF_ZV (current_buffer
, Z
);
1143 /* Changing the buffer bounds invalidates any recorded current column. */
1144 invalidate_current_column ();
1148 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
1149 "Restrict editing in this buffer to the current region.\n\
1150 The rest of the text becomes temporarily invisible and untouchable\n\
1151 but is not deleted; if you save the buffer in a file, the invisible\n\
1152 text is included in the file. \\[widen] makes all visible again.\n\
1153 See also `save-restriction'.\n\
1155 When calling from a program, pass two arguments; positions (integers\n\
1156 or markers) bounding the text that should remain visible.")
1158 register Lisp_Object b
, e
;
1162 CHECK_NUMBER_COERCE_MARKER (b
, 0);
1163 CHECK_NUMBER_COERCE_MARKER (e
, 1);
1165 if (XINT (b
) > XINT (e
))
1172 if (!(BEG
<= XINT (b
) && XINT (b
) <= XINT (e
) && XINT (e
) <= Z
))
1173 args_out_of_range (b
, e
);
1175 BEGV
= XFASTINT (b
);
1176 SET_BUF_ZV (current_buffer
, XFASTINT (e
));
1177 if (point
< XFASTINT (b
))
1178 SET_PT (XFASTINT (b
));
1179 if (point
> XFASTINT (e
))
1180 SET_PT (XFASTINT (e
));
1182 /* Changing the buffer bounds invalidates any recorded current column. */
1183 invalidate_current_column ();
1188 save_restriction_save ()
1190 register Lisp_Object bottom
, top
;
1191 /* Note: I tried using markers here, but it does not win
1192 because insertion at the end of the saved region
1193 does not advance mh and is considered "outside" the saved region. */
1194 XFASTINT (bottom
) = BEGV
- BEG
;
1195 XFASTINT (top
) = Z
- ZV
;
1197 return Fcons (Fcurrent_buffer (), Fcons (bottom
, top
));
1201 save_restriction_restore (data
)
1204 register struct buffer
*buf
;
1205 register int newhead
, newtail
;
1206 register Lisp_Object tem
;
1208 buf
= XBUFFER (XCONS (data
)->car
);
1210 data
= XCONS (data
)->cdr
;
1212 tem
= XCONS (data
)->car
;
1213 newhead
= XINT (tem
);
1214 tem
= XCONS (data
)->cdr
;
1215 newtail
= XINT (tem
);
1216 if (newhead
+ newtail
> BUF_Z (buf
) - BUF_BEG (buf
))
1221 BUF_BEGV (buf
) = BUF_BEG (buf
) + newhead
;
1222 SET_BUF_ZV (buf
, BUF_Z (buf
) - newtail
);
1225 /* If point is outside the new visible range, move it inside. */
1227 clip_to_bounds (BUF_BEGV (buf
), BUF_PT (buf
), BUF_ZV (buf
)));
1232 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
1233 "Execute BODY, saving and restoring current buffer's restrictions.\n\
1234 The buffer's restrictions make parts of the beginning and end invisible.\n\
1235 \(They are set up with `narrow-to-region' and eliminated with `widen'.)\n\
1236 This special form, `save-restriction', saves the current buffer's restrictions\n\
1237 when it is entered, and restores them when it is exited.\n\
1238 So any `narrow-to-region' within BODY lasts only until the end of the form.\n\
1239 The old restrictions settings are restored\n\
1240 even in case of abnormal exit (throw or error).\n\
1242 The value returned is the value of the last form in BODY.\n\
1244 `save-restriction' can get confused if, within the BODY, you widen\n\
1245 and then make changes outside the area within the saved restrictions.\n\
1247 Note: if you are using both `save-excursion' and `save-restriction',\n\
1248 use `save-excursion' outermost:\n\
1249 (save-excursion (save-restriction ...))")
1253 register Lisp_Object val
;
1254 int count
= specpdl_ptr
- specpdl
;
1256 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
1257 val
= Fprogn (body
);
1258 return unbind_to (count
, val
);
1261 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
1262 "Print a one-line message at the bottom of the screen.\n\
1263 The first argument is a control string.\n\
1264 It may contain %s or %d or %c to print successive following arguments.\n\
1265 %s means print an argument as a string, %d means print as number in decimal,\n\
1266 %c means print a number as a single character.\n\
1267 The argument used by %s must be a string or a symbol;\n\
1268 the argument used by %d or %c must be a number.\n\
1269 If the first argument is nil, clear any existing message; let the\n\
1270 minibuffer contents show.")
1282 register Lisp_Object val
;
1283 val
= Fformat (nargs
, args
);
1284 message ("%s", XSTRING (val
)->data
);
1289 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
1290 "Format a string out of a control-string and arguments.\n\
1291 The first argument is a control string.\n\
1292 The other arguments are substituted into it to make the result, a string.\n\
1293 It may contain %-sequences meaning to substitute the next argument.\n\
1294 %s means print a string argument. Actually, prints any object, with `princ'.\n\
1295 %d means print as number in decimal (%o octal, %x hex).\n\
1296 %c means print a number as a single character.\n\
1297 %S means print any object as an s-expression (using prin1).\n\
1298 The argument used for %d, %o, %x or %c must be a number.\n\
1299 Use %% to put a single % into the output.")
1302 register Lisp_Object
*args
;
1304 register int n
; /* The number of the next arg to substitute */
1305 register int total
= 5; /* An estimate of the final length */
1307 register unsigned char *format
, *end
;
1309 extern char *index ();
1310 /* It should not be necessary to GCPRO ARGS, because
1311 the caller in the interpreter should take care of that. */
1313 CHECK_STRING (args
[0], 0);
1314 format
= XSTRING (args
[0])->data
;
1315 end
= format
+ XSTRING (args
[0])->size
;
1318 while (format
!= end
)
1319 if (*format
++ == '%')
1323 /* Process a numeric arg and skip it. */
1324 minlen
= atoi (format
);
1329 while ((*format
>= '0' && *format
<= '9')
1330 || *format
== '-' || *format
== ' ' || *format
== '.')
1335 else if (++n
>= nargs
)
1337 else if (*format
== 'S')
1339 /* For `S', prin1 the argument and then treat like a string. */
1340 register Lisp_Object tem
;
1341 tem
= Fprin1_to_string (args
[n
], Qnil
);
1345 else if (XTYPE (args
[n
]) == Lisp_Symbol
)
1347 XSET (args
[n
], Lisp_String
, XSYMBOL (args
[n
])->name
);
1350 else if (XTYPE (args
[n
]) == Lisp_String
)
1353 total
+= XSTRING (args
[n
])->size
;
1355 /* Would get MPV otherwise, since Lisp_Int's `point' to low memory. */
1356 else if (XTYPE (args
[n
]) == Lisp_Int
&& *format
!= 's')
1358 #ifdef LISP_FLOAT_TYPE
1359 /* The following loop issumes the Lisp type indicates
1360 the proper way to pass the argument.
1361 So make sure we have a flonum if the argument should
1363 if (*format
== 'e' || *format
== 'f' || *format
== 'g')
1364 args
[n
] = Ffloat (args
[n
]);
1368 #ifdef LISP_FLOAT_TYPE
1369 else if (XTYPE (args
[n
]) == Lisp_Float
&& *format
!= 's')
1371 if (! (*format
== 'e' || *format
== 'f' || *format
== 'g'))
1372 args
[n
] = Ftruncate (args
[n
]);
1378 /* Anything but a string, convert to a string using princ. */
1379 register Lisp_Object tem
;
1380 tem
= Fprin1_to_string (args
[n
], Qt
);
1387 register int nstrings
= n
+ 1;
1388 register unsigned char **strings
1389 = (unsigned char **) alloca (nstrings
* sizeof (unsigned char *));
1391 for (n
= 0; n
< nstrings
; n
++)
1394 strings
[n
] = (unsigned char *) "";
1395 else if (XTYPE (args
[n
]) == Lisp_Int
)
1396 /* We checked above that the corresponding format effector
1397 isn't %s, which would cause MPV. */
1398 strings
[n
] = (unsigned char *) XINT (args
[n
]);
1399 #ifdef LISP_FLOAT_TYPE
1400 else if (XTYPE (args
[n
]) == Lisp_Float
)
1402 union { double d
; int half
[2]; } u
;
1404 u
.d
= XFLOAT (args
[n
])->data
;
1405 strings
[n
++] = (unsigned char *) u
.half
[0];
1406 strings
[n
] = (unsigned char *) u
.half
[1];
1410 strings
[n
] = XSTRING (args
[n
])->data
;
1413 /* Format it in bigger and bigger buf's until it all fits. */
1416 buf
= (char *) alloca (total
+ 1);
1419 length
= doprnt (buf
, total
+ 1, strings
[0], end
, nargs
, strings
+ 1);
1420 if (buf
[total
- 1] == 0)
1428 return make_string (buf
, length
);
1434 format1 (string1
, arg0
, arg1
, arg2
, arg3
, arg4
)
1435 int arg0
, arg1
, arg2
, arg3
, arg4
;
1449 doprnt (buf
, sizeof buf
, string1
, 0, 5, args
);
1451 doprnt (buf
, sizeof buf
, string1
, 0, 5, &string1
+ 1);
1453 return build_string (buf
);
1456 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
1457 "Return t if two characters match, optionally ignoring case.\n\
1458 Both arguments must be characters (i.e. integers).\n\
1459 Case is ignored if `case-fold-search' is non-nil in the current buffer.")
1461 register Lisp_Object c1
, c2
;
1463 unsigned char *downcase
= DOWNCASE_TABLE
;
1464 CHECK_NUMBER (c1
, 0);
1465 CHECK_NUMBER (c2
, 1);
1467 if (!NILP (current_buffer
->case_fold_search
)
1468 ? (downcase
[0xff & XFASTINT (c1
)] == downcase
[0xff & XFASTINT (c2
)]
1469 && (XFASTINT (c1
) & ~0xff) == (XFASTINT (c2
) & ~0xff))
1470 : XINT (c1
) == XINT (c2
))
1479 DEFVAR_LISP ("system-name", &Vsystem_name
,
1480 "The name of the machine Emacs is running on.");
1482 DEFVAR_LISP ("user-full-name", &Vuser_full_name
,
1483 "The full name of the user logged in.");
1485 DEFVAR_LISP ("user-name", &Vuser_name
,
1486 "The user's name, based on the effective uid.");
1488 DEFVAR_LISP ("user-real-name", &Vuser_real_name
,
1489 "The user's name, base upon the real uid.");
1491 defsubr (&Schar_equal
);
1492 defsubr (&Sgoto_char
);
1493 defsubr (&Sstring_to_char
);
1494 defsubr (&Schar_to_string
);
1495 defsubr (&Sbuffer_substring
);
1496 defsubr (&Sbuffer_string
);
1498 defsubr (&Spoint_marker
);
1499 defsubr (&Smark_marker
);
1501 defsubr (&Sregion_beginning
);
1502 defsubr (&Sregion_end
);
1503 /* defsubr (&Smark); */
1504 /* defsubr (&Sset_mark); */
1505 defsubr (&Ssave_excursion
);
1507 defsubr (&Sbufsize
);
1508 defsubr (&Spoint_max
);
1509 defsubr (&Spoint_min
);
1510 defsubr (&Spoint_min_marker
);
1511 defsubr (&Spoint_max_marker
);
1517 defsubr (&Sfollowing_char
);
1518 defsubr (&Sprevious_char
);
1519 defsubr (&Schar_after
);
1521 defsubr (&Sinsert_before_markers
);
1522 defsubr (&Sinsert_char
);
1524 defsubr (&Suser_login_name
);
1525 defsubr (&Suser_real_login_name
);
1526 defsubr (&Suser_uid
);
1527 defsubr (&Suser_real_uid
);
1528 defsubr (&Suser_full_name
);
1529 defsubr (&Scurrent_time
);
1530 defsubr (&Scurrent_time_string
);
1531 defsubr (&Scurrent_time_zone
);
1532 defsubr (&Ssystem_name
);
1533 defsubr (&Smessage
);
1536 defsubr (&Sinsert_buffer_substring
);
1537 defsubr (&Scompare_buffer_substrings
);
1538 defsubr (&Ssubst_char_in_region
);
1539 defsubr (&Stranslate_region
);
1540 defsubr (&Sdelete_region
);
1542 defsubr (&Snarrow_to_region
);
1543 defsubr (&Ssave_restriction
);