1 /* Lisp functions pertaining to editing.
2 Copyright (C) 1985, 1986, 1987, 1989, 1993 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 1, or (at your option)
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs; see the file COPYING. If not, write to
18 the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
21 #include <sys/types.h>
32 #include "intervals.h"
38 #define min(a, b) ((a) < (b) ? (a) : (b))
39 #define max(a, b) ((a) > (b) ? (a) : (b))
41 /* Some static data, and a function to initialize it for each run */
43 Lisp_Object Vsystem_name
;
44 Lisp_Object Vuser_real_name
; /* login name of current user ID */
45 Lisp_Object Vuser_full_name
; /* full name of current user */
46 Lisp_Object Vuser_name
; /* user name from USER or LOGNAME. */
52 register unsigned char *p
, *q
, *r
;
53 struct passwd
*pw
; /* password entry for the current user */
54 extern char *index ();
57 /* Set up system_name even when dumping. */
59 Vsystem_name
= build_string (get_system_name ());
60 p
= XSTRING (Vsystem_name
)->data
;
63 if (*p
== ' ' || *p
== '\t')
69 /* Don't bother with this on initial start when just dumping out */
72 #endif /* not CANNOT_DUMP */
74 pw
= (struct passwd
*) getpwuid (getuid ());
75 Vuser_real_name
= build_string (pw
? pw
->pw_name
: "unknown");
77 /* Get the effective user name, by consulting environment variables,
78 or the effective uid if those are unset. */
79 user_name
= (char *) getenv ("USER");
81 user_name
= (char *) getenv ("LOGNAME");
84 pw
= (struct passwd
*) getpwuid (geteuid ());
85 user_name
= (char *) (pw
? pw
->pw_name
: "unknown");
87 Vuser_name
= build_string (user_name
);
89 /* If the user name claimed in the environment vars differs from
90 the real uid, use the claimed name to find the full name. */
91 tem
= Fstring_equal (Vuser_name
, Vuser_real_name
);
93 pw
= (struct passwd
*) getpwnam (XSTRING (Vuser_name
)->data
);
95 p
= (unsigned char *) (pw
? USER_FULL_NAME
: "unknown");
96 q
= (unsigned char *) index (p
, ',');
97 Vuser_full_name
= make_string (p
, q
? q
- p
: strlen (p
));
99 #ifdef AMPERSAND_FULL_NAME
100 p
= XSTRING (Vuser_full_name
)->data
;
101 q
= (char *) index (p
, '&');
102 /* Substitute the login name for the &, upcasing the first character. */
105 r
= (char *) alloca (strlen (p
) + XSTRING (Vuser_name
)->size
+ 1);
108 strcat (r
, XSTRING (Vuser_name
)->data
);
109 r
[q
- p
] = UPCASE (r
[q
- p
]);
111 Vuser_full_name
= build_string (r
);
113 #endif /* AMPERSAND_FULL_NAME */
116 DEFUN ("char-to-string", Fchar_to_string
, Schar_to_string
, 1, 1, 0,
117 "Convert arg CHAR to a one-character string containing that character.")
125 return make_string (&c
, 1);
128 DEFUN ("string-to-char", Fstring_to_char
, Sstring_to_char
, 1, 1, 0,
129 "Convert arg STRING to a character, the first character of that string.")
131 register Lisp_Object str
;
133 register Lisp_Object val
;
134 register struct Lisp_String
*p
;
135 CHECK_STRING (str
, 0);
139 XFASTINT (val
) = ((unsigned char *) p
->data
)[0];
149 register Lisp_Object mark
;
150 mark
= Fmake_marker ();
151 Fset_marker (mark
, make_number (val
), Qnil
);
155 DEFUN ("point", Fpoint
, Spoint
, 0, 0, 0,
156 "Return value of point, as an integer.\n\
157 Beginning of buffer is position (point-min)")
161 XFASTINT (temp
) = point
;
165 DEFUN ("point-marker", Fpoint_marker
, Spoint_marker
, 0, 0, 0,
166 "Return value of point, as a marker object.")
169 return buildmark (point
);
173 clip_to_bounds (lower
, num
, upper
)
174 int lower
, num
, upper
;
178 else if (num
> upper
)
184 DEFUN ("goto-char", Fgoto_char
, Sgoto_char
, 1, 1, "NGoto char: ",
185 "Set point to POSITION, a number or marker.\n\
186 Beginning of buffer is position (point-min), end is (point-max).")
188 register Lisp_Object n
;
190 CHECK_NUMBER_COERCE_MARKER (n
, 0);
192 SET_PT (clip_to_bounds (BEGV
, XINT (n
), ZV
));
197 region_limit (beginningp
)
200 extern Lisp_Object Vmark_even_if_inactive
; /* Defined in callint.c. */
201 register Lisp_Object m
;
202 if (!NILP (Vtransient_mark_mode
) && NILP (Vmark_even_if_inactive
)
203 && NILP (current_buffer
->mark_active
))
204 Fsignal (Qmark_inactive
, Qnil
);
205 m
= Fmarker_position (current_buffer
->mark
);
206 if (NILP (m
)) error ("There is no region now");
207 if ((point
< XFASTINT (m
)) == beginningp
)
208 return (make_number (point
));
213 DEFUN ("region-beginning", Fregion_beginning
, Sregion_beginning
, 0, 0, 0,
214 "Return position of beginning of region, as an integer.")
217 return (region_limit (1));
220 DEFUN ("region-end", Fregion_end
, Sregion_end
, 0, 0, 0,
221 "Return position of end of region, as an integer.")
224 return (region_limit (0));
227 #if 0 /* now in lisp code */
228 DEFUN ("mark", Fmark
, Smark
, 0, 0, 0,
229 "Return this buffer's mark value as integer, or nil if no mark.\n\
230 If you are using this in an editing command, you are most likely making\n\
231 a mistake; see the documentation of `set-mark'.")
234 return Fmarker_position (current_buffer
->mark
);
236 #endif /* commented out code */
238 DEFUN ("mark-marker", Fmark_marker
, Smark_marker
, 0, 0, 0,
239 "Return this buffer's mark, as a marker object.\n\
240 Watch out! Moving this marker changes the mark position.\n\
241 If you set the marker not to point anywhere, the buffer will have no mark.")
244 return current_buffer
->mark
;
247 #if 0 /* this is now in lisp code */
248 DEFUN ("set-mark", Fset_mark
, Sset_mark
, 1, 1, 0,
249 "Set this buffer's mark to POS. Don't use this function!\n\
250 That is to say, don't use this function unless you want\n\
251 the user to see that the mark has moved, and you want the previous\n\
252 mark position to be lost.\n\
254 Normally, when a new mark is set, the old one should go on the stack.\n\
255 This is why most applications should use push-mark, not set-mark.\n\
257 Novice programmers often try to use the mark for the wrong purposes.\n\
258 The mark saves a location for the user's convenience.\n\
259 Most editing commands should not alter the mark.\n\
260 To remember a location for internal use in the Lisp program,\n\
261 store it in a Lisp variable. Example:\n\
263 (let ((beg (point))) (forward-line 1) (delete-region beg (point))).")
269 current_buffer
->mark
= Qnil
;
272 CHECK_NUMBER_COERCE_MARKER (pos
, 0);
274 if (NILP (current_buffer
->mark
))
275 current_buffer
->mark
= Fmake_marker ();
277 Fset_marker (current_buffer
->mark
, pos
, Qnil
);
280 #endif /* commented-out code */
283 save_excursion_save ()
285 register int visible
= (XBUFFER (XWINDOW (selected_window
)->buffer
)
288 return Fcons (Fpoint_marker (),
289 Fcons (Fcopy_marker (current_buffer
->mark
),
290 Fcons (visible
? Qt
: Qnil
,
291 current_buffer
->mark_active
)));
295 save_excursion_restore (info
)
296 register Lisp_Object info
;
298 register Lisp_Object tem
, tem1
;
300 tem
= Fmarker_buffer (Fcar (info
));
301 /* If buffer being returned to is now deleted, avoid error */
302 /* Otherwise could get error here while unwinding to top level
304 /* In that case, Fmarker_buffer returns nil now. */
310 unchain_marker (tem
);
311 tem
= Fcar (Fcdr (info
));
312 Fset_marker (current_buffer
->mark
, tem
, Fcurrent_buffer ());
313 unchain_marker (tem
);
314 tem
= Fcdr (Fcdr (info
));
317 && current_buffer
!= XBUFFER (XWINDOW (selected_window
)->buffer
))
318 Fswitch_to_buffer (Fcurrent_buffer (), Qnil
);
320 tem1
= current_buffer
->mark_active
;
321 current_buffer
->mark_active
= Fcdr (tem
);
322 if (! NILP (current_buffer
->mark_active
))
323 call1 (Vrun_hooks
, intern ("activate-mark-hook"));
324 else if (! NILP (tem1
))
325 call1 (Vrun_hooks
, intern ("deactivate-mark-hook"));
329 DEFUN ("save-excursion", Fsave_excursion
, Ssave_excursion
, 0, UNEVALLED
, 0,
330 "Save point, mark, and current buffer; execute BODY; restore those things.\n\
331 Executes BODY just like `progn'.\n\
332 The values of point, mark and the current buffer are restored\n\
333 even in case of abnormal exit (throw or error).\n\
334 The state of activation of the mark is also restored.")
338 register Lisp_Object val
;
339 int count
= specpdl_ptr
- specpdl
;
341 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
344 return unbind_to (count
, val
);
347 DEFUN ("buffer-size", Fbufsize
, Sbufsize
, 0, 0, 0,
348 "Return the number of characters in the current buffer.")
352 XFASTINT (temp
) = Z
- BEG
;
356 DEFUN ("point-min", Fpoint_min
, Spoint_min
, 0, 0, 0,
357 "Return the minimum permissible value of point in the current buffer.\n\
358 This is 1, unless a clipping restriction is in effect.")
362 XFASTINT (temp
) = BEGV
;
366 DEFUN ("point-min-marker", Fpoint_min_marker
, Spoint_min_marker
, 0, 0, 0,
367 "Return a marker to the minimum permissible value of point in this buffer.\n\
368 This is the beginning, unless a clipping restriction is in effect.")
371 return buildmark (BEGV
);
374 DEFUN ("point-max", Fpoint_max
, Spoint_max
, 0, 0, 0,
375 "Return the maximum permissible value of point in the current buffer.\n\
376 This is (1+ (buffer-size)), unless a clipping restriction is in effect,\n\
377 in which case it is less.")
381 XFASTINT (temp
) = ZV
;
385 DEFUN ("point-max-marker", Fpoint_max_marker
, Spoint_max_marker
, 0, 0, 0,
386 "Return a marker to the maximum permissible value of point in this buffer.\n\
387 This is (1+ (buffer-size)), unless a clipping restriction is in effect,\n\
388 in which case it is less.")
391 return buildmark (ZV
);
394 DEFUN ("following-char", Ffollowing_char
, Sfollowing_char
, 0, 0, 0,
395 "Return the character following point, as a number.\n\
396 At the end of the buffer or accessible region, return 0.")
403 XFASTINT (temp
) = FETCH_CHAR (point
);
407 DEFUN ("preceding-char", Fprevious_char
, Sprevious_char
, 0, 0, 0,
408 "Return the character preceding point, as a number.\n\
409 At the beginning of the buffer or accessible region, return 0.")
416 XFASTINT (temp
) = FETCH_CHAR (point
- 1);
420 DEFUN ("bobp", Fbobp
, Sbobp
, 0, 0, 0,
421 "Return T if point is at the beginning of the buffer.\n\
422 If the buffer is narrowed, this means the beginning of the narrowed part.")
430 DEFUN ("eobp", Feobp
, Seobp
, 0, 0, 0,
431 "Return T if point is at the end of the buffer.\n\
432 If the buffer is narrowed, this means the end of the narrowed part.")
440 DEFUN ("bolp", Fbolp
, Sbolp
, 0, 0, 0,
441 "Return T if point is at the beginning of a line.")
444 if (point
== BEGV
|| FETCH_CHAR (point
- 1) == '\n')
449 DEFUN ("eolp", Feolp
, Seolp
, 0, 0, 0,
450 "Return T if point is at the end of a line.\n\
451 `End of a line' includes point being at the end of the buffer.")
454 if (point
== ZV
|| FETCH_CHAR (point
) == '\n')
459 DEFUN ("char-after", Fchar_after
, Schar_after
, 1, 1, 0,
460 "Return character in current buffer at position POS.\n\
461 POS is an integer or a buffer pointer.\n\
462 If POS is out of range, the value is nil.")
466 register Lisp_Object val
;
469 CHECK_NUMBER_COERCE_MARKER (pos
, 0);
472 if (n
< BEGV
|| n
>= ZV
) return Qnil
;
474 XFASTINT (val
) = FETCH_CHAR (n
);
478 DEFUN ("user-login-name", Fuser_login_name
, Suser_login_name
, 0, 0, 0,
479 "Return the name under which the user logged in, as a string.\n\
480 This is based on the effective uid, not the real uid.\n\
481 Also, if the environment variable USER or LOGNAME is set,\n\
482 that determines the value of this function.")
488 DEFUN ("user-real-login-name", Fuser_real_login_name
, Suser_real_login_name
,
490 "Return the name of the user's real uid, as a string.\n\
491 Differs from `user-login-name' when running under `su'.")
494 return Vuser_real_name
;
497 DEFUN ("user-uid", Fuser_uid
, Suser_uid
, 0, 0, 0,
498 "Return the effective uid of Emacs, as an integer.")
501 return make_number (geteuid ());
504 DEFUN ("user-real-uid", Fuser_real_uid
, Suser_real_uid
, 0, 0, 0,
505 "Return the real uid of Emacs, as an integer.")
508 return make_number (getuid ());
511 DEFUN ("user-full-name", Fuser_full_name
, Suser_full_name
, 0, 0, 0,
512 "Return the full name of the user logged in, as a string.")
515 return Vuser_full_name
;
518 DEFUN ("system-name", Fsystem_name
, Ssystem_name
, 0, 0, 0,
519 "Return the name of the machine you are running on, as a string.")
525 DEFUN ("current-time", Fcurrent_time
, Scurrent_time
, 0, 0, 0,
526 "Return the current time, as the number of seconds since 12:00 AM January 1970.\n\
527 The time is returned as a list of three integers. The first has the\n\
528 most significant 16 bits of the seconds, while the second has the\n\
529 least significant 16 bits. The third integer gives the microsecond\n\
532 The microsecond count is zero on systems that do not provide\n\
533 resolution finer than a second.")
537 Lisp_Object result
[3];
540 XSET (result
[0], Lisp_Int
, (EMACS_SECS (t
) >> 16) & 0xffff);
541 XSET (result
[1], Lisp_Int
, (EMACS_SECS (t
) >> 0) & 0xffff);
542 XSET (result
[2], Lisp_Int
, EMACS_USECS (t
));
544 return Flist (3, result
);
549 lisp_time_argument (specified_time
, result
)
550 Lisp_Object specified_time
;
553 if (NILP (specified_time
))
554 return time (result
) != -1;
557 Lisp_Object high
, low
;
558 high
= Fcar (specified_time
);
559 CHECK_NUMBER (high
, 0);
560 low
= Fcdr (specified_time
);
561 if (XTYPE (low
) == Lisp_Cons
)
563 CHECK_NUMBER (low
, 0);
564 *result
= (XINT (high
) << 16) + (XINT (low
) & 0xffff);
565 return *result
>> 16 == XINT (high
);
569 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
, 0, 1, 0,
570 "Return the current time, as a human-readable string.\n\
571 Programs can use this function to decode a time,\n\
572 since the number of columns in each field is fixed.\n\
573 The format is `Sun Sep 16 01:03:52 1973'.\n\
574 If an argument is given, it specifies a time to format\n\
575 instead of the current time. The argument should have the form:\n\
578 (HIGH LOW . IGNORED).\n\
579 Thus, you can use times obtained from `current-time'\n\
580 and from `file-attributes'.")
582 Lisp_Object specified_time
;
588 if (! lisp_time_argument (specified_time
, &value
))
590 tem
= (char *) ctime (&value
);
592 strncpy (buf
, tem
, 24);
595 return build_string (buf
);
598 #define TM_YEAR_ORIGIN 1900
600 /* Yield A - B, measured in seconds. */
605 int ay
= a
->tm_year
+ (TM_YEAR_ORIGIN
- 1);
606 int by
= b
->tm_year
+ (TM_YEAR_ORIGIN
- 1);
611 /* difference in day of year */
612 a
->tm_yday
- b
->tm_yday
613 /* + intervening leap days */
614 + ((ay
>> 2) - (by
>> 2))
616 + ((ay
/100 >> 2) - (by
/100 >> 2))
617 /* + difference in years * 365 */
618 + (long)(ay
-by
) * 365
619 )*24 + (a
->tm_hour
- b
->tm_hour
)
620 )*60 + (a
->tm_min
- b
->tm_min
)
621 )*60 + (a
->tm_sec
- b
->tm_sec
);
624 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 1, 0,
625 "Return the offset and name for the local time zone.\n\
626 This returns a list of the form (OFFSET NAME).\n\
627 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).\n\
628 A negative value means west of Greenwich.\n\
629 NAME is a string giving the name of the time zone.\n\
630 If an argument is given, it specifies when the time zone offset is determined\n\
631 instead of using the current time. The argument should have the form:\n\
634 (HIGH LOW . IGNORED).\n\
635 Thus, you can use times obtained from `current-time'\n\
636 and from `file-attributes'.\n\
638 Some operating systems cannot provide all this information to Emacs;\n\
639 in this case, `current-time-zone' returns a list containing nil for\n\
640 the data it can't find.")
642 Lisp_Object specified_time
;
647 if (lisp_time_argument (specified_time
, &value
)
648 && (t
= gmtime (&value
)) != 0)
654 gmt
= *t
; /* Make a copy, in case localtime modifies *t. */
655 t
= localtime (&value
);
656 offset
= difftm (t
, &gmt
);
661 #else /* not HAVE_TM_ZONE */
663 if (t
->tm_isdst
== 0 || t
->tm_isdst
== 1)
664 s
= tzname
[t
->tm_isdst
];
666 #endif /* not HAVE_TM_ZONE */
669 /* No local time zone name is available; use "+-NNNN" instead. */
670 int am
= (offset
< 0 ? -offset
: offset
) / 60;
671 sprintf (buf
, "%c%02d%02d", (offset
< 0 ? '-' : '+'), am
/60, am
%60);
674 return Fcons (make_number (offset
), Fcons (build_string (s
), Qnil
));
677 return Fmake_list (2, Qnil
);
689 /* Callers passing one argument to Finsert need not gcpro the
690 argument "array", since the only element of the array will
691 not be used after calling insert or insert_from_string, so
692 we don't care if it gets trashed. */
694 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
695 "Insert the arguments, either strings or characters, at point.\n\
696 Point moves forward so that it ends up after the inserted text.\n\
697 Any other markers at the point of insertion remain before the text.")
700 register Lisp_Object
*args
;
703 register Lisp_Object tem
;
706 for (argnum
= 0; argnum
< nargs
; argnum
++)
710 if (XTYPE (tem
) == Lisp_Int
)
715 else if (XTYPE (tem
) == Lisp_String
)
717 insert_from_string (tem
, 0, XSTRING (tem
)->size
);
721 tem
= wrong_type_argument (Qchar_or_string_p
, tem
);
729 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
730 "Insert strings or characters at point, relocating markers after the text.\n\
731 Point moves forward so that it ends up after the inserted text.\n\
732 Any other markers at the point of insertion also end up after the text.")
735 register Lisp_Object
*args
;
738 register Lisp_Object tem
;
741 for (argnum
= 0; argnum
< nargs
; argnum
++)
745 if (XTYPE (tem
) == Lisp_Int
)
748 insert_before_markers (str
, 1);
750 else if (XTYPE (tem
) == Lisp_String
)
752 insert_from_string_before_markers (tem
, 0, XSTRING (tem
)->size
);
756 tem
= wrong_type_argument (Qchar_or_string_p
, tem
);
764 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 2, 2, 0,
765 "Insert COUNT (second arg) copies of CHAR (first arg).\n\
766 Point and all markers are affected as in the function `insert'.\n\
767 Both arguments are required.")
769 Lisp_Object chr
, count
;
771 register unsigned char *string
;
775 CHECK_NUMBER (chr
, 0);
776 CHECK_NUMBER (count
, 1);
781 strlen
= min (n
, 256);
782 string
= (unsigned char *) alloca (strlen
);
783 for (i
= 0; i
< strlen
; i
++)
784 string
[i
] = XFASTINT (chr
);
787 insert (string
, strlen
);
796 /* Making strings from buffer contents. */
798 /* Return a Lisp_String containing the text of the current buffer from
799 START to END. If text properties are in use and the current buffer
800 has properties in the range specified, the resulting string will also
803 We don't want to use plain old make_string here, because it calls
804 make_uninit_string, which can cause the buffer arena to be
805 compacted. make_string has no way of knowing that the data has
806 been moved, and thus copies the wrong data into the string. This
807 doesn't effect most of the other users of make_string, so it should
808 be left as is. But we should use this function when conjuring
809 buffer substrings. */
812 make_buffer_string (start
, end
)
817 if (start
< GPT
&& GPT
< end
)
820 result
= make_uninit_string (end
- start
);
821 bcopy (&FETCH_CHAR (start
), XSTRING (result
)->data
, end
- start
);
823 /* Only defined if Emacs is compiled with USE_TEXT_PROPERTIES */
824 copy_intervals_to_string (result
, current_buffer
, start
, end
- start
);
829 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
830 "Return the contents of part of the current buffer as a string.\n\
831 The two arguments START and END are character positions;\n\
832 they can be in either order.")
836 register int beg
, end
;
838 validate_region (&b
, &e
);
842 return make_buffer_string (beg
, end
);
845 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
846 "Return the contents of the current buffer as a string.")
849 return make_buffer_string (BEGV
, ZV
);
852 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
854 "Insert before point a substring of the contents of buffer BUFFER.\n\
855 BUFFER may be a buffer or a buffer name.\n\
856 Arguments START and END are character numbers specifying the substring.\n\
857 They default to the beginning and the end of BUFFER.")
859 Lisp_Object buf
, b
, e
;
861 register int beg
, end
, temp
, len
, opoint
, start
;
862 register struct buffer
*bp
;
865 buffer
= Fget_buffer (buf
);
868 bp
= XBUFFER (buffer
);
874 CHECK_NUMBER_COERCE_MARKER (b
, 0);
881 CHECK_NUMBER_COERCE_MARKER (e
, 1);
886 temp
= beg
, beg
= end
, end
= temp
;
888 /* Move the gap or create enough gap in the current buffer. */
892 if (GAP_SIZE
< end
- beg
)
893 make_gap (end
- beg
- GAP_SIZE
);
899 if (!(BUF_BEGV (bp
) <= beg
901 && end
<= BUF_ZV (bp
)))
902 args_out_of_range (b
, e
);
904 /* Now the actual insertion will not do any gap motion,
905 so it matters not if BUF is the current buffer. */
906 if (beg
< BUF_GPT (bp
))
908 insert (BUF_CHAR_ADDRESS (bp
, beg
), min (end
, BUF_GPT (bp
)) - beg
);
909 beg
= min (end
, BUF_GPT (bp
));
912 insert (BUF_CHAR_ADDRESS (bp
, beg
), end
- beg
);
914 /* Only defined if Emacs is compiled with USE_TEXT_PROPERTIES */
915 graft_intervals_into_buffer (copy_intervals (bp
->intervals
, start
, len
),
921 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
923 "Compare two substrings of two buffers; return result as number.\n\
924 the value is -N if first string is less after N-1 chars,\n\
925 +N if first string is greater after N-1 chars, or 0 if strings match.\n\
926 Each substring is represented as three arguments: BUFFER, START and END.\n\
927 That makes six args in all, three for each substring.\n\n\
928 The value of `case-fold-search' in the current buffer\n\
929 determines whether case is significant or ignored.")
930 (buffer1
, start1
, end1
, buffer2
, start2
, end2
)
931 Lisp_Object buffer1
, start1
, end1
, buffer2
, start2
, end2
;
933 register int begp1
, endp1
, begp2
, endp2
, temp
, len1
, len2
, length
, i
;
934 register struct buffer
*bp1
, *bp2
;
935 register unsigned char *trt
936 = (!NILP (current_buffer
->case_fold_search
)
937 ? XSTRING (current_buffer
->case_canon_table
)->data
: 0);
939 /* Find the first buffer and its substring. */
942 bp1
= current_buffer
;
946 buf1
= Fget_buffer (buffer1
);
949 bp1
= XBUFFER (buf1
);
953 begp1
= BUF_BEGV (bp1
);
956 CHECK_NUMBER_COERCE_MARKER (start1
, 1);
957 begp1
= XINT (start1
);
960 endp1
= BUF_ZV (bp1
);
963 CHECK_NUMBER_COERCE_MARKER (end1
, 2);
968 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
970 if (!(BUF_BEGV (bp1
) <= begp1
972 && endp1
<= BUF_ZV (bp1
)))
973 args_out_of_range (start1
, end1
);
975 /* Likewise for second substring. */
978 bp2
= current_buffer
;
982 buf2
= Fget_buffer (buffer2
);
985 bp2
= XBUFFER (buffer2
);
989 begp2
= BUF_BEGV (bp2
);
992 CHECK_NUMBER_COERCE_MARKER (start2
, 4);
993 begp2
= XINT (start2
);
996 endp2
= BUF_ZV (bp2
);
999 CHECK_NUMBER_COERCE_MARKER (end2
, 5);
1000 endp2
= XINT (end2
);
1004 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
1006 if (!(BUF_BEGV (bp2
) <= begp2
1008 && endp2
<= BUF_ZV (bp2
)))
1009 args_out_of_range (start2
, end2
);
1011 len1
= endp1
- begp1
;
1012 len2
= endp2
- begp2
;
1017 for (i
= 0; i
< length
; i
++)
1019 int c1
= *BUF_CHAR_ADDRESS (bp1
, begp1
+ i
);
1020 int c2
= *BUF_CHAR_ADDRESS (bp2
, begp2
+ i
);
1027 return make_number (- 1 - i
);
1029 return make_number (i
+ 1);
1032 /* The strings match as far as they go.
1033 If one is shorter, that one is less. */
1035 return make_number (length
+ 1);
1036 else if (length
< len2
)
1037 return make_number (- length
- 1);
1039 /* Same length too => they are equal. */
1040 return make_number (0);
1043 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
1044 Ssubst_char_in_region
, 4, 5, 0,
1045 "From START to END, replace FROMCHAR with TOCHAR each time it occurs.\n\
1046 If optional arg NOUNDO is non-nil, don't record this change for undo\n\
1047 and don't mark the buffer as really changed.")
1048 (start
, end
, fromchar
, tochar
, noundo
)
1049 Lisp_Object start
, end
, fromchar
, tochar
, noundo
;
1051 register int pos
, stop
, look
;
1053 validate_region (&start
, &end
);
1054 CHECK_NUMBER (fromchar
, 2);
1055 CHECK_NUMBER (tochar
, 3);
1059 look
= XINT (fromchar
);
1061 modify_region (current_buffer
, pos
, stop
);
1062 if (! NILP (noundo
))
1064 if (MODIFF
- 1 == current_buffer
->save_modified
)
1065 current_buffer
->save_modified
++;
1066 if (MODIFF
- 1 == current_buffer
->auto_save_modified
)
1067 current_buffer
->auto_save_modified
++;
1072 if (FETCH_CHAR (pos
) == look
)
1075 record_change (pos
, 1);
1076 FETCH_CHAR (pos
) = XINT (tochar
);
1078 signal_after_change (pos
, 1, 1);
1086 DEFUN ("translate-region", Ftranslate_region
, Stranslate_region
, 3, 3, 0,
1087 "From START to END, translate characters according to TABLE.\n\
1088 TABLE is a string; the Nth character in it is the mapping\n\
1089 for the character with code N. Returns the number of characters changed.")
1093 register Lisp_Object table
;
1095 register int pos
, stop
; /* Limits of the region. */
1096 register unsigned char *tt
; /* Trans table. */
1097 register int oc
; /* Old character. */
1098 register int nc
; /* New character. */
1099 int cnt
; /* Number of changes made. */
1100 Lisp_Object z
; /* Return. */
1101 int size
; /* Size of translate table. */
1103 validate_region (&start
, &end
);
1104 CHECK_STRING (table
, 2);
1106 size
= XSTRING (table
)->size
;
1107 tt
= XSTRING (table
)->data
;
1111 modify_region (current_buffer
, pos
, stop
);
1114 for (; pos
< stop
; ++pos
)
1116 oc
= FETCH_CHAR (pos
);
1122 record_change (pos
, 1);
1123 FETCH_CHAR (pos
) = nc
;
1124 signal_after_change (pos
, 1, 1);
1134 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
1135 "Delete the text between point and mark.\n\
1136 When called from a program, expects two arguments,\n\
1137 positions (integers or markers) specifying the stretch to be deleted.")
1141 validate_region (&b
, &e
);
1142 del_range (XINT (b
), XINT (e
));
1146 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
1147 "Remove restrictions (narrowing) from current buffer.\n\
1148 This allows the buffer's full text to be seen and edited.")
1152 SET_BUF_ZV (current_buffer
, Z
);
1154 /* Changing the buffer bounds invalidates any recorded current column. */
1155 invalidate_current_column ();
1159 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
1160 "Restrict editing in this buffer to the current region.\n\
1161 The rest of the text becomes temporarily invisible and untouchable\n\
1162 but is not deleted; if you save the buffer in a file, the invisible\n\
1163 text is included in the file. \\[widen] makes all visible again.\n\
1164 See also `save-restriction'.\n\
1166 When calling from a program, pass two arguments; positions (integers\n\
1167 or markers) bounding the text that should remain visible.")
1169 register Lisp_Object b
, e
;
1173 CHECK_NUMBER_COERCE_MARKER (b
, 0);
1174 CHECK_NUMBER_COERCE_MARKER (e
, 1);
1176 if (XINT (b
) > XINT (e
))
1183 if (!(BEG
<= XINT (b
) && XINT (b
) <= XINT (e
) && XINT (e
) <= Z
))
1184 args_out_of_range (b
, e
);
1186 BEGV
= XFASTINT (b
);
1187 SET_BUF_ZV (current_buffer
, XFASTINT (e
));
1188 if (point
< XFASTINT (b
))
1189 SET_PT (XFASTINT (b
));
1190 if (point
> XFASTINT (e
))
1191 SET_PT (XFASTINT (e
));
1193 /* Changing the buffer bounds invalidates any recorded current column. */
1194 invalidate_current_column ();
1199 save_restriction_save ()
1201 register Lisp_Object bottom
, top
;
1202 /* Note: I tried using markers here, but it does not win
1203 because insertion at the end of the saved region
1204 does not advance mh and is considered "outside" the saved region. */
1205 XFASTINT (bottom
) = BEGV
- BEG
;
1206 XFASTINT (top
) = Z
- ZV
;
1208 return Fcons (Fcurrent_buffer (), Fcons (bottom
, top
));
1212 save_restriction_restore (data
)
1215 register struct buffer
*buf
;
1216 register int newhead
, newtail
;
1217 register Lisp_Object tem
;
1219 buf
= XBUFFER (XCONS (data
)->car
);
1221 data
= XCONS (data
)->cdr
;
1223 tem
= XCONS (data
)->car
;
1224 newhead
= XINT (tem
);
1225 tem
= XCONS (data
)->cdr
;
1226 newtail
= XINT (tem
);
1227 if (newhead
+ newtail
> BUF_Z (buf
) - BUF_BEG (buf
))
1232 BUF_BEGV (buf
) = BUF_BEG (buf
) + newhead
;
1233 SET_BUF_ZV (buf
, BUF_Z (buf
) - newtail
);
1236 /* If point is outside the new visible range, move it inside. */
1238 clip_to_bounds (BUF_BEGV (buf
), BUF_PT (buf
), BUF_ZV (buf
)));
1243 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
1244 "Execute BODY, saving and restoring current buffer's restrictions.\n\
1245 The buffer's restrictions make parts of the beginning and end invisible.\n\
1246 \(They are set up with `narrow-to-region' and eliminated with `widen'.)\n\
1247 This special form, `save-restriction', saves the current buffer's restrictions\n\
1248 when it is entered, and restores them when it is exited.\n\
1249 So any `narrow-to-region' within BODY lasts only until the end of the form.\n\
1250 The old restrictions settings are restored\n\
1251 even in case of abnormal exit (throw or error).\n\
1253 The value returned is the value of the last form in BODY.\n\
1255 `save-restriction' can get confused if, within the BODY, you widen\n\
1256 and then make changes outside the area within the saved restrictions.\n\
1258 Note: if you are using both `save-excursion' and `save-restriction',\n\
1259 use `save-excursion' outermost:\n\
1260 (save-excursion (save-restriction ...))")
1264 register Lisp_Object val
;
1265 int count
= specpdl_ptr
- specpdl
;
1267 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
1268 val
= Fprogn (body
);
1269 return unbind_to (count
, val
);
1272 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
1273 "Print a one-line message at the bottom of the screen.\n\
1274 The first argument is a control string.\n\
1275 It may contain %s or %d or %c to print successive following arguments.\n\
1276 %s means print an argument as a string, %d means print as number in decimal,\n\
1277 %c means print a number as a single character.\n\
1278 The argument used by %s must be a string or a symbol;\n\
1279 the argument used by %d or %c must be a number.\n\
1280 If the first argument is nil, clear any existing message; let the\n\
1281 minibuffer contents show.")
1293 register Lisp_Object val
;
1294 val
= Fformat (nargs
, args
);
1295 message ("%s", XSTRING (val
)->data
);
1300 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
1301 "Format a string out of a control-string and arguments.\n\
1302 The first argument is a control string.\n\
1303 The other arguments are substituted into it to make the result, a string.\n\
1304 It may contain %-sequences meaning to substitute the next argument.\n\
1305 %s means print a string argument. Actually, prints any object, with `princ'.\n\
1306 %d means print as number in decimal (%o octal, %x hex).\n\
1307 %c means print a number as a single character.\n\
1308 %S means print any object as an s-expression (using prin1).\n\
1309 The argument used for %d, %o, %x or %c must be a number.\n\
1310 Use %% to put a single % into the output.")
1313 register Lisp_Object
*args
;
1315 register int n
; /* The number of the next arg to substitute */
1316 register int total
= 5; /* An estimate of the final length */
1318 register unsigned char *format
, *end
;
1320 extern char *index ();
1321 /* It should not be necessary to GCPRO ARGS, because
1322 the caller in the interpreter should take care of that. */
1324 CHECK_STRING (args
[0], 0);
1325 format
= XSTRING (args
[0])->data
;
1326 end
= format
+ XSTRING (args
[0])->size
;
1329 while (format
!= end
)
1330 if (*format
++ == '%')
1334 /* Process a numeric arg and skip it. */
1335 minlen
= atoi (format
);
1340 while ((*format
>= '0' && *format
<= '9')
1341 || *format
== '-' || *format
== ' ' || *format
== '.')
1346 else if (++n
>= nargs
)
1348 else if (*format
== 'S')
1350 /* For `S', prin1 the argument and then treat like a string. */
1351 register Lisp_Object tem
;
1352 tem
= Fprin1_to_string (args
[n
], Qnil
);
1356 else if (XTYPE (args
[n
]) == Lisp_Symbol
)
1358 XSET (args
[n
], Lisp_String
, XSYMBOL (args
[n
])->name
);
1361 else if (XTYPE (args
[n
]) == Lisp_String
)
1364 total
+= XSTRING (args
[n
])->size
;
1366 /* Would get MPV otherwise, since Lisp_Int's `point' to low memory. */
1367 else if (XTYPE (args
[n
]) == Lisp_Int
&& *format
!= 's')
1369 #ifdef LISP_FLOAT_TYPE
1370 /* The following loop assumes the Lisp type indicates
1371 the proper way to pass the argument.
1372 So make sure we have a flonum if the argument should
1374 if (*format
== 'e' || *format
== 'f' || *format
== 'g')
1375 args
[n
] = Ffloat (args
[n
]);
1379 #ifdef LISP_FLOAT_TYPE
1380 else if (XTYPE (args
[n
]) == Lisp_Float
&& *format
!= 's')
1382 if (! (*format
== 'e' || *format
== 'f' || *format
== 'g'))
1383 args
[n
] = Ftruncate (args
[n
]);
1389 /* Anything but a string, convert to a string using princ. */
1390 register Lisp_Object tem
;
1391 tem
= Fprin1_to_string (args
[n
], Qt
);
1398 register int nstrings
= n
+ 1;
1400 /* Allocate twice as many strings as we have %-escapes; floats occupy
1401 two slots, and we're not sure how many of those we have. */
1402 register unsigned char **strings
1403 = (unsigned char **) alloca (2 * nstrings
* sizeof (unsigned char *));
1407 for (n
= 0; n
< nstrings
; n
++)
1410 strings
[i
++] = (unsigned char *) "";
1411 else if (XTYPE (args
[n
]) == Lisp_Int
)
1412 /* We checked above that the corresponding format effector
1413 isn't %s, which would cause MPV. */
1414 strings
[i
++] = (unsigned char *) XINT (args
[n
]);
1415 #ifdef LISP_FLOAT_TYPE
1416 else if (XTYPE (args
[n
]) == Lisp_Float
)
1418 union { double d
; int half
[2]; } u
;
1420 u
.d
= XFLOAT (args
[n
])->data
;
1421 strings
[i
++] = (unsigned char *) u
.half
[0];
1422 strings
[i
++] = (unsigned char *) u
.half
[1];
1426 strings
[i
++] = XSTRING (args
[n
])->data
;
1429 /* Format it in bigger and bigger buf's until it all fits. */
1432 buf
= (char *) alloca (total
+ 1);
1435 length
= doprnt (buf
, total
+ 1, strings
[0], end
, i
-1, strings
+ 1);
1436 if (buf
[total
- 1] == 0)
1444 return make_string (buf
, length
);
1450 format1 (string1
, arg0
, arg1
, arg2
, arg3
, arg4
)
1451 int arg0
, arg1
, arg2
, arg3
, arg4
;
1465 doprnt (buf
, sizeof buf
, string1
, 0, 5, args
);
1467 doprnt (buf
, sizeof buf
, string1
, 0, 5, &string1
+ 1);
1469 return build_string (buf
);
1472 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
1473 "Return t if two characters match, optionally ignoring case.\n\
1474 Both arguments must be characters (i.e. integers).\n\
1475 Case is ignored if `case-fold-search' is non-nil in the current buffer.")
1477 register Lisp_Object c1
, c2
;
1479 unsigned char *downcase
= DOWNCASE_TABLE
;
1480 CHECK_NUMBER (c1
, 0);
1481 CHECK_NUMBER (c2
, 1);
1483 if (!NILP (current_buffer
->case_fold_search
)
1484 ? (downcase
[0xff & XFASTINT (c1
)] == downcase
[0xff & XFASTINT (c2
)]
1485 && (XFASTINT (c1
) & ~0xff) == (XFASTINT (c2
) & ~0xff))
1486 : XINT (c1
) == XINT (c2
))
1495 staticpro (&Vuser_name
);
1496 staticpro (&Vuser_full_name
);
1497 staticpro (&Vuser_real_name
);
1498 staticpro (&Vsystem_name
);
1500 defsubr (&Schar_equal
);
1501 defsubr (&Sgoto_char
);
1502 defsubr (&Sstring_to_char
);
1503 defsubr (&Schar_to_string
);
1504 defsubr (&Sbuffer_substring
);
1505 defsubr (&Sbuffer_string
);
1507 defsubr (&Spoint_marker
);
1508 defsubr (&Smark_marker
);
1510 defsubr (&Sregion_beginning
);
1511 defsubr (&Sregion_end
);
1512 /* defsubr (&Smark); */
1513 /* defsubr (&Sset_mark); */
1514 defsubr (&Ssave_excursion
);
1516 defsubr (&Sbufsize
);
1517 defsubr (&Spoint_max
);
1518 defsubr (&Spoint_min
);
1519 defsubr (&Spoint_min_marker
);
1520 defsubr (&Spoint_max_marker
);
1526 defsubr (&Sfollowing_char
);
1527 defsubr (&Sprevious_char
);
1528 defsubr (&Schar_after
);
1530 defsubr (&Sinsert_before_markers
);
1531 defsubr (&Sinsert_char
);
1533 defsubr (&Suser_login_name
);
1534 defsubr (&Suser_real_login_name
);
1535 defsubr (&Suser_uid
);
1536 defsubr (&Suser_real_uid
);
1537 defsubr (&Suser_full_name
);
1538 defsubr (&Scurrent_time
);
1539 defsubr (&Scurrent_time_string
);
1540 defsubr (&Scurrent_time_zone
);
1541 defsubr (&Ssystem_name
);
1542 defsubr (&Smessage
);
1545 defsubr (&Sinsert_buffer_substring
);
1546 defsubr (&Scompare_buffer_substrings
);
1547 defsubr (&Ssubst_char_in_region
);
1548 defsubr (&Stranslate_region
);
1549 defsubr (&Sdelete_region
);
1551 defsubr (&Snarrow_to_region
);
1552 defsubr (&Ssave_restriction
);