1 /* Lisp functions pertaining to editing.
2 Copyright (C) 1985,86,87,89,93,94,95 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 2, 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 extern void insert_from_buffer ();
42 static long difftm ();
44 /* Some static data, and a function to initialize it for each run */
46 Lisp_Object Vsystem_name
;
47 Lisp_Object Vuser_real_login_name
; /* login name of current user ID */
48 Lisp_Object Vuser_full_name
; /* full name of current user */
49 Lisp_Object Vuser_login_name
; /* user name from LOGNAME or USER */
55 register unsigned char *p
, *q
, *r
;
56 struct passwd
*pw
; /* password entry for the current user */
57 extern char *index ();
60 /* Set up system_name even when dumping. */
64 /* Don't bother with this on initial start when just dumping out */
67 #endif /* not CANNOT_DUMP */
69 pw
= (struct passwd
*) getpwuid (getuid ());
71 /* We let the real user name default to "root" because that's quite
72 accurate on MSDOG and because it lets Emacs find the init file.
73 (The DVX libraries override the Djgpp libraries here.) */
74 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "root");
76 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "unknown");
79 /* Get the effective user name, by consulting environment variables,
80 or the effective uid if those are unset. */
81 user_name
= (char *) getenv ("LOGNAME");
84 user_name
= (char *) getenv ("USERNAME"); /* it's USERNAME on NT */
86 user_name
= (char *) getenv ("USER");
87 #endif /* WINDOWSNT */
90 pw
= (struct passwd
*) getpwuid (geteuid ());
91 user_name
= (char *) (pw
? pw
->pw_name
: "unknown");
93 Vuser_login_name
= build_string (user_name
);
95 /* If the user name claimed in the environment vars differs from
96 the real uid, use the claimed name to find the full name. */
97 tem
= Fstring_equal (Vuser_login_name
, Vuser_real_login_name
);
99 pw
= (struct passwd
*) getpwnam (XSTRING (Vuser_login_name
)->data
);
101 p
= (unsigned char *) (pw
? USER_FULL_NAME
: "unknown");
102 q
= (unsigned char *) index (p
, ',');
103 Vuser_full_name
= make_string (p
, q
? q
- p
: strlen (p
));
105 #ifdef AMPERSAND_FULL_NAME
106 p
= XSTRING (Vuser_full_name
)->data
;
107 q
= (unsigned char *) index (p
, '&');
108 /* Substitute the login name for the &, upcasing the first character. */
111 r
= (unsigned char *) alloca (strlen (p
)
112 + XSTRING (Vuser_login_name
)->size
+ 1);
115 strcat (r
, XSTRING (Vuser_login_name
)->data
);
116 r
[q
- p
] = UPCASE (r
[q
- p
]);
118 Vuser_full_name
= build_string (r
);
120 #endif /* AMPERSAND_FULL_NAME */
122 p
= (unsigned char *) getenv ("NAME");
124 Vuser_full_name
= build_string (p
);
127 DEFUN ("char-to-string", Fchar_to_string
, Schar_to_string
, 1, 1, 0,
128 "Convert arg CHAR to a one-character string containing that character.")
136 return make_string (&c
, 1);
139 DEFUN ("string-to-char", Fstring_to_char
, Sstring_to_char
, 1, 1, 0,
140 "Convert arg STRING to a character, the first character of that string.")
142 register Lisp_Object str
;
144 register Lisp_Object val
;
145 register struct Lisp_String
*p
;
146 CHECK_STRING (str
, 0);
150 XSETFASTINT (val
, ((unsigned char *) p
->data
)[0]);
152 XSETFASTINT (val
, 0);
160 register Lisp_Object mark
;
161 mark
= Fmake_marker ();
162 Fset_marker (mark
, make_number (val
), Qnil
);
166 DEFUN ("point", Fpoint
, Spoint
, 0, 0, 0,
167 "Return value of point, as an integer.\n\
168 Beginning of buffer is position (point-min)")
172 XSETFASTINT (temp
, point
);
176 DEFUN ("point-marker", Fpoint_marker
, Spoint_marker
, 0, 0, 0,
177 "Return value of point, as a marker object.")
180 return buildmark (point
);
184 clip_to_bounds (lower
, num
, upper
)
185 int lower
, num
, upper
;
189 else if (num
> upper
)
195 DEFUN ("goto-char", Fgoto_char
, Sgoto_char
, 1, 1, "NGoto char: ",
196 "Set point to POSITION, a number or marker.\n\
197 Beginning of buffer is position (point-min), end is (point-max).")
199 register Lisp_Object n
;
201 CHECK_NUMBER_COERCE_MARKER (n
, 0);
203 SET_PT (clip_to_bounds (BEGV
, XINT (n
), ZV
));
208 region_limit (beginningp
)
211 extern Lisp_Object Vmark_even_if_inactive
; /* Defined in callint.c. */
212 register Lisp_Object m
;
213 if (!NILP (Vtransient_mark_mode
) && NILP (Vmark_even_if_inactive
)
214 && NILP (current_buffer
->mark_active
))
215 Fsignal (Qmark_inactive
, Qnil
);
216 m
= Fmarker_position (current_buffer
->mark
);
217 if (NILP (m
)) error ("There is no region now");
218 if ((point
< XFASTINT (m
)) == beginningp
)
219 return (make_number (point
));
224 DEFUN ("region-beginning", Fregion_beginning
, Sregion_beginning
, 0, 0, 0,
225 "Return position of beginning of region, as an integer.")
228 return (region_limit (1));
231 DEFUN ("region-end", Fregion_end
, Sregion_end
, 0, 0, 0,
232 "Return position of end of region, as an integer.")
235 return (region_limit (0));
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
;
248 save_excursion_save ()
250 register int visible
= (XBUFFER (XWINDOW (selected_window
)->buffer
)
253 return Fcons (Fpoint_marker (),
254 Fcons (Fcopy_marker (current_buffer
->mark
),
255 Fcons (visible
? Qt
: Qnil
,
256 current_buffer
->mark_active
)));
260 save_excursion_restore (info
)
261 register Lisp_Object info
;
263 register Lisp_Object tem
, tem1
, omark
, nmark
;
265 tem
= Fmarker_buffer (Fcar (info
));
266 /* If buffer being returned to is now deleted, avoid error */
267 /* Otherwise could get error here while unwinding to top level
269 /* In that case, Fmarker_buffer returns nil now. */
275 unchain_marker (tem
);
276 tem
= Fcar (Fcdr (info
));
277 omark
= Fmarker_position (current_buffer
->mark
);
278 Fset_marker (current_buffer
->mark
, tem
, Fcurrent_buffer ());
279 nmark
= Fmarker_position (tem
);
280 unchain_marker (tem
);
281 tem
= Fcdr (Fcdr (info
));
282 #if 0 /* We used to make the current buffer visible in the selected window
283 if that was true previously. That avoids some anomalies.
284 But it creates others, and it wasn't documented, and it is simpler
285 and cleaner never to alter the window/buffer connections. */
288 && current_buffer
!= XBUFFER (XWINDOW (selected_window
)->buffer
))
289 Fswitch_to_buffer (Fcurrent_buffer (), Qnil
);
292 tem1
= current_buffer
->mark_active
;
293 current_buffer
->mark_active
= Fcdr (tem
);
294 if (!NILP (Vrun_hooks
))
296 /* If mark is active now, and either was not active
297 or was at a different place, run the activate hook. */
298 if (! NILP (current_buffer
->mark_active
))
300 if (! EQ (omark
, nmark
))
301 call1 (Vrun_hooks
, intern ("activate-mark-hook"));
303 /* If mark has ceased to be active, run deactivate hook. */
304 else if (! NILP (tem1
))
305 call1 (Vrun_hooks
, intern ("deactivate-mark-hook"));
310 DEFUN ("save-excursion", Fsave_excursion
, Ssave_excursion
, 0, UNEVALLED
, 0,
311 "Save point, mark, and current buffer; execute BODY; restore those things.\n\
312 Executes BODY just like `progn'.\n\
313 The values of point, mark and the current buffer are restored\n\
314 even in case of abnormal exit (throw or error).\n\
315 The state of activation of the mark is also restored.")
319 register Lisp_Object val
;
320 int count
= specpdl_ptr
- specpdl
;
322 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
325 return unbind_to (count
, val
);
328 DEFUN ("buffer-size", Fbufsize
, Sbufsize
, 0, 0, 0,
329 "Return the number of characters in the current buffer.")
333 XSETFASTINT (temp
, Z
- BEG
);
337 DEFUN ("point-min", Fpoint_min
, Spoint_min
, 0, 0, 0,
338 "Return the minimum permissible value of point in the current buffer.\n\
339 This is 1, unless narrowing (a buffer restriction) is in effect.")
343 XSETFASTINT (temp
, BEGV
);
347 DEFUN ("point-min-marker", Fpoint_min_marker
, Spoint_min_marker
, 0, 0, 0,
348 "Return a marker to the minimum permissible value of point in this buffer.\n\
349 This is the beginning, unless narrowing (a buffer restriction) is in effect.")
352 return buildmark (BEGV
);
355 DEFUN ("point-max", Fpoint_max
, Spoint_max
, 0, 0, 0,
356 "Return the maximum permissible value of point in the current buffer.\n\
357 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)\n\
358 is in effect, in which case it is less.")
362 XSETFASTINT (temp
, ZV
);
366 DEFUN ("point-max-marker", Fpoint_max_marker
, Spoint_max_marker
, 0, 0, 0,
367 "Return a marker to the maximum permissible value of point in this buffer.\n\
368 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)\n\
369 is in effect, in which case it is less.")
372 return buildmark (ZV
);
375 DEFUN ("following-char", Ffollowing_char
, Sfollowing_char
, 0, 0, 0,
376 "Return the character following point, as a number.\n\
377 At the end of the buffer or accessible region, return 0.")
382 XSETFASTINT (temp
, 0);
384 XSETFASTINT (temp
, FETCH_CHAR (point
));
388 DEFUN ("preceding-char", Fprevious_char
, Sprevious_char
, 0, 0, 0,
389 "Return the character preceding point, as a number.\n\
390 At the beginning of the buffer or accessible region, return 0.")
395 XSETFASTINT (temp
, 0);
397 XSETFASTINT (temp
, FETCH_CHAR (point
- 1));
401 DEFUN ("bobp", Fbobp
, Sbobp
, 0, 0, 0,
402 "Return T if point is at the beginning of the buffer.\n\
403 If the buffer is narrowed, this means the beginning of the narrowed part.")
411 DEFUN ("eobp", Feobp
, Seobp
, 0, 0, 0,
412 "Return T if point is at the end of the buffer.\n\
413 If the buffer is narrowed, this means the end of the narrowed part.")
421 DEFUN ("bolp", Fbolp
, Sbolp
, 0, 0, 0,
422 "Return T if point is at the beginning of a line.")
425 if (point
== BEGV
|| FETCH_CHAR (point
- 1) == '\n')
430 DEFUN ("eolp", Feolp
, Seolp
, 0, 0, 0,
431 "Return T if point is at the end of a line.\n\
432 `End of a line' includes point being at the end of the buffer.")
435 if (point
== ZV
|| FETCH_CHAR (point
) == '\n')
440 DEFUN ("char-after", Fchar_after
, Schar_after
, 1, 1, 0,
441 "Return character in current buffer at position POS.\n\
442 POS is an integer or a buffer pointer.\n\
443 If POS is out of range, the value is nil.")
447 register Lisp_Object val
;
450 CHECK_NUMBER_COERCE_MARKER (pos
, 0);
453 if (n
< BEGV
|| n
>= ZV
) return Qnil
;
455 XSETFASTINT (val
, FETCH_CHAR (n
));
459 DEFUN ("user-login-name", Fuser_login_name
, Suser_login_name
, 0, 1, 0,
460 "Return the name under which the user logged in, as a string.\n\
461 This is based on the effective uid, not the real uid.\n\
462 Also, if the environment variable LOGNAME or USER is set,\n\
463 that determines the value of this function.\n\n\
464 If optional argument UID is an integer, return the login name of the user\n\
465 with that uid, or nil if there is no such user.")
471 /* Set up the user name info if we didn't do it before.
472 (That can happen if Emacs is dumpable
473 but you decide to run `temacs -l loadup' and not dump. */
474 if (INTEGERP (Vuser_login_name
))
478 return Vuser_login_name
;
480 CHECK_NUMBER (uid
, 0);
481 pw
= (struct passwd
*) getpwuid (XINT (uid
));
482 return (pw
? build_string (pw
->pw_name
) : Qnil
);
485 DEFUN ("user-real-login-name", Fuser_real_login_name
, Suser_real_login_name
,
487 "Return the name of the user's real uid, as a string.\n\
488 This ignores the environment variables LOGNAME and USER, so it differs from\n\
489 `user-login-name' when running under `su'.")
492 /* Set up the user name info if we didn't do it before.
493 (That can happen if Emacs is dumpable
494 but you decide to run `temacs -l loadup' and not dump. */
495 if (INTEGERP (Vuser_login_name
))
497 return Vuser_real_login_name
;
500 DEFUN ("user-uid", Fuser_uid
, Suser_uid
, 0, 0, 0,
501 "Return the effective uid of Emacs, as an integer.")
504 return make_number (geteuid ());
507 DEFUN ("user-real-uid", Fuser_real_uid
, Suser_real_uid
, 0, 0, 0,
508 "Return the real uid of Emacs, as an integer.")
511 return make_number (getuid ());
514 DEFUN ("user-full-name", Fuser_full_name
, Suser_full_name
, 0, 0, 0,
515 "Return the full name of the user logged in, as a string.")
518 return Vuser_full_name
;
521 DEFUN ("system-name", Fsystem_name
, Ssystem_name
, 0, 0, 0,
522 "Return the name of the machine you are running on, as a string.")
528 /* For the benefit of callers who don't want to include lisp.h */
532 return (char *) XSTRING (Vsystem_name
)->data
;
535 DEFUN ("emacs-pid", Femacs_pid
, Semacs_pid
, 0, 0, 0,
536 "Return the process ID of Emacs, as an integer.")
539 return make_number (getpid ());
542 DEFUN ("current-time", Fcurrent_time
, Scurrent_time
, 0, 0, 0,
543 "Return the current time, as the number of seconds since 12:00 AM January 1970.\n\
544 The time is returned as a list of three integers. The first has the\n\
545 most significant 16 bits of the seconds, while the second has the\n\
546 least significant 16 bits. The third integer gives the microsecond\n\
549 The microsecond count is zero on systems that do not provide\n\
550 resolution finer than a second.")
554 Lisp_Object result
[3];
557 XSETINT (result
[0], (EMACS_SECS (t
) >> 16) & 0xffff);
558 XSETINT (result
[1], (EMACS_SECS (t
) >> 0) & 0xffff);
559 XSETINT (result
[2], EMACS_USECS (t
));
561 return Flist (3, result
);
566 lisp_time_argument (specified_time
, result
)
567 Lisp_Object specified_time
;
570 if (NILP (specified_time
))
571 return time (result
) != -1;
574 Lisp_Object high
, low
;
575 high
= Fcar (specified_time
);
576 CHECK_NUMBER (high
, 0);
577 low
= Fcdr (specified_time
);
580 CHECK_NUMBER (low
, 0);
581 *result
= (XINT (high
) << 16) + (XINT (low
) & 0xffff);
582 return *result
>> 16 == XINT (high
);
586 DEFUN ("format-time-string", Fformat_time_string
, Sformat_time_string
, 2, 2, 0,
587 "Use FORMAT-STRING to format the time TIME.\n\
588 TIME is specified as (HIGH LOW . IGNORED) or (HIGH . LOW), as from\n\
589 `current-time' and `file-attributes'.\n\
590 FORMAT-STRING may contain %-sequences to substitute parts of the time.\n\
591 %a is replaced by the abbreviated name of the day of week.\n\
592 %A is replaced by the full name of the day of week.\n\
593 %b is replaced by the abbreviated name of the month.\n\
594 %B is replaced by the full name of the month.\n\
595 %c is a synonym for \"%x %X\".\n\
596 %C is a locale-specific synonym, which defaults to \"%A, %B %e, %Y\" in the C locale.\n\
597 %d is replaced by the day of month, zero-padded.\n\
598 %D is a synonym for \"%m/%d/%y\".\n\
599 %e is replaced by the day of month, blank-padded.\n\
600 %h is a synonym for \"%b\".\n\
601 %H is replaced by the hour (00-23).\n\
602 %I is replaced by the hour (00-12).\n\
603 %j is replaced by the day of the year (001-366).\n\
604 %k is replaced by the hour (0-23), blank padded.\n\
605 %l is replaced by the hour (1-12), blank padded.\n\
606 %m is replaced by the month (01-12).\n\
607 %M is replaced by the minut (00-59).\n\
608 %n is a synonym for \"\\n\".\n\
609 %p is replaced by AM or PM, as appropriate.\n\
610 %r is a synonym for \"%I:%M:%S %p\".\n\
611 %R is a synonym for \"%H:%M\".\n\
612 %S is replaced by the seconds (00-60).\n\
613 %t is a synonym for \"\\t\".\n\
614 %T is a synonym for \"%H:%M:%S\".\n\
615 %U is replaced by the week of the year (01-52), first day of week is Sunday.\n\
616 %w is replaced by the day of week (0-6), Sunday is day 0.\n\
617 %W is replaced by the week of the year (01-52), first day of week is Monday.\n\
618 %x is a locale-specific synonym, which defaults to \"%D\" in the C locale.\n\
619 %X is a locale-specific synonym, which defaults to \"%T\" in the C locale.\n\
620 %y is replaced by the year without century (00-99).\n\
621 %Y is replaced by the year with century.\n\
622 %Z is replaced by the time zone abbreviation.\n\
624 The number of options reflects the `strftime' function.")
625 (format_string
, time
)
626 Lisp_Object format_string
, time
;
631 CHECK_STRING (format_string
, 1);
633 if (! lisp_time_argument (time
, &value
))
634 error ("Invalid time specification");
636 /* This is probably enough. */
637 size
= XSTRING (format_string
)->size
* 6 + 50;
641 char *buf
= (char *) alloca (size
);
642 if (emacs_strftime (buf
, size
, XSTRING (format_string
)->data
,
644 return build_string (buf
);
645 /* If buffer was too small, make it bigger. */
650 DEFUN ("decode-time", Fdecode_time
, Sdecode_time
, 0, 1, 0,
651 "Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST ZONE).\n\
652 The optional SPECIFIED-TIME should be a list of (HIGH LOW . IGNORED)\n\
653 or (HIGH . LOW), as from `current-time' and `file-attributes', or `nil'\n\
654 to use the current time. The list has the following nine members:\n\
655 SEC is an integer between 0 and 59. MINUTE is an integer between 0 and 59.\n\
656 HOUR is an integer between 0 and 23. DAY is an integer between 1 and 31.\n\
657 MONTH is an integer between 1 and 12. YEAR is an integer indicating the\n\
658 four-digit year. DOW is the day of week, an integer between 0 and 6, where\n\
659 0 is Sunday. DST is t if daylight savings time is effect, otherwise nil.\n\
660 ZONE is an integer indicating the number of seconds east of Greenwich.\n\
661 (Note that Common Lisp has different meanings for DOW and ZONE.)")
663 Lisp_Object specified_time
;
667 struct tm
*decoded_time
;
668 Lisp_Object list_args
[9];
670 if (! lisp_time_argument (specified_time
, &time_spec
))
671 error ("Invalid time specification");
673 decoded_time
= localtime (&time_spec
);
674 XSETFASTINT (list_args
[0], decoded_time
->tm_sec
);
675 XSETFASTINT (list_args
[1], decoded_time
->tm_min
);
676 XSETFASTINT (list_args
[2], decoded_time
->tm_hour
);
677 XSETFASTINT (list_args
[3], decoded_time
->tm_mday
);
678 XSETFASTINT (list_args
[4], decoded_time
->tm_mon
+ 1);
679 XSETFASTINT (list_args
[5], decoded_time
->tm_year
+ 1900);
680 XSETFASTINT (list_args
[6], decoded_time
->tm_wday
);
681 list_args
[7] = (decoded_time
->tm_isdst
)? Qt
: Qnil
;
683 /* Make a copy, in case gmtime modifies the struct. */
684 save_tm
= *decoded_time
;
685 decoded_time
= gmtime (&time_spec
);
686 if (decoded_time
== 0)
689 XSETINT (list_args
[8], difftm (&save_tm
, decoded_time
));
690 return Flist (9, list_args
);
693 static char days_per_month
[11]
694 = { 31, 30, 31, 30, 31, 31, 30, 31, 30, 31, 31 };
696 DEFUN ("encode-time", Fencode_time
, Sencode_time
, 6, 7, 0,
697 "Convert SEC, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.\n\
698 This is the reverse operation of `decode-time', which see. ZONE defaults\n\
699 to the current time zone and daylight savings time if not specified; if\n\
700 specified, it can be either a list (as from `current-time-zone') or an\n\
701 integer (as from `decode-time'), and is applied without consideration for\n\
702 daylight savings time.\n\
703 Year numbers less than 100 are treated just like other year numbers.\n\
704 If you want them to stand for years above 1900, you must do that yourself.")
705 (sec
, minute
, hour
, day
, month
, year
, zone
)
706 Lisp_Object sec
, minute
, hour
, day
, month
, year
, zone
;
709 int fullyear
, mon
, days
, seconds
, tz
= 0;
711 CHECK_NATNUM (sec
, 0);
712 CHECK_NATNUM (minute
, 1);
713 CHECK_NATNUM (hour
, 2);
714 CHECK_NATNUM (day
, 3);
715 CHECK_NATNUM (month
, 4);
716 CHECK_NATNUM (year
, 5);
718 fullyear
= XINT (year
);
720 /* Adjust incoming datespec to epoch = March 1, year 0.
721 The "date" March 1, year 0, is an abstraction used purely for its
722 computational convenience; year 0 never existed. */
723 mon
= XINT (month
) - 1 + 10;
724 fullyear
+= mon
/12 - 1;
727 days
= XINT (day
) - 1; /* day of month */
728 while (mon
-- > 0) /* day of year */
729 days
+= days_per_month
[mon
];
730 days
+= 146097 * (fullyear
/400); /* 400 years = 146097 days */
732 days
+= 36524 * (fullyear
/100); /* 100 years = 36524 days */
734 days
+= 1461 * (fullyear
/4); /* 4 years = 1461 days */
736 days
+= 365 * fullyear
; /* 1 year = 365 days */
738 /* Adjust computed datespec to epoch = January 1, 1970. */
739 days
+= 59; /* March 1 is 59th day. */
740 days
-= 719527; /* 1970 years = 719527 days */
742 seconds
= XINT (sec
) + 60 * XINT (minute
) + 3600 * XINT (hour
);
744 if (sizeof (time_t) == 4
745 && ((days
+(seconds
/86400) > 24854) || (days
+(seconds
/86400) < -24854)))
746 error ("the specified time is outside the representable range");
748 time
= days
* 86400 + seconds
;
750 /* We have the correct value for UTC. Adjust for timezones. */
754 time_t adjusted_time
;
756 /* If the system does not use timezones, gmtime returns 0, and we
757 already have the correct value, by definition. */
758 if ((t
= gmtime (&time
)) != 0)
761 t
= localtime (&time
);
762 tz
= difftm (t
, &gmt
);
763 /* The timezone returned is that at the specified Universal Time,
764 not the local time, which is what we want. Adjust, repeat. */
765 adjusted_time
= time
- tz
;
766 gmt
= *gmtime (&adjusted_time
); /* this is safe now */
767 t
= localtime (&adjusted_time
);
768 adjusted_tz
= difftm (t
, &gmt
);
769 /* In case of discrepancy, adjust again for extra accuracy. */
770 if (adjusted_tz
!= tz
)
772 adjusted_time
= time
- adjusted_tz
;
773 gmt
= *gmtime (&adjusted_time
);
774 t
= localtime (&adjusted_time
);
775 adjusted_tz
= difftm (t
, &gmt
);
784 CHECK_NUMBER (zone
, 6);
788 return make_time (time
- tz
);
791 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
, 0, 1, 0,
792 "Return the current time, as a human-readable string.\n\
793 Programs can use this function to decode a time,\n\
794 since the number of columns in each field is fixed.\n\
795 The format is `Sun Sep 16 01:03:52 1973'.\n\
796 If an argument is given, it specifies a time to format\n\
797 instead of the current time. The argument should have the form:\n\
800 (HIGH LOW . IGNORED).\n\
801 Thus, you can use times obtained from `current-time'\n\
802 and from `file-attributes'.")
804 Lisp_Object specified_time
;
810 if (! lisp_time_argument (specified_time
, &value
))
812 tem
= (char *) ctime (&value
);
814 strncpy (buf
, tem
, 24);
817 return build_string (buf
);
820 #define TM_YEAR_ORIGIN 1900
822 /* Yield A - B, measured in seconds. */
827 int ay
= a
->tm_year
+ (TM_YEAR_ORIGIN
- 1);
828 int by
= b
->tm_year
+ (TM_YEAR_ORIGIN
- 1);
829 /* Some compilers can't handle this as a single return statement. */
831 /* difference in day of year */
832 a
->tm_yday
- b
->tm_yday
833 /* + intervening leap days */
834 + ((ay
>> 2) - (by
>> 2))
836 + ((ay
/100 >> 2) - (by
/100 >> 2))
837 /* + difference in years * 365 */
838 + (long)(ay
-by
) * 365
840 return (60*(60*(24*days
+ (a
->tm_hour
- b
->tm_hour
))
841 + (a
->tm_min
- b
->tm_min
))
842 + (a
->tm_sec
- b
->tm_sec
));
845 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 1, 0,
846 "Return the offset and name for the local time zone.\n\
847 This returns a list of the form (OFFSET NAME).\n\
848 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).\n\
849 A negative value means west of Greenwich.\n\
850 NAME is a string giving the name of the time zone.\n\
851 If an argument is given, it specifies when the time zone offset is determined\n\
852 instead of using the current time. The argument should have the form:\n\
855 (HIGH LOW . IGNORED).\n\
856 Thus, you can use times obtained from `current-time'\n\
857 and from `file-attributes'.\n\
859 Some operating systems cannot provide all this information to Emacs;\n\
860 in this case, `current-time-zone' returns a list containing nil for\n\
861 the data it can't find.")
863 Lisp_Object specified_time
;
868 if (lisp_time_argument (specified_time
, &value
)
869 && (t
= gmtime (&value
)) != 0)
875 gmt
= *t
; /* Make a copy, in case localtime modifies *t. */
876 t
= localtime (&value
);
877 offset
= difftm (t
, &gmt
);
881 s
= (char *)t
->tm_zone
;
882 #else /* not HAVE_TM_ZONE */
884 if (t
->tm_isdst
== 0 || t
->tm_isdst
== 1)
885 s
= tzname
[t
->tm_isdst
];
887 #endif /* not HAVE_TM_ZONE */
890 /* No local time zone name is available; use "+-NNNN" instead. */
891 int am
= (offset
< 0 ? -offset
: offset
) / 60;
892 sprintf (buf
, "%c%02d%02d", (offset
< 0 ? '-' : '+'), am
/60, am
%60);
895 return Fcons (make_number (offset
), Fcons (build_string (s
), Qnil
));
898 return Fmake_list (2, Qnil
);
910 /* Callers passing one argument to Finsert need not gcpro the
911 argument "array", since the only element of the array will
912 not be used after calling insert or insert_from_string, so
913 we don't care if it gets trashed. */
915 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
916 "Insert the arguments, either strings or characters, at point.\n\
917 Point moves forward so that it ends up after the inserted text.\n\
918 Any other markers at the point of insertion remain before the text.")
921 register Lisp_Object
*args
;
924 register Lisp_Object tem
;
927 for (argnum
= 0; argnum
< nargs
; argnum
++)
936 else if (STRINGP (tem
))
938 insert_from_string (tem
, 0, XSTRING (tem
)->size
, 0);
942 tem
= wrong_type_argument (Qchar_or_string_p
, tem
);
950 DEFUN ("insert-and-inherit", Finsert_and_inherit
, Sinsert_and_inherit
,
952 "Insert the arguments at point, inheriting properties from adjoining text.\n\
953 Point moves forward so that it ends up after the inserted text.\n\
954 Any other markers at the point of insertion remain before the text.")
957 register Lisp_Object
*args
;
960 register Lisp_Object tem
;
963 for (argnum
= 0; argnum
< nargs
; argnum
++)
970 insert_and_inherit (str
, 1);
972 else if (STRINGP (tem
))
974 insert_from_string (tem
, 0, XSTRING (tem
)->size
, 1);
978 tem
= wrong_type_argument (Qchar_or_string_p
, tem
);
986 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
987 "Insert strings or characters at point, relocating markers after the text.\n\
988 Point moves forward so that it ends up after the inserted text.\n\
989 Any other markers at the point of insertion also end up after the text.")
992 register Lisp_Object
*args
;
995 register Lisp_Object tem
;
998 for (argnum
= 0; argnum
< nargs
; argnum
++)
1004 str
[0] = XINT (tem
);
1005 insert_before_markers (str
, 1);
1007 else if (STRINGP (tem
))
1009 insert_from_string_before_markers (tem
, 0, XSTRING (tem
)->size
, 0);
1013 tem
= wrong_type_argument (Qchar_or_string_p
, tem
);
1021 DEFUN ("insert-before-markers-and-inherit",
1022 Finsert_and_inherit_before_markers
, Sinsert_and_inherit_before_markers
,
1024 "Insert text at point, relocating markers and inheriting properties.\n\
1025 Point moves forward so that it ends up after the inserted text.\n\
1026 Any other markers at the point of insertion also end up after the text.")
1029 register Lisp_Object
*args
;
1031 register int argnum
;
1032 register Lisp_Object tem
;
1035 for (argnum
= 0; argnum
< nargs
; argnum
++)
1041 str
[0] = XINT (tem
);
1042 insert_before_markers_and_inherit (str
, 1);
1044 else if (STRINGP (tem
))
1046 insert_from_string_before_markers (tem
, 0, XSTRING (tem
)->size
, 1);
1050 tem
= wrong_type_argument (Qchar_or_string_p
, tem
);
1058 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 2, 3, 0,
1059 "Insert COUNT (second arg) copies of CHAR (first arg).\n\
1060 Point and all markers are affected as in the function `insert'.\n\
1061 Both arguments are required.\n\
1062 The optional third arg INHERIT, if non-nil, says to inherit text properties\n\
1063 from adjoining text, if those properties are sticky.")
1064 (chr
, count
, inherit
)
1065 Lisp_Object chr
, count
, inherit
;
1067 register unsigned char *string
;
1068 register int strlen
;
1071 CHECK_NUMBER (chr
, 0);
1072 CHECK_NUMBER (count
, 1);
1077 strlen
= min (n
, 256);
1078 string
= (unsigned char *) alloca (strlen
);
1079 for (i
= 0; i
< strlen
; i
++)
1080 string
[i
] = XFASTINT (chr
);
1083 if (!NILP (inherit
))
1084 insert_and_inherit (string
, strlen
);
1086 insert (string
, strlen
);
1091 if (!NILP (inherit
))
1092 insert_and_inherit (string
, n
);
1100 /* Making strings from buffer contents. */
1102 /* Return a Lisp_String containing the text of the current buffer from
1103 START to END. If text properties are in use and the current buffer
1104 has properties in the range specified, the resulting string will also
1107 We don't want to use plain old make_string here, because it calls
1108 make_uninit_string, which can cause the buffer arena to be
1109 compacted. make_string has no way of knowing that the data has
1110 been moved, and thus copies the wrong data into the string. This
1111 doesn't effect most of the other users of make_string, so it should
1112 be left as is. But we should use this function when conjuring
1113 buffer substrings. */
1116 make_buffer_string (start
, end
)
1119 Lisp_Object result
, tem
, tem1
;
1121 if (start
< GPT
&& GPT
< end
)
1124 result
= make_uninit_string (end
- start
);
1125 bcopy (&FETCH_CHAR (start
), XSTRING (result
)->data
, end
- start
);
1127 tem
= Fnext_property_change (make_number (start
), Qnil
, make_number (end
));
1128 tem1
= Ftext_properties_at (make_number (start
), Qnil
);
1130 #ifdef USE_TEXT_PROPERTIES
1131 if (XINT (tem
) != end
|| !NILP (tem1
))
1132 copy_intervals_to_string (result
, current_buffer
, start
, end
- start
);
1138 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
1139 "Return the contents of part of the current buffer as a string.\n\
1140 The two arguments START and END are character positions;\n\
1141 they can be in either order.")
1145 register int beg
, end
;
1147 validate_region (&b
, &e
);
1151 return make_buffer_string (beg
, end
);
1154 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
1155 "Return the contents of the current buffer as a string.\n\
1156 If narrowing is in effect, this function returns only the visible part\n\
1160 return make_buffer_string (BEGV
, ZV
);
1163 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
1165 "Insert before point a substring of the contents of buffer BUFFER.\n\
1166 BUFFER may be a buffer or a buffer name.\n\
1167 Arguments START and END are character numbers specifying the substring.\n\
1168 They default to the beginning and the end of BUFFER.")
1170 Lisp_Object buf
, b
, e
;
1172 register int beg
, end
, temp
;
1173 register struct buffer
*bp
;
1176 buffer
= Fget_buffer (buf
);
1179 bp
= XBUFFER (buffer
);
1182 beg
= BUF_BEGV (bp
);
1185 CHECK_NUMBER_COERCE_MARKER (b
, 0);
1192 CHECK_NUMBER_COERCE_MARKER (e
, 1);
1197 temp
= beg
, beg
= end
, end
= temp
;
1199 if (!(BUF_BEGV (bp
) <= beg
&& end
<= BUF_ZV (bp
)))
1200 args_out_of_range (b
, e
);
1202 insert_from_buffer (bp
, beg
, end
- beg
, 0);
1206 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
1208 "Compare two substrings of two buffers; return result as number.\n\
1209 the value is -N if first string is less after N-1 chars,\n\
1210 +N if first string is greater after N-1 chars, or 0 if strings match.\n\
1211 Each substring is represented as three arguments: BUFFER, START and END.\n\
1212 That makes six args in all, three for each substring.\n\n\
1213 The value of `case-fold-search' in the current buffer\n\
1214 determines whether case is significant or ignored.")
1215 (buffer1
, start1
, end1
, buffer2
, start2
, end2
)
1216 Lisp_Object buffer1
, start1
, end1
, buffer2
, start2
, end2
;
1218 register int begp1
, endp1
, begp2
, endp2
, temp
, len1
, len2
, length
, i
;
1219 register struct buffer
*bp1
, *bp2
;
1220 register unsigned char *trt
1221 = (!NILP (current_buffer
->case_fold_search
)
1222 ? XSTRING (current_buffer
->case_canon_table
)->data
: 0);
1224 /* Find the first buffer and its substring. */
1227 bp1
= current_buffer
;
1231 buf1
= Fget_buffer (buffer1
);
1234 bp1
= XBUFFER (buf1
);
1238 begp1
= BUF_BEGV (bp1
);
1241 CHECK_NUMBER_COERCE_MARKER (start1
, 1);
1242 begp1
= XINT (start1
);
1245 endp1
= BUF_ZV (bp1
);
1248 CHECK_NUMBER_COERCE_MARKER (end1
, 2);
1249 endp1
= XINT (end1
);
1253 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
1255 if (!(BUF_BEGV (bp1
) <= begp1
1257 && endp1
<= BUF_ZV (bp1
)))
1258 args_out_of_range (start1
, end1
);
1260 /* Likewise for second substring. */
1263 bp2
= current_buffer
;
1267 buf2
= Fget_buffer (buffer2
);
1270 bp2
= XBUFFER (buffer2
);
1274 begp2
= BUF_BEGV (bp2
);
1277 CHECK_NUMBER_COERCE_MARKER (start2
, 4);
1278 begp2
= XINT (start2
);
1281 endp2
= BUF_ZV (bp2
);
1284 CHECK_NUMBER_COERCE_MARKER (end2
, 5);
1285 endp2
= XINT (end2
);
1289 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
1291 if (!(BUF_BEGV (bp2
) <= begp2
1293 && endp2
<= BUF_ZV (bp2
)))
1294 args_out_of_range (start2
, end2
);
1296 len1
= endp1
- begp1
;
1297 len2
= endp2
- begp2
;
1302 for (i
= 0; i
< length
; i
++)
1304 int c1
= *BUF_CHAR_ADDRESS (bp1
, begp1
+ i
);
1305 int c2
= *BUF_CHAR_ADDRESS (bp2
, begp2
+ i
);
1312 return make_number (- 1 - i
);
1314 return make_number (i
+ 1);
1317 /* The strings match as far as they go.
1318 If one is shorter, that one is less. */
1320 return make_number (length
+ 1);
1321 else if (length
< len2
)
1322 return make_number (- length
- 1);
1324 /* Same length too => they are equal. */
1325 return make_number (0);
1329 subst_char_in_region_unwind (arg
)
1332 return current_buffer
->undo_list
= arg
;
1336 subst_char_in_region_unwind_1 (arg
)
1339 return current_buffer
->filename
= arg
;
1342 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
1343 Ssubst_char_in_region
, 4, 5, 0,
1344 "From START to END, replace FROMCHAR with TOCHAR each time it occurs.\n\
1345 If optional arg NOUNDO is non-nil, don't record this change for undo\n\
1346 and don't mark the buffer as really changed.")
1347 (start
, end
, fromchar
, tochar
, noundo
)
1348 Lisp_Object start
, end
, fromchar
, tochar
, noundo
;
1350 register int pos
, stop
, look
;
1352 int count
= specpdl_ptr
- specpdl
;
1354 validate_region (&start
, &end
);
1355 CHECK_NUMBER (fromchar
, 2);
1356 CHECK_NUMBER (tochar
, 3);
1360 look
= XINT (fromchar
);
1362 /* If we don't want undo, turn off putting stuff on the list.
1363 That's faster than getting rid of things,
1364 and it prevents even the entry for a first change.
1365 Also inhibit locking the file. */
1368 record_unwind_protect (subst_char_in_region_unwind
,
1369 current_buffer
->undo_list
);
1370 current_buffer
->undo_list
= Qt
;
1371 /* Don't do file-locking. */
1372 record_unwind_protect (subst_char_in_region_unwind_1
,
1373 current_buffer
->filename
);
1374 current_buffer
->filename
= Qnil
;
1379 if (FETCH_CHAR (pos
) == look
)
1383 modify_region (current_buffer
, XINT (start
), stop
);
1385 if (! NILP (noundo
))
1387 if (MODIFF
- 1 == SAVE_MODIFF
)
1389 if (MODIFF
- 1 == current_buffer
->auto_save_modified
)
1390 current_buffer
->auto_save_modified
++;
1397 record_change (pos
, 1);
1398 FETCH_CHAR (pos
) = XINT (tochar
);
1404 signal_after_change (XINT (start
),
1405 stop
- XINT (start
), stop
- XINT (start
));
1407 unbind_to (count
, Qnil
);
1411 DEFUN ("translate-region", Ftranslate_region
, Stranslate_region
, 3, 3, 0,
1412 "From START to END, translate characters according to TABLE.\n\
1413 TABLE is a string; the Nth character in it is the mapping\n\
1414 for the character with code N. Returns the number of characters changed.")
1418 register Lisp_Object table
;
1420 register int pos
, stop
; /* Limits of the region. */
1421 register unsigned char *tt
; /* Trans table. */
1422 register int oc
; /* Old character. */
1423 register int nc
; /* New character. */
1424 int cnt
; /* Number of changes made. */
1425 Lisp_Object z
; /* Return. */
1426 int size
; /* Size of translate table. */
1428 validate_region (&start
, &end
);
1429 CHECK_STRING (table
, 2);
1431 size
= XSTRING (table
)->size
;
1432 tt
= XSTRING (table
)->data
;
1436 modify_region (current_buffer
, pos
, stop
);
1439 for (; pos
< stop
; ++pos
)
1441 oc
= FETCH_CHAR (pos
);
1447 record_change (pos
, 1);
1448 FETCH_CHAR (pos
) = nc
;
1449 signal_after_change (pos
, 1, 1);
1455 XSETFASTINT (z
, cnt
);
1459 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
1460 "Delete the text between point and mark.\n\
1461 When called from a program, expects two arguments,\n\
1462 positions (integers or markers) specifying the stretch to be deleted.")
1466 validate_region (&b
, &e
);
1467 del_range (XINT (b
), XINT (e
));
1471 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
1472 "Remove restrictions (narrowing) from current buffer.\n\
1473 This allows the buffer's full text to be seen and edited.")
1477 SET_BUF_ZV (current_buffer
, Z
);
1478 current_buffer
->clip_changed
= 1;
1479 /* Changing the buffer bounds invalidates any recorded current column. */
1480 invalidate_current_column ();
1484 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
1485 "Restrict editing in this buffer to the current region.\n\
1486 The rest of the text becomes temporarily invisible and untouchable\n\
1487 but is not deleted; if you save the buffer in a file, the invisible\n\
1488 text is included in the file. \\[widen] makes all visible again.\n\
1489 See also `save-restriction'.\n\
1491 When calling from a program, pass two arguments; positions (integers\n\
1492 or markers) bounding the text that should remain visible.")
1494 register Lisp_Object b
, e
;
1496 CHECK_NUMBER_COERCE_MARKER (b
, 0);
1497 CHECK_NUMBER_COERCE_MARKER (e
, 1);
1499 if (XINT (b
) > XINT (e
))
1502 tem
= b
; b
= e
; e
= tem
;
1505 if (!(BEG
<= XINT (b
) && XINT (b
) <= XINT (e
) && XINT (e
) <= Z
))
1506 args_out_of_range (b
, e
);
1508 BEGV
= XFASTINT (b
);
1509 SET_BUF_ZV (current_buffer
, XFASTINT (e
));
1510 if (point
< XFASTINT (b
))
1511 SET_PT (XFASTINT (b
));
1512 if (point
> XFASTINT (e
))
1513 SET_PT (XFASTINT (e
));
1514 current_buffer
->clip_changed
= 1;
1515 /* Changing the buffer bounds invalidates any recorded current column. */
1516 invalidate_current_column ();
1521 save_restriction_save ()
1523 register Lisp_Object bottom
, top
;
1524 /* Note: I tried using markers here, but it does not win
1525 because insertion at the end of the saved region
1526 does not advance mh and is considered "outside" the saved region. */
1527 XSETFASTINT (bottom
, BEGV
- BEG
);
1528 XSETFASTINT (top
, Z
- ZV
);
1530 return Fcons (Fcurrent_buffer (), Fcons (bottom
, top
));
1534 save_restriction_restore (data
)
1537 register struct buffer
*buf
;
1538 register int newhead
, newtail
;
1539 register Lisp_Object tem
;
1541 buf
= XBUFFER (XCONS (data
)->car
);
1543 data
= XCONS (data
)->cdr
;
1545 tem
= XCONS (data
)->car
;
1546 newhead
= XINT (tem
);
1547 tem
= XCONS (data
)->cdr
;
1548 newtail
= XINT (tem
);
1549 if (newhead
+ newtail
> BUF_Z (buf
) - BUF_BEG (buf
))
1554 BUF_BEGV (buf
) = BUF_BEG (buf
) + newhead
;
1555 SET_BUF_ZV (buf
, BUF_Z (buf
) - newtail
);
1556 current_buffer
->clip_changed
= 1;
1558 /* If point is outside the new visible range, move it inside. */
1560 clip_to_bounds (BUF_BEGV (buf
), BUF_PT (buf
), BUF_ZV (buf
)));
1565 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
1566 "Execute BODY, saving and restoring current buffer's restrictions.\n\
1567 The buffer's restrictions make parts of the beginning and end invisible.\n\
1568 \(They are set up with `narrow-to-region' and eliminated with `widen'.)\n\
1569 This special form, `save-restriction', saves the current buffer's restrictions\n\
1570 when it is entered, and restores them when it is exited.\n\
1571 So any `narrow-to-region' within BODY lasts only until the end of the form.\n\
1572 The old restrictions settings are restored\n\
1573 even in case of abnormal exit (throw or error).\n\
1575 The value returned is the value of the last form in BODY.\n\
1577 `save-restriction' can get confused if, within the BODY, you widen\n\
1578 and then make changes outside the area within the saved restrictions.\n\
1580 Note: if you are using both `save-excursion' and `save-restriction',\n\
1581 use `save-excursion' outermost:\n\
1582 (save-excursion (save-restriction ...))")
1586 register Lisp_Object val
;
1587 int count
= specpdl_ptr
- specpdl
;
1589 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
1590 val
= Fprogn (body
);
1591 return unbind_to (count
, val
);
1594 /* Buffer for the most recent text displayed by Fmessage. */
1595 static char *message_text
;
1597 /* Allocated length of that buffer. */
1598 static int message_length
;
1600 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
1601 "Print a one-line message at the bottom of the screen.\n\
1602 The first argument is a format control string, and the rest are data\n\
1603 to be formatted under control of the string. See `format' for details.\n\
1605 If the first argument is nil, clear any existing message; let the\n\
1606 minibuffer contents show.")
1618 register Lisp_Object val
;
1619 val
= Fformat (nargs
, args
);
1620 /* Copy the data so that it won't move when we GC. */
1623 message_text
= (char *)xmalloc (80);
1624 message_length
= 80;
1626 if (XSTRING (val
)->size
> message_length
)
1628 message_length
= XSTRING (val
)->size
;
1629 message_text
= (char *)xrealloc (message_text
, message_length
);
1631 bcopy (XSTRING (val
)->data
, message_text
, XSTRING (val
)->size
);
1632 message2 (message_text
, XSTRING (val
)->size
);
1637 DEFUN ("message-box", Fmessage_box
, Smessage_box
, 1, MANY
, 0,
1638 "Display a message, in a dialog box if possible.\n\
1639 If a dialog box is not available, use the echo area.\n\
1640 The first argument is a control string.\n\
1641 It may contain %s or %d or %c to print successive following arguments.\n\
1642 %s means print an argument as a string, %d means print as number in decimal,\n\
1643 %c means print a number as a single character.\n\
1644 The argument used by %s must be a string or a symbol;\n\
1645 the argument used by %d or %c must be a number.\n\
1646 If the first argument is nil, clear any existing message; let the\n\
1647 minibuffer contents show.")
1659 register Lisp_Object val
;
1660 val
= Fformat (nargs
, args
);
1663 Lisp_Object pane
, menu
, obj
;
1664 struct gcpro gcpro1
;
1665 pane
= Fcons (Fcons (build_string ("OK"), Qt
), Qnil
);
1667 menu
= Fcons (val
, pane
);
1668 obj
= Fx_popup_dialog (Qt
, menu
);
1673 /* Copy the data so that it won't move when we GC. */
1676 message_text
= (char *)xmalloc (80);
1677 message_length
= 80;
1679 if (XSTRING (val
)->size
> message_length
)
1681 message_length
= XSTRING (val
)->size
;
1682 message_text
= (char *)xrealloc (message_text
, message_length
);
1684 bcopy (XSTRING (val
)->data
, message_text
, XSTRING (val
)->size
);
1685 message2 (message_text
, XSTRING (val
)->size
);
1691 extern Lisp_Object last_nonmenu_event
;
1693 DEFUN ("message-or-box", Fmessage_or_box
, Smessage_or_box
, 1, MANY
, 0,
1694 "Display a message in a dialog box or in the echo area.\n\
1695 If this command was invoked with the mouse, use a dialog box.\n\
1696 Otherwise, use the echo area.\n\
1698 The first argument is a control string.\n\
1699 It may contain %s or %d or %c to print successive following arguments.\n\
1700 %s means print an argument as a string, %d means print as number in decimal,\n\
1701 %c means print a number as a single character.\n\
1702 The argument used by %s must be a string or a symbol;\n\
1703 the argument used by %d or %c must be a number.\n\
1704 If the first argument is nil, clear any existing message; let the\n\
1705 minibuffer contents show.")
1711 if (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
1712 return Fmessage_box (nargs
, args
);
1714 return Fmessage (nargs
, args
);
1717 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
1718 "Format a string out of a control-string and arguments.\n\
1719 The first argument is a control string.\n\
1720 The other arguments are substituted into it to make the result, a string.\n\
1721 It may contain %-sequences meaning to substitute the next argument.\n\
1722 %s means print a string argument. Actually, prints any object, with `princ'.\n\
1723 %d means print as number in decimal (%o octal, %x hex).\n\
1724 %e means print a number in exponential notation.\n\
1725 %f means print a number in decimal-point notation.\n\
1726 %g means print a number in exponential notation\n\
1727 or decimal-point notation, whichever uses fewer characters.\n\
1728 %c means print a number as a single character.\n\
1729 %S means print any object as an s-expression (using prin1).\n\
1730 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.\n\
1731 Use %% to put a single % into the output.")
1734 register Lisp_Object
*args
;
1736 register int n
; /* The number of the next arg to substitute */
1737 register int total
= 5; /* An estimate of the final length */
1739 register unsigned char *format
, *end
;
1741 extern char *index ();
1742 /* It should not be necessary to GCPRO ARGS, because
1743 the caller in the interpreter should take care of that. */
1745 CHECK_STRING (args
[0], 0);
1746 format
= XSTRING (args
[0])->data
;
1747 end
= format
+ XSTRING (args
[0])->size
;
1750 while (format
!= end
)
1751 if (*format
++ == '%')
1755 /* Process a numeric arg and skip it. */
1756 minlen
= atoi (format
);
1760 while ((*format
>= '0' && *format
<= '9')
1761 || *format
== '-' || *format
== ' ' || *format
== '.')
1766 else if (++n
>= nargs
)
1767 error ("Not enough arguments for format string");
1768 else if (*format
== 'S')
1770 /* For `S', prin1 the argument and then treat like a string. */
1771 register Lisp_Object tem
;
1772 tem
= Fprin1_to_string (args
[n
], Qnil
);
1776 else if (SYMBOLP (args
[n
]))
1778 XSETSTRING (args
[n
], XSYMBOL (args
[n
])->name
);
1781 else if (STRINGP (args
[n
]))
1784 if (*format
!= 's' && *format
!= 'S')
1785 error ("format specifier doesn't match argument type");
1786 total
+= XSTRING (args
[n
])->size
;
1787 /* We have to put an arbitrary limit on minlen
1788 since otherwise it could make alloca fail. */
1789 if (minlen
< XSTRING (args
[n
])->size
+ 1000)
1792 /* Would get MPV otherwise, since Lisp_Int's `point' to low memory. */
1793 else if (INTEGERP (args
[n
]) && *format
!= 's')
1795 #ifdef LISP_FLOAT_TYPE
1796 /* The following loop assumes the Lisp type indicates
1797 the proper way to pass the argument.
1798 So make sure we have a flonum if the argument should
1800 if (*format
== 'e' || *format
== 'f' || *format
== 'g')
1801 args
[n
] = Ffloat (args
[n
]);
1804 /* We have to put an arbitrary limit on minlen
1805 since otherwise it could make alloca fail. */
1809 #ifdef LISP_FLOAT_TYPE
1810 else if (FLOATP (args
[n
]) && *format
!= 's')
1812 if (! (*format
== 'e' || *format
== 'f' || *format
== 'g'))
1813 args
[n
] = Ftruncate (args
[n
]);
1815 /* We have to put an arbitrary limit on minlen
1816 since otherwise it could make alloca fail. */
1823 /* Anything but a string, convert to a string using princ. */
1824 register Lisp_Object tem
;
1825 tem
= Fprin1_to_string (args
[n
], Qt
);
1832 register int nstrings
= n
+ 1;
1834 /* Allocate twice as many strings as we have %-escapes; floats occupy
1835 two slots, and we're not sure how many of those we have. */
1836 register unsigned char **strings
1837 = (unsigned char **) alloca (2 * nstrings
* sizeof (unsigned char *));
1841 for (n
= 0; n
< nstrings
; n
++)
1844 strings
[i
++] = (unsigned char *) "";
1845 else if (INTEGERP (args
[n
]))
1846 /* We checked above that the corresponding format effector
1847 isn't %s, which would cause MPV. */
1848 strings
[i
++] = (unsigned char *) XINT (args
[n
]);
1849 #ifdef LISP_FLOAT_TYPE
1850 else if (FLOATP (args
[n
]))
1852 union { double d
; char *half
[2]; } u
;
1854 u
.d
= XFLOAT (args
[n
])->data
;
1855 strings
[i
++] = (unsigned char *) u
.half
[0];
1856 strings
[i
++] = (unsigned char *) u
.half
[1];
1860 strings
[i
++] = XSTRING (args
[n
])->data
;
1863 /* Make room in result for all the non-%-codes in the control string. */
1864 total
+= XSTRING (args
[0])->size
;
1866 /* Format it in bigger and bigger buf's until it all fits. */
1869 buf
= (char *) alloca (total
+ 1);
1872 length
= doprnt (buf
, total
+ 1, strings
[0], end
, i
-1, strings
+ 1);
1873 if (buf
[total
- 1] == 0)
1881 return make_string (buf
, length
);
1887 format1 (string1
, arg0
, arg1
, arg2
, arg3
, arg4
)
1888 EMACS_INT arg0
, arg1
, arg2
, arg3
, arg4
;
1902 doprnt (buf
, sizeof buf
, string1
, (char *)0, 5, args
);
1904 doprnt (buf
, sizeof buf
, string1
, (char *)0, 5, &string1
+ 1);
1906 return build_string (buf
);
1909 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
1910 "Return t if two characters match, optionally ignoring case.\n\
1911 Both arguments must be characters (i.e. integers).\n\
1912 Case is ignored if `case-fold-search' is non-nil in the current buffer.")
1914 register Lisp_Object c1
, c2
;
1916 unsigned char *downcase
= DOWNCASE_TABLE
;
1917 CHECK_NUMBER (c1
, 0);
1918 CHECK_NUMBER (c2
, 1);
1920 if (!NILP (current_buffer
->case_fold_search
)
1921 ? (downcase
[0xff & XFASTINT (c1
)] == downcase
[0xff & XFASTINT (c2
)]
1922 && (XFASTINT (c1
) & ~0xff) == (XFASTINT (c2
) & ~0xff))
1923 : XINT (c1
) == XINT (c2
))
1928 /* Transpose the markers in two regions of the current buffer, and
1929 adjust the ones between them if necessary (i.e.: if the regions
1932 Traverses the entire marker list of the buffer to do so, adding an
1933 appropriate amount to some, subtracting from some, and leaving the
1934 rest untouched. Most of this is copied from adjust_markers in insdel.c.
1936 It's the caller's job to see that (start1 <= end1 <= start2 <= end2). */
1939 transpose_markers (start1
, end1
, start2
, end2
)
1940 register int start1
, end1
, start2
, end2
;
1942 register int amt1
, amt2
, diff
, mpos
;
1943 register Lisp_Object marker
;
1945 /* Update point as if it were a marker. */
1949 TEMP_SET_PT (PT
+ (end2
- end1
));
1950 else if (PT
< start2
)
1951 TEMP_SET_PT (PT
+ (end2
- start2
) - (end1
- start1
));
1953 TEMP_SET_PT (PT
- (start2
- start1
));
1955 /* We used to adjust the endpoints here to account for the gap, but that
1956 isn't good enough. Even if we assume the caller has tried to move the
1957 gap out of our way, it might still be at start1 exactly, for example;
1958 and that places it `inside' the interval, for our purposes. The amount
1959 of adjustment is nontrivial if there's a `denormalized' marker whose
1960 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
1961 the dirty work to Fmarker_position, below. */
1963 /* The difference between the region's lengths */
1964 diff
= (end2
- start2
) - (end1
- start1
);
1966 /* For shifting each marker in a region by the length of the other
1967 * region plus the distance between the regions.
1969 amt1
= (end2
- start2
) + (start2
- end1
);
1970 amt2
= (end1
- start1
) + (start2
- end1
);
1972 for (marker
= BUF_MARKERS (current_buffer
); !NILP (marker
);
1973 marker
= XMARKER (marker
)->chain
)
1975 mpos
= Fmarker_position (marker
);
1976 if (mpos
>= start1
&& mpos
< end2
)
1980 else if (mpos
< start2
)
1984 if (mpos
> GPT
) mpos
+= GAP_SIZE
;
1985 XMARKER (marker
)->bufpos
= mpos
;
1990 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
1991 "Transpose region START1 to END1 with START2 to END2.\n\
1992 The regions may not be overlapping, because the size of the buffer is\n\
1993 never changed in a transposition.\n\
1995 Optional fifth arg LEAVE_MARKERS, if non-nil, means don't transpose\n\
1996 any markers that happen to be located in the regions.\n\
1998 Transposing beyond buffer boundaries is an error.")
1999 (startr1
, endr1
, startr2
, endr2
, leave_markers
)
2000 Lisp_Object startr1
, endr1
, startr2
, endr2
, leave_markers
;
2002 register int start1
, end1
, start2
, end2
,
2003 gap
, len1
, len_mid
, len2
;
2004 unsigned char *start1_addr
, *start2_addr
, *temp
;
2006 #ifdef USE_TEXT_PROPERTIES
2007 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
;
2008 cur_intv
= BUF_INTERVALS (current_buffer
);
2009 #endif /* USE_TEXT_PROPERTIES */
2011 validate_region (&startr1
, &endr1
);
2012 validate_region (&startr2
, &endr2
);
2014 start1
= XFASTINT (startr1
);
2015 end1
= XFASTINT (endr1
);
2016 start2
= XFASTINT (startr2
);
2017 end2
= XFASTINT (endr2
);
2020 /* Swap the regions if they're reversed. */
2023 register int glumph
= start1
;
2031 len1
= end1
- start1
;
2032 len2
= end2
- start2
;
2035 error ("transposed regions not properly ordered");
2036 else if (start1
== end1
|| start2
== end2
)
2037 error ("transposed region may not be of length 0");
2039 /* The possibilities are:
2040 1. Adjacent (contiguous) regions, or separate but equal regions
2041 (no, really equal, in this case!), or
2042 2. Separate regions of unequal size.
2044 The worst case is usually No. 2. It means that (aside from
2045 potential need for getting the gap out of the way), there also
2046 needs to be a shifting of the text between the two regions. So
2047 if they are spread far apart, we are that much slower... sigh. */
2049 /* It must be pointed out that the really studly thing to do would
2050 be not to move the gap at all, but to leave it in place and work
2051 around it if necessary. This would be extremely efficient,
2052 especially considering that people are likely to do
2053 transpositions near where they are working interactively, which
2054 is exactly where the gap would be found. However, such code
2055 would be much harder to write and to read. So, if you are
2056 reading this comment and are feeling squirrely, by all means have
2057 a go! I just didn't feel like doing it, so I will simply move
2058 the gap the minimum distance to get it out of the way, and then
2059 deal with an unbroken array. */
2061 /* Make sure the gap won't interfere, by moving it out of the text
2062 we will operate on. */
2063 if (start1
< gap
&& gap
< end2
)
2065 if (gap
- start1
< end2
- gap
)
2071 /* Hmmm... how about checking to see if the gap is large
2072 enough to use as the temporary storage? That would avoid an
2073 allocation... interesting. Later, don't fool with it now. */
2075 /* Working without memmove, for portability (sigh), so must be
2076 careful of overlapping subsections of the array... */
2078 if (end1
== start2
) /* adjacent regions */
2080 modify_region (current_buffer
, start1
, end2
);
2081 record_change (start1
, len1
+ len2
);
2083 #ifdef USE_TEXT_PROPERTIES
2084 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
2085 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
2086 Fset_text_properties (start1
, end2
, Qnil
, Qnil
);
2087 #endif /* USE_TEXT_PROPERTIES */
2089 /* First region smaller than second. */
2092 /* We use alloca only if it is small,
2093 because we want to avoid stack overflow. */
2095 temp
= (unsigned char *) xmalloc (len2
);
2097 temp
= (unsigned char *) alloca (len2
);
2099 /* Don't precompute these addresses. We have to compute them
2100 at the last minute, because the relocating allocator might
2101 have moved the buffer around during the xmalloc. */
2102 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1
);
2103 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2
);
2105 bcopy (start2_addr
, temp
, len2
);
2106 bcopy (start1_addr
, start1_addr
+ len2
, len1
);
2107 bcopy (temp
, start1_addr
, len2
);
2112 /* First region not smaller than second. */
2115 temp
= (unsigned char *) xmalloc (len1
);
2117 temp
= (unsigned char *) alloca (len1
);
2118 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1
);
2119 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2
);
2120 bcopy (start1_addr
, temp
, len1
);
2121 bcopy (start2_addr
, start1_addr
, len2
);
2122 bcopy (temp
, start1_addr
+ len2
, len1
);
2126 #ifdef USE_TEXT_PROPERTIES
2127 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
2128 len1
, current_buffer
, 0);
2129 graft_intervals_into_buffer (tmp_interval2
, start1
,
2130 len2
, current_buffer
, 0);
2131 #endif /* USE_TEXT_PROPERTIES */
2133 /* Non-adjacent regions, because end1 != start2, bleagh... */
2137 /* Regions are same size, though, how nice. */
2139 modify_region (current_buffer
, start1
, end1
);
2140 modify_region (current_buffer
, start2
, end2
);
2141 record_change (start1
, len1
);
2142 record_change (start2
, len2
);
2143 #ifdef USE_TEXT_PROPERTIES
2144 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
2145 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
2146 Fset_text_properties (start1
, end1
, Qnil
, Qnil
);
2147 Fset_text_properties (start2
, end2
, Qnil
, Qnil
);
2148 #endif /* USE_TEXT_PROPERTIES */
2151 temp
= (unsigned char *) xmalloc (len1
);
2153 temp
= (unsigned char *) alloca (len1
);
2154 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1
);
2155 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2
);
2156 bcopy (start1_addr
, temp
, len1
);
2157 bcopy (start2_addr
, start1_addr
, len2
);
2158 bcopy (temp
, start2_addr
, len1
);
2161 #ifdef USE_TEXT_PROPERTIES
2162 graft_intervals_into_buffer (tmp_interval1
, start2
,
2163 len1
, current_buffer
, 0);
2164 graft_intervals_into_buffer (tmp_interval2
, start1
,
2165 len2
, current_buffer
, 0);
2166 #endif /* USE_TEXT_PROPERTIES */
2169 else if (len1
< len2
) /* Second region larger than first */
2170 /* Non-adjacent & unequal size, area between must also be shifted. */
2172 len_mid
= start2
- end1
;
2173 modify_region (current_buffer
, start1
, end2
);
2174 record_change (start1
, (end2
- start1
));
2175 #ifdef USE_TEXT_PROPERTIES
2176 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
2177 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
2178 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
2179 Fset_text_properties (start1
, end2
, Qnil
, Qnil
);
2180 #endif /* USE_TEXT_PROPERTIES */
2182 /* holds region 2 */
2184 temp
= (unsigned char *) xmalloc (len2
);
2186 temp
= (unsigned char *) alloca (len2
);
2187 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1
);
2188 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2
);
2189 bcopy (start2_addr
, temp
, len2
);
2190 bcopy (start1_addr
, start1_addr
+ len_mid
+ len2
, len1
);
2191 safe_bcopy (start1_addr
+ len1
, start1_addr
+ len2
, len_mid
);
2192 bcopy (temp
, start1_addr
, len2
);
2195 #ifdef USE_TEXT_PROPERTIES
2196 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
2197 len1
, current_buffer
, 0);
2198 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
2199 len_mid
, current_buffer
, 0);
2200 graft_intervals_into_buffer (tmp_interval2
, start1
,
2201 len2
, current_buffer
, 0);
2202 #endif /* USE_TEXT_PROPERTIES */
2205 /* Second region smaller than first. */
2207 len_mid
= start2
- end1
;
2208 record_change (start1
, (end2
- start1
));
2209 modify_region (current_buffer
, start1
, end2
);
2211 #ifdef USE_TEXT_PROPERTIES
2212 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
2213 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
2214 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
2215 Fset_text_properties (start1
, end2
, Qnil
, Qnil
);
2216 #endif /* USE_TEXT_PROPERTIES */
2218 /* holds region 1 */
2220 temp
= (unsigned char *) xmalloc (len1
);
2222 temp
= (unsigned char *) alloca (len1
);
2223 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1
);
2224 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2
);
2225 bcopy (start1_addr
, temp
, len1
);
2226 bcopy (start2_addr
, start1_addr
, len2
);
2227 bcopy (start1_addr
+ len1
, start1_addr
+ len2
, len_mid
);
2228 bcopy (temp
, start1_addr
+ len2
+ len_mid
, len1
);
2231 #ifdef USE_TEXT_PROPERTIES
2232 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
2233 len1
, current_buffer
, 0);
2234 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
2235 len_mid
, current_buffer
, 0);
2236 graft_intervals_into_buffer (tmp_interval2
, start1
,
2237 len2
, current_buffer
, 0);
2238 #endif /* USE_TEXT_PROPERTIES */
2242 /* todo: this will be slow, because for every transposition, we
2243 traverse the whole friggin marker list. Possible solutions:
2244 somehow get a list of *all* the markers across multiple
2245 transpositions and do it all in one swell phoop. Or maybe modify
2246 Emacs' marker code to keep an ordered list or tree. This might
2247 be nicer, and more beneficial in the long run, but would be a
2248 bunch of work. Plus the way they're arranged now is nice. */
2249 if (NILP (leave_markers
))
2251 transpose_markers (start1
, end1
, start2
, end2
);
2252 fix_overlays_in_range (start1
, end2
);
2262 DEFVAR_LISP ("system-name", &Vsystem_name
,
2263 "The name of the machine Emacs is running on.");
2265 DEFVAR_LISP ("user-full-name", &Vuser_full_name
,
2266 "The full name of the user logged in.");
2268 DEFVAR_LISP ("user-login-name", &Vuser_login_name
,
2269 "The user's name, taken from environment variables if possible.");
2271 DEFVAR_LISP ("user-real-login-name", &Vuser_real_login_name
,
2272 "The user's name, based upon the real uid only.");
2274 defsubr (&Schar_equal
);
2275 defsubr (&Sgoto_char
);
2276 defsubr (&Sstring_to_char
);
2277 defsubr (&Schar_to_string
);
2278 defsubr (&Sbuffer_substring
);
2279 defsubr (&Sbuffer_string
);
2281 defsubr (&Spoint_marker
);
2282 defsubr (&Smark_marker
);
2284 defsubr (&Sregion_beginning
);
2285 defsubr (&Sregion_end
);
2286 /* defsubr (&Smark); */
2287 /* defsubr (&Sset_mark); */
2288 defsubr (&Ssave_excursion
);
2290 defsubr (&Sbufsize
);
2291 defsubr (&Spoint_max
);
2292 defsubr (&Spoint_min
);
2293 defsubr (&Spoint_min_marker
);
2294 defsubr (&Spoint_max_marker
);
2300 defsubr (&Sfollowing_char
);
2301 defsubr (&Sprevious_char
);
2302 defsubr (&Schar_after
);
2304 defsubr (&Sinsert_before_markers
);
2305 defsubr (&Sinsert_and_inherit
);
2306 defsubr (&Sinsert_and_inherit_before_markers
);
2307 defsubr (&Sinsert_char
);
2309 defsubr (&Suser_login_name
);
2310 defsubr (&Suser_real_login_name
);
2311 defsubr (&Suser_uid
);
2312 defsubr (&Suser_real_uid
);
2313 defsubr (&Suser_full_name
);
2314 defsubr (&Semacs_pid
);
2315 defsubr (&Scurrent_time
);
2316 defsubr (&Sformat_time_string
);
2317 defsubr (&Sdecode_time
);
2318 defsubr (&Sencode_time
);
2319 defsubr (&Scurrent_time_string
);
2320 defsubr (&Scurrent_time_zone
);
2321 defsubr (&Ssystem_name
);
2322 defsubr (&Smessage
);
2323 defsubr (&Smessage_box
);
2324 defsubr (&Smessage_or_box
);
2327 defsubr (&Sinsert_buffer_substring
);
2328 defsubr (&Scompare_buffer_substrings
);
2329 defsubr (&Ssubst_char_in_region
);
2330 defsubr (&Stranslate_region
);
2331 defsubr (&Sdelete_region
);
2333 defsubr (&Snarrow_to_region
);
2334 defsubr (&Ssave_restriction
);
2335 defsubr (&Stranspose_regions
);