Use WORDS_BIG_ENDIAN, not BIG_ENDIAN.
[bpt/emacs.git] / src / editfns.c
CommitLineData
35692fe0 1/* Lisp functions pertaining to editing.
9772455e 2 Copyright (C) 1985, 1986, 1987, 1989, 1993 Free Software Foundation, Inc.
35692fe0
JB
3
4This file is part of GNU Emacs.
5
6GNU Emacs is free software; you can redistribute it and/or modify
7it under the terms of the GNU General Public License as published by
8the Free Software Foundation; either version 1, or (at your option)
9any later version.
10
11GNU Emacs is distributed in the hope that it will be useful,
12but WITHOUT ANY WARRANTY; without even the implied warranty of
13MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14GNU General Public License for more details.
15
16You should have received a copy of the GNU General Public License
17along with GNU Emacs; see the file COPYING. If not, write to
18the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
19
20
738429d1
JB
21#include <sys/types.h>
22
18160b98 23#include <config.h>
bfb61299
JB
24
25#ifdef VMS
956ace37 26#include "vms-pwd.h"
bfb61299 27#else
35692fe0 28#include <pwd.h>
bfb61299
JB
29#endif
30
35692fe0 31#include "lisp.h"
74d6d8c5 32#include "intervals.h"
35692fe0
JB
33#include "buffer.h"
34#include "window.h"
35
956ace37 36#include "systime.h"
35692fe0
JB
37
38#define min(a, b) ((a) < (b) ? (a) : (b))
39#define max(a, b) ((a) > (b) ? (a) : (b))
40
41/* Some static data, and a function to initialize it for each run */
42
43Lisp_Object Vsystem_name;
44Lisp_Object Vuser_real_name; /* login name of current user ID */
45Lisp_Object Vuser_full_name; /* full name of current user */
46Lisp_Object Vuser_name; /* user name from USER or LOGNAME. */
47
48void
49init_editfns ()
50{
52b14ac0 51 char *user_name;
35692fe0
JB
52 register unsigned char *p, *q, *r;
53 struct passwd *pw; /* password entry for the current user */
54 extern char *index ();
55 Lisp_Object tem;
56
57 /* Set up system_name even when dumping. */
58
59 Vsystem_name = build_string (get_system_name ());
60 p = XSTRING (Vsystem_name)->data;
61 while (*p)
62 {
63 if (*p == ' ' || *p == '\t')
64 *p = '-';
65 p++;
66 }
67
68#ifndef CANNOT_DUMP
69 /* Don't bother with this on initial start when just dumping out */
70 if (!initialized)
71 return;
72#endif /* not CANNOT_DUMP */
73
74 pw = (struct passwd *) getpwuid (getuid ());
75 Vuser_real_name = build_string (pw ? pw->pw_name : "unknown");
76
52b14ac0
JB
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");
35692fe0 80 if (!user_name)
52b14ac0
JB
81 user_name = (char *) getenv ("LOGNAME");
82 if (!user_name)
83 {
84 pw = (struct passwd *) getpwuid (geteuid ());
85 user_name = (char *) (pw ? pw->pw_name : "unknown");
86 }
87 Vuser_name = build_string (user_name);
35692fe0 88
52b14ac0
JB
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. */
35692fe0 91 tem = Fstring_equal (Vuser_name, Vuser_real_name);
56a98455 92 if (NILP (tem))
52b14ac0 93 pw = (struct passwd *) getpwnam (XSTRING (Vuser_name)->data);
35692fe0
JB
94
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));
98
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. */
103 if (q)
104 {
105 r = (char *) alloca (strlen (p) + XSTRING (Vuser_name)->size + 1);
106 bcopy (p, r, q - p);
107 r[q - p] = 0;
52b14ac0 108 strcat (r, XSTRING (Vuser_name)->data);
35692fe0
JB
109 r[q - p] = UPCASE (r[q - p]);
110 strcat (r, q + 1);
111 Vuser_full_name = build_string (r);
112 }
113#endif /* AMPERSAND_FULL_NAME */
114}
115\f
116DEFUN ("char-to-string", Fchar_to_string, Schar_to_string, 1, 1, 0,
117 "Convert arg CHAR to a one-character string containing that character.")
118 (n)
119 Lisp_Object n;
120{
121 char c;
122 CHECK_NUMBER (n, 0);
123
124 c = XINT (n);
125 return make_string (&c, 1);
126}
127
128DEFUN ("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.")
130 (str)
131 register Lisp_Object str;
132{
133 register Lisp_Object val;
134 register struct Lisp_String *p;
135 CHECK_STRING (str, 0);
136
137 p = XSTRING (str);
138 if (p->size)
139 XFASTINT (val) = ((unsigned char *) p->data)[0];
140 else
141 XFASTINT (val) = 0;
142 return val;
143}
144\f
145static Lisp_Object
146buildmark (val)
147 int val;
148{
149 register Lisp_Object mark;
150 mark = Fmake_marker ();
151 Fset_marker (mark, make_number (val), Qnil);
152 return mark;
153}
154
155DEFUN ("point", Fpoint, Spoint, 0, 0, 0,
156 "Return value of point, as an integer.\n\
157Beginning of buffer is position (point-min)")
158 ()
159{
160 Lisp_Object temp;
161 XFASTINT (temp) = point;
162 return temp;
163}
164
165DEFUN ("point-marker", Fpoint_marker, Spoint_marker, 0, 0, 0,
166 "Return value of point, as a marker object.")
167 ()
168{
169 return buildmark (point);
170}
171
172int
173clip_to_bounds (lower, num, upper)
174 int lower, num, upper;
175{
176 if (num < lower)
177 return lower;
178 else if (num > upper)
179 return upper;
180 else
181 return num;
182}
183
184DEFUN ("goto-char", Fgoto_char, Sgoto_char, 1, 1, "NGoto char: ",
185 "Set point to POSITION, a number or marker.\n\
186Beginning of buffer is position (point-min), end is (point-max).")
187 (n)
188 register Lisp_Object n;
189{
190 CHECK_NUMBER_COERCE_MARKER (n, 0);
191
192 SET_PT (clip_to_bounds (BEGV, XINT (n), ZV));
193 return n;
194}
195
196static Lisp_Object
197region_limit (beginningp)
198 int beginningp;
199{
646d9d18 200 extern Lisp_Object Vmark_even_if_inactive; /* Defined in callint.c. */
35692fe0 201 register Lisp_Object m;
c9dd14e1
RM
202 if (!NILP (Vtransient_mark_mode) && NILP (Vmark_even_if_inactive)
203 && NILP (current_buffer->mark_active))
204 Fsignal (Qmark_inactive, Qnil);
35692fe0 205 m = Fmarker_position (current_buffer->mark);
56a98455 206 if (NILP (m)) error ("There is no region now");
35692fe0
JB
207 if ((point < XFASTINT (m)) == beginningp)
208 return (make_number (point));
209 else
210 return (m);
211}
212
213DEFUN ("region-beginning", Fregion_beginning, Sregion_beginning, 0, 0, 0,
214 "Return position of beginning of region, as an integer.")
215 ()
216{
217 return (region_limit (1));
218}
219
220DEFUN ("region-end", Fregion_end, Sregion_end, 0, 0, 0,
221 "Return position of end of region, as an integer.")
222 ()
223{
224 return (region_limit (0));
225}
226
227#if 0 /* now in lisp code */
228DEFUN ("mark", Fmark, Smark, 0, 0, 0,
229 "Return this buffer's mark value as integer, or nil if no mark.\n\
230If you are using this in an editing command, you are most likely making\n\
231a mistake; see the documentation of `set-mark'.")
232 ()
233{
234 return Fmarker_position (current_buffer->mark);
235}
236#endif /* commented out code */
237
238DEFUN ("mark-marker", Fmark_marker, Smark_marker, 0, 0, 0,
239 "Return this buffer's mark, as a marker object.\n\
240Watch out! Moving this marker changes the mark position.\n\
241If you set the marker not to point anywhere, the buffer will have no mark.")
242 ()
243{
244 return current_buffer->mark;
245}
246
247#if 0 /* this is now in lisp code */
248DEFUN ("set-mark", Fset_mark, Sset_mark, 1, 1, 0,
249 "Set this buffer's mark to POS. Don't use this function!\n\
250That is to say, don't use this function unless you want\n\
251the user to see that the mark has moved, and you want the previous\n\
252mark position to be lost.\n\
253\n\
254Normally, when a new mark is set, the old one should go on the stack.\n\
255This is why most applications should use push-mark, not set-mark.\n\
256\n\
257Novice programmers often try to use the mark for the wrong purposes.\n\
258The mark saves a location for the user's convenience.\n\
259Most editing commands should not alter the mark.\n\
260To remember a location for internal use in the Lisp program,\n\
261store it in a Lisp variable. Example:\n\
262\n\
263 (let ((beg (point))) (forward-line 1) (delete-region beg (point))).")
264 (pos)
265 Lisp_Object pos;
266{
56a98455 267 if (NILP (pos))
35692fe0
JB
268 {
269 current_buffer->mark = Qnil;
270 return Qnil;
271 }
272 CHECK_NUMBER_COERCE_MARKER (pos, 0);
273
56a98455 274 if (NILP (current_buffer->mark))
35692fe0
JB
275 current_buffer->mark = Fmake_marker ();
276
277 Fset_marker (current_buffer->mark, pos, Qnil);
278 return pos;
279}
280#endif /* commented-out code */
281
282Lisp_Object
283save_excursion_save ()
284{
0e2c9c70
JB
285 register int visible = (XBUFFER (XWINDOW (selected_window)->buffer)
286 == current_buffer);
35692fe0
JB
287
288 return Fcons (Fpoint_marker (),
0e2c9c70 289 Fcons (Fcopy_marker (current_buffer->mark),
9772455e
RS
290 Fcons (visible ? Qt : Qnil,
291 current_buffer->mark_active)));
35692fe0
JB
292}
293
294Lisp_Object
295save_excursion_restore (info)
296 register Lisp_Object info;
297{
9772455e 298 register Lisp_Object tem, tem1;
35692fe0
JB
299
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
303 and crash */
304 /* In that case, Fmarker_buffer returns nil now. */
56a98455 305 if (NILP (tem))
35692fe0
JB
306 return Qnil;
307 Fset_buffer (tem);
308 tem = Fcar (info);
309 Fgoto_char (tem);
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));
ef580991
RS
315#if 0 /* We used to make the current buffer visible in the selected window
316 if that was true previously. That avoids some anomalies.
317 But it creates others, and it wasn't documented, and it is simpler
318 and cleaner never to alter the window/buffer connections. */
9772455e
RS
319 tem1 = Fcar (tem);
320 if (!NILP (tem1)
0e2c9c70 321 && current_buffer != XBUFFER (XWINDOW (selected_window)->buffer))
35692fe0 322 Fswitch_to_buffer (Fcurrent_buffer (), Qnil);
ef580991 323#endif /* 0 */
9772455e
RS
324
325 tem1 = current_buffer->mark_active;
326 current_buffer->mark_active = Fcdr (tem);
327 if (! NILP (current_buffer->mark_active))
328 call1 (Vrun_hooks, intern ("activate-mark-hook"));
329 else if (! NILP (tem1))
330 call1 (Vrun_hooks, intern ("deactivate-mark-hook"));
35692fe0
JB
331 return Qnil;
332}
333
334DEFUN ("save-excursion", Fsave_excursion, Ssave_excursion, 0, UNEVALLED, 0,
335 "Save point, mark, and current buffer; execute BODY; restore those things.\n\
336Executes BODY just like `progn'.\n\
337The values of point, mark and the current buffer are restored\n\
9772455e
RS
338even in case of abnormal exit (throw or error).\n\
339The state of activation of the mark is also restored.")
35692fe0
JB
340 (args)
341 Lisp_Object args;
342{
343 register Lisp_Object val;
344 int count = specpdl_ptr - specpdl;
345
346 record_unwind_protect (save_excursion_restore, save_excursion_save ());
347
348 val = Fprogn (args);
349 return unbind_to (count, val);
350}
351\f
352DEFUN ("buffer-size", Fbufsize, Sbufsize, 0, 0, 0,
353 "Return the number of characters in the current buffer.")
354 ()
355{
356 Lisp_Object temp;
357 XFASTINT (temp) = Z - BEG;
358 return temp;
359}
360
361DEFUN ("point-min", Fpoint_min, Spoint_min, 0, 0, 0,
362 "Return the minimum permissible value of point in the current buffer.\n\
4c390850 363This is 1, unless narrowing (a buffer restriction) is in effect.")
35692fe0
JB
364 ()
365{
366 Lisp_Object temp;
367 XFASTINT (temp) = BEGV;
368 return temp;
369}
370
371DEFUN ("point-min-marker", Fpoint_min_marker, Spoint_min_marker, 0, 0, 0,
372 "Return a marker to the minimum permissible value of point in this buffer.\n\
4c390850 373This is the beginning, unless narrowing (a buffer restriction) is in effect.")
35692fe0
JB
374 ()
375{
376 return buildmark (BEGV);
377}
378
379DEFUN ("point-max", Fpoint_max, Spoint_max, 0, 0, 0,
380 "Return the maximum permissible value of point in the current buffer.\n\
4c390850
RS
381This is (1+ (buffer-size)), unless narrowing (a buffer restriction)\n\
382is in effect, in which case it is less.")
35692fe0
JB
383 ()
384{
385 Lisp_Object temp;
386 XFASTINT (temp) = ZV;
387 return temp;
388}
389
390DEFUN ("point-max-marker", Fpoint_max_marker, Spoint_max_marker, 0, 0, 0,
391 "Return a marker to the maximum permissible value of point in this buffer.\n\
4c390850
RS
392This is (1+ (buffer-size)), unless narrowing (a buffer restriction)\n\
393is in effect, in which case it is less.")
35692fe0
JB
394 ()
395{
396 return buildmark (ZV);
397}
398
850a8179
JB
399DEFUN ("following-char", Ffollowing_char, Sfollowing_char, 0, 0, 0,
400 "Return the character following point, as a number.\n\
401At the end of the buffer or accessible region, return 0.")
35692fe0
JB
402 ()
403{
404 Lisp_Object temp;
850a8179
JB
405 if (point >= ZV)
406 XFASTINT (temp) = 0;
407 else
408 XFASTINT (temp) = FETCH_CHAR (point);
35692fe0
JB
409 return temp;
410}
411
850a8179
JB
412DEFUN ("preceding-char", Fprevious_char, Sprevious_char, 0, 0, 0,
413 "Return the character preceding point, as a number.\n\
414At the beginning of the buffer or accessible region, return 0.")
35692fe0
JB
415 ()
416{
417 Lisp_Object temp;
418 if (point <= BEGV)
419 XFASTINT (temp) = 0;
420 else
421 XFASTINT (temp) = FETCH_CHAR (point - 1);
422 return temp;
423}
424
425DEFUN ("bobp", Fbobp, Sbobp, 0, 0, 0,
426 "Return T if point is at the beginning of the buffer.\n\
427If the buffer is narrowed, this means the beginning of the narrowed part.")
428 ()
429{
430 if (point == BEGV)
431 return Qt;
432 return Qnil;
433}
434
435DEFUN ("eobp", Feobp, Seobp, 0, 0, 0,
436 "Return T if point is at the end of the buffer.\n\
437If the buffer is narrowed, this means the end of the narrowed part.")
438 ()
439{
440 if (point == ZV)
441 return Qt;
442 return Qnil;
443}
444
445DEFUN ("bolp", Fbolp, Sbolp, 0, 0, 0,
446 "Return T if point is at the beginning of a line.")
447 ()
448{
449 if (point == BEGV || FETCH_CHAR (point - 1) == '\n')
450 return Qt;
451 return Qnil;
452}
453
454DEFUN ("eolp", Feolp, Seolp, 0, 0, 0,
455 "Return T if point is at the end of a line.\n\
456`End of a line' includes point being at the end of the buffer.")
457 ()
458{
459 if (point == ZV || FETCH_CHAR (point) == '\n')
460 return Qt;
461 return Qnil;
462}
463
464DEFUN ("char-after", Fchar_after, Schar_after, 1, 1, 0,
465 "Return character in current buffer at position POS.\n\
466POS is an integer or a buffer pointer.\n\
467If POS is out of range, the value is nil.")
468 (pos)
469 Lisp_Object pos;
470{
471 register Lisp_Object val;
472 register int n;
473
474 CHECK_NUMBER_COERCE_MARKER (pos, 0);
475
476 n = XINT (pos);
477 if (n < BEGV || n >= ZV) return Qnil;
478
479 XFASTINT (val) = FETCH_CHAR (n);
480 return val;
481}
482\f
483DEFUN ("user-login-name", Fuser_login_name, Suser_login_name, 0, 0, 0,
484 "Return the name under which the user logged in, as a string.\n\
485This is based on the effective uid, not the real uid.\n\
486Also, if the environment variable USER or LOGNAME is set,\n\
487that determines the value of this function.")
488 ()
489{
490 return Vuser_name;
491}
492
493DEFUN ("user-real-login-name", Fuser_real_login_name, Suser_real_login_name,
494 0, 0, 0,
495 "Return the name of the user's real uid, as a string.\n\
496Differs from `user-login-name' when running under `su'.")
497 ()
498{
499 return Vuser_real_name;
500}
501
502DEFUN ("user-uid", Fuser_uid, Suser_uid, 0, 0, 0,
503 "Return the effective uid of Emacs, as an integer.")
504 ()
505{
506 return make_number (geteuid ());
507}
508
509DEFUN ("user-real-uid", Fuser_real_uid, Suser_real_uid, 0, 0, 0,
510 "Return the real uid of Emacs, as an integer.")
511 ()
512{
513 return make_number (getuid ());
514}
515
516DEFUN ("user-full-name", Fuser_full_name, Suser_full_name, 0, 0, 0,
517 "Return the full name of the user logged in, as a string.")
518 ()
519{
520 return Vuser_full_name;
521}
522
523DEFUN ("system-name", Fsystem_name, Ssystem_name, 0, 0, 0,
524 "Return the name of the machine you are running on, as a string.")
525 ()
526{
527 return Vsystem_name;
528}
529
d940e0e4 530DEFUN ("current-time", Fcurrent_time, Scurrent_time, 0, 0, 0,
956ace37
JB
531 "Return the current time, as the number of seconds since 12:00 AM January 1970.\n\
532The time is returned as a list of three integers. The first has the\n\
533most significant 16 bits of the seconds, while the second has the\n\
534least significant 16 bits. The third integer gives the microsecond\n\
535count.\n\
536\n\
537The microsecond count is zero on systems that do not provide\n\
538resolution finer than a second.")
d940e0e4
JB
539 ()
540{
956ace37
JB
541 EMACS_TIME t;
542 Lisp_Object result[3];
543
544 EMACS_GET_TIME (t);
545 XSET (result[0], Lisp_Int, (EMACS_SECS (t) >> 16) & 0xffff);
546 XSET (result[1], Lisp_Int, (EMACS_SECS (t) >> 0) & 0xffff);
547 XSET (result[2], Lisp_Int, EMACS_USECS (t));
548
549 return Flist (3, result);
d940e0e4
JB
550}
551\f
552
e3120ab5
JB
553static int
554lisp_time_argument (specified_time, result)
555 Lisp_Object specified_time;
556 time_t *result;
557{
558 if (NILP (specified_time))
559 return time (result) != -1;
560 else
561 {
562 Lisp_Object high, low;
563 high = Fcar (specified_time);
564 CHECK_NUMBER (high, 0);
565 low = Fcdr (specified_time);
566 if (XTYPE (low) == Lisp_Cons)
567 low = Fcar (low);
568 CHECK_NUMBER (low, 0);
569 *result = (XINT (high) << 16) + (XINT (low) & 0xffff);
570 return *result >> 16 == XINT (high);
571 }
572}
573
2148f2b4 574DEFUN ("current-time-string", Fcurrent_time_string, Scurrent_time_string, 0, 1, 0,
35692fe0 575 "Return the current time, as a human-readable string.\n\
2148f2b4
RS
576Programs can use this function to decode a time,\n\
577since the number of columns in each field is fixed.\n\
578The format is `Sun Sep 16 01:03:52 1973'.\n\
579If an argument is given, it specifies a time to format\n\
580instead of the current time. The argument should have the form:\n\
581 (HIGH . LOW)\n\
582or the form:\n\
583 (HIGH LOW . IGNORED).\n\
584Thus, you can use times obtained from `current-time'\n\
585and from `file-attributes'.")
586 (specified_time)
587 Lisp_Object specified_time;
588{
e3120ab5 589 time_t value;
35692fe0 590 char buf[30];
2148f2b4
RS
591 register char *tem;
592
e3120ab5
JB
593 if (! lisp_time_argument (specified_time, &value))
594 value = -1;
2148f2b4 595 tem = (char *) ctime (&value);
35692fe0
JB
596
597 strncpy (buf, tem, 24);
598 buf[24] = 0;
599
600 return build_string (buf);
601}
c2662aea 602
e3120ab5
JB
603#define TM_YEAR_ORIGIN 1900
604
605/* Yield A - B, measured in seconds. */
606static long
607difftm(a, b)
608 struct tm *a, *b;
609{
610 int ay = a->tm_year + (TM_YEAR_ORIGIN - 1);
611 int by = b->tm_year + (TM_YEAR_ORIGIN - 1);
612 return
613 (
614 (
615 (
616 /* difference in day of year */
617 a->tm_yday - b->tm_yday
618 /* + intervening leap days */
619 + ((ay >> 2) - (by >> 2))
620 - (ay/100 - by/100)
621 + ((ay/100 >> 2) - (by/100 >> 2))
622 /* + difference in years * 365 */
623 + (long)(ay-by) * 365
624 )*24 + (a->tm_hour - b->tm_hour)
625 )*60 + (a->tm_min - b->tm_min)
626 )*60 + (a->tm_sec - b->tm_sec);
627}
628
629DEFUN ("current-time-zone", Fcurrent_time_zone, Scurrent_time_zone, 0, 1, 0,
630 "Return the offset and name for the local time zone.\n\
631This returns a list of the form (OFFSET NAME).\n\
632OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).\n\
633 A negative value means west of Greenwich.\n\
634NAME is a string giving the name of the time zone.\n\
635If an argument is given, it specifies when the time zone offset is determined\n\
636instead of using the current time. The argument should have the form:\n\
637 (HIGH . LOW)\n\
638or the form:\n\
639 (HIGH LOW . IGNORED).\n\
640Thus, you can use times obtained from `current-time'\n\
641and from `file-attributes'.\n\
773c1fd3
JB
642\n\
643Some operating systems cannot provide all this information to Emacs;\n\
2d88f747 644in this case, `current-time-zone' returns a list containing nil for\n\
773c1fd3 645the data it can't find.")
e3120ab5
JB
646 (specified_time)
647 Lisp_Object specified_time;
c2662aea 648{
e3120ab5
JB
649 time_t value;
650 struct tm *t;
c2662aea 651
e3120ab5 652 if (lisp_time_argument (specified_time, &value)
2d88f747 653 && (t = gmtime (&value)) != 0)
e3120ab5 654 {
2d88f747 655 struct tm gmt;
e3120ab5
JB
656 long offset;
657 char *s, buf[6];
2d88f747
RS
658
659 gmt = *t; /* Make a copy, in case localtime modifies *t. */
660 t = localtime (&value);
661 offset = difftm (t, &gmt);
e3120ab5
JB
662 s = 0;
663#ifdef HAVE_TM_ZONE
664 if (t->tm_zone)
665 s = t->tm_zone;
a7971c39
RS
666#else /* not HAVE_TM_ZONE */
667#ifdef HAVE_TZNAME
668 if (t->tm_isdst == 0 || t->tm_isdst == 1)
669 s = tzname[t->tm_isdst];
c2662aea 670#endif
a7971c39 671#endif /* not HAVE_TM_ZONE */
e3120ab5
JB
672 if (!s)
673 {
674 /* No local time zone name is available; use "+-NNNN" instead. */
00fc94d0 675 int am = (offset < 0 ? -offset : offset) / 60;
e3120ab5
JB
676 sprintf (buf, "%c%02d%02d", (offset < 0 ? '-' : '+'), am/60, am%60);
677 s = buf;
678 }
679 return Fcons (make_number (offset), Fcons (build_string (s), Qnil));
680 }
681 else
682 return Fmake_list (2, Qnil);
c2662aea
JB
683}
684
35692fe0
JB
685\f
686void
687insert1 (arg)
688 Lisp_Object arg;
689{
690 Finsert (1, &arg);
691}
692
52b14ac0
JB
693
694/* Callers passing one argument to Finsert need not gcpro the
695 argument "array", since the only element of the array will
696 not be used after calling insert or insert_from_string, so
697 we don't care if it gets trashed. */
698
35692fe0
JB
699DEFUN ("insert", Finsert, Sinsert, 0, MANY, 0,
700 "Insert the arguments, either strings or characters, at point.\n\
701Point moves forward so that it ends up after the inserted text.\n\
702Any other markers at the point of insertion remain before the text.")
703 (nargs, args)
704 int nargs;
705 register Lisp_Object *args;
706{
707 register int argnum;
708 register Lisp_Object tem;
709 char str[1];
35692fe0
JB
710
711 for (argnum = 0; argnum < nargs; argnum++)
712 {
713 tem = args[argnum];
714 retry:
715 if (XTYPE (tem) == Lisp_Int)
716 {
717 str[0] = XINT (tem);
718 insert (str, 1);
719 }
720 else if (XTYPE (tem) == Lisp_String)
721 {
be91036a
RS
722 insert_from_string (tem, 0, XSTRING (tem)->size, 0);
723 }
724 else
725 {
726 tem = wrong_type_argument (Qchar_or_string_p, tem);
727 goto retry;
728 }
729 }
730
731 return Qnil;
732}
733
734DEFUN ("insert-and-inherit", Finsert_and_inherit, Sinsert_and_inherit,
735 0, MANY, 0,
736 "Insert the arguments at point, inheriting properties from adjoining text.\n\
737Point moves forward so that it ends up after the inserted text.\n\
738Any other markers at the point of insertion remain before the text.")
739 (nargs, args)
740 int nargs;
741 register Lisp_Object *args;
742{
743 register int argnum;
744 register Lisp_Object tem;
745 char str[1];
746
747 for (argnum = 0; argnum < nargs; argnum++)
748 {
749 tem = args[argnum];
750 retry:
751 if (XTYPE (tem) == Lisp_Int)
752 {
753 str[0] = XINT (tem);
754 insert (str, 1);
755 }
756 else if (XTYPE (tem) == Lisp_String)
757 {
758 insert_from_string (tem, 0, XSTRING (tem)->size, 1);
35692fe0
JB
759 }
760 else
761 {
762 tem = wrong_type_argument (Qchar_or_string_p, tem);
763 goto retry;
764 }
765 }
766
35692fe0
JB
767 return Qnil;
768}
769
770DEFUN ("insert-before-markers", Finsert_before_markers, Sinsert_before_markers, 0, MANY, 0,
771 "Insert strings or characters at point, relocating markers after the text.\n\
772Point moves forward so that it ends up after the inserted text.\n\
773Any other markers at the point of insertion also end up after the text.")
774 (nargs, args)
775 int nargs;
776 register Lisp_Object *args;
777{
778 register int argnum;
779 register Lisp_Object tem;
780 char str[1];
35692fe0
JB
781
782 for (argnum = 0; argnum < nargs; argnum++)
783 {
784 tem = args[argnum];
785 retry:
786 if (XTYPE (tem) == Lisp_Int)
787 {
788 str[0] = XINT (tem);
789 insert_before_markers (str, 1);
790 }
791 else if (XTYPE (tem) == Lisp_String)
792 {
be91036a
RS
793 insert_from_string_before_markers (tem, 0, XSTRING (tem)->size, 0);
794 }
795 else
796 {
797 tem = wrong_type_argument (Qchar_or_string_p, tem);
798 goto retry;
799 }
800 }
801
802 return Qnil;
803}
804
805DEFUN ("insert-before-markers-and-inherit",
806 Finsert_and_inherit_before_markers, Sinsert_and_inherit_before_markers,
807 0, MANY, 0,
808 "Insert text at point, relocating markers and inheriting properties.\n\
809Point moves forward so that it ends up after the inserted text.\n\
810Any other markers at the point of insertion also end up after the text.")
811 (nargs, args)
812 int nargs;
813 register Lisp_Object *args;
814{
815 register int argnum;
816 register Lisp_Object tem;
817 char str[1];
818
819 for (argnum = 0; argnum < nargs; argnum++)
820 {
821 tem = args[argnum];
822 retry:
823 if (XTYPE (tem) == Lisp_Int)
824 {
825 str[0] = XINT (tem);
826 insert_before_markers (str, 1);
827 }
828 else if (XTYPE (tem) == Lisp_String)
829 {
830 insert_from_string_before_markers (tem, 0, XSTRING (tem)->size, 1);
35692fe0
JB
831 }
832 else
833 {
834 tem = wrong_type_argument (Qchar_or_string_p, tem);
835 goto retry;
836 }
837 }
838
35692fe0
JB
839 return Qnil;
840}
841\f
842DEFUN ("insert-char", Finsert_char, Sinsert_char, 2, 2, 0,
843 "Insert COUNT (second arg) copies of CHAR (first arg).\n\
844Point and all markers are affected as in the function `insert'.\n\
845Both arguments are required.")
846 (chr, count)
847 Lisp_Object chr, count;
848{
849 register unsigned char *string;
850 register int strlen;
851 register int i, n;
852
853 CHECK_NUMBER (chr, 0);
854 CHECK_NUMBER (count, 1);
855
856 n = XINT (count);
857 if (n <= 0)
858 return Qnil;
859 strlen = min (n, 256);
860 string = (unsigned char *) alloca (strlen);
861 for (i = 0; i < strlen; i++)
862 string[i] = XFASTINT (chr);
863 while (n >= strlen)
864 {
865 insert (string, strlen);
866 n -= strlen;
867 }
868 if (n > 0)
869 insert (string, n);
870 return Qnil;
871}
872
873\f
ffd56f97
JB
874/* Making strings from buffer contents. */
875
876/* Return a Lisp_String containing the text of the current buffer from
74d6d8c5 877 START to END. If text properties are in use and the current buffer
eb8c3be9 878 has properties in the range specified, the resulting string will also
74d6d8c5 879 have them.
ffd56f97
JB
880
881 We don't want to use plain old make_string here, because it calls
882 make_uninit_string, which can cause the buffer arena to be
883 compacted. make_string has no way of knowing that the data has
884 been moved, and thus copies the wrong data into the string. This
885 doesn't effect most of the other users of make_string, so it should
886 be left as is. But we should use this function when conjuring
887 buffer substrings. */
74d6d8c5 888
ffd56f97
JB
889Lisp_Object
890make_buffer_string (start, end)
891 int start, end;
892{
60b96ee7 893 Lisp_Object result, tem;
ffd56f97
JB
894
895 if (start < GPT && GPT < end)
896 move_gap (start);
897
898 result = make_uninit_string (end - start);
899 bcopy (&FETCH_CHAR (start), XSTRING (result)->data, end - start);
900
60b96ee7
RS
901 tem = Fnext_property_change (make_number (start), Qnil, make_number (end));
902
903#ifdef USE_TEXT_PROPERTIES
904 if (XINT (tem) != end)
905 copy_intervals_to_string (result, current_buffer, start, end - start);
906#endif
74d6d8c5 907
ffd56f97
JB
908 return result;
909}
35692fe0
JB
910
911DEFUN ("buffer-substring", Fbuffer_substring, Sbuffer_substring, 2, 2, 0,
912 "Return the contents of part of the current buffer as a string.\n\
913The two arguments START and END are character positions;\n\
914they can be in either order.")
915 (b, e)
916 Lisp_Object b, e;
917{
918 register int beg, end;
35692fe0
JB
919
920 validate_region (&b, &e);
921 beg = XINT (b);
922 end = XINT (e);
923
ffd56f97 924 return make_buffer_string (beg, end);
35692fe0
JB
925}
926
927DEFUN ("buffer-string", Fbuffer_string, Sbuffer_string, 0, 0, 0,
928 "Return the contents of the current buffer as a string.")
929 ()
930{
ffd56f97 931 return make_buffer_string (BEGV, ZV);
35692fe0
JB
932}
933
934DEFUN ("insert-buffer-substring", Finsert_buffer_substring, Sinsert_buffer_substring,
935 1, 3, 0,
83ea6fc2 936 "Insert before point a substring of the contents of buffer BUFFER.\n\
35692fe0
JB
937BUFFER may be a buffer or a buffer name.\n\
938Arguments START and END are character numbers specifying the substring.\n\
939They default to the beginning and the end of BUFFER.")
940 (buf, b, e)
941 Lisp_Object buf, b, e;
942{
74d6d8c5 943 register int beg, end, temp, len, opoint, start;
35692fe0 944 register struct buffer *bp;
3fff2dfa 945 Lisp_Object buffer;
35692fe0 946
3fff2dfa
RS
947 buffer = Fget_buffer (buf);
948 if (NILP (buffer))
949 nsberror (buf);
950 bp = XBUFFER (buffer);
35692fe0 951
56a98455 952 if (NILP (b))
35692fe0
JB
953 beg = BUF_BEGV (bp);
954 else
955 {
956 CHECK_NUMBER_COERCE_MARKER (b, 0);
957 beg = XINT (b);
958 }
56a98455 959 if (NILP (e))
35692fe0
JB
960 end = BUF_ZV (bp);
961 else
962 {
963 CHECK_NUMBER_COERCE_MARKER (e, 1);
964 end = XINT (e);
965 }
966
967 if (beg > end)
74d6d8c5 968 temp = beg, beg = end, end = temp;
35692fe0
JB
969
970 /* Move the gap or create enough gap in the current buffer. */
971
972 if (point != GPT)
973 move_gap (point);
974 if (GAP_SIZE < end - beg)
975 make_gap (end - beg - GAP_SIZE);
976
74d6d8c5
JA
977 len = end - beg;
978 start = beg;
979 opoint = point;
980
35692fe0
JB
981 if (!(BUF_BEGV (bp) <= beg
982 && beg <= end
983 && end <= BUF_ZV (bp)))
984 args_out_of_range (b, e);
985
986 /* Now the actual insertion will not do any gap motion,
987 so it matters not if BUF is the current buffer. */
988 if (beg < BUF_GPT (bp))
989 {
990 insert (BUF_CHAR_ADDRESS (bp, beg), min (end, BUF_GPT (bp)) - beg);
991 beg = min (end, BUF_GPT (bp));
992 }
993 if (beg < end)
994 insert (BUF_CHAR_ADDRESS (bp, beg), end - beg);
995
74d6d8c5
JA
996 /* Only defined if Emacs is compiled with USE_TEXT_PROPERTIES */
997 graft_intervals_into_buffer (copy_intervals (bp->intervals, start, len),
60b96ee7 998 opoint, len, current_buffer, 0);
74d6d8c5 999
35692fe0
JB
1000 return Qnil;
1001}
e9cf2084
RS
1002
1003DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings, Scompare_buffer_substrings,
1004 6, 6, 0,
1005 "Compare two substrings of two buffers; return result as number.\n\
1006the value is -N if first string is less after N-1 chars,\n\
1007+N if first string is greater after N-1 chars, or 0 if strings match.\n\
1008Each substring is represented as three arguments: BUFFER, START and END.\n\
1009That makes six args in all, three for each substring.\n\n\
1010The value of `case-fold-search' in the current buffer\n\
1011determines whether case is significant or ignored.")
1012 (buffer1, start1, end1, buffer2, start2, end2)
1013 Lisp_Object buffer1, start1, end1, buffer2, start2, end2;
1014{
1015 register int begp1, endp1, begp2, endp2, temp, len1, len2, length, i;
1016 register struct buffer *bp1, *bp2;
1017 register unsigned char *trt
1018 = (!NILP (current_buffer->case_fold_search)
1019 ? XSTRING (current_buffer->case_canon_table)->data : 0);
1020
1021 /* Find the first buffer and its substring. */
1022
1023 if (NILP (buffer1))
1024 bp1 = current_buffer;
1025 else
1026 {
3fff2dfa
RS
1027 Lisp_Object buf1;
1028 buf1 = Fget_buffer (buffer1);
1029 if (NILP (buf1))
1030 nsberror (buffer1);
1031 bp1 = XBUFFER (buf1);
e9cf2084
RS
1032 }
1033
1034 if (NILP (start1))
1035 begp1 = BUF_BEGV (bp1);
1036 else
1037 {
1038 CHECK_NUMBER_COERCE_MARKER (start1, 1);
1039 begp1 = XINT (start1);
1040 }
1041 if (NILP (end1))
1042 endp1 = BUF_ZV (bp1);
1043 else
1044 {
1045 CHECK_NUMBER_COERCE_MARKER (end1, 2);
1046 endp1 = XINT (end1);
1047 }
1048
1049 if (begp1 > endp1)
1050 temp = begp1, begp1 = endp1, endp1 = temp;
1051
1052 if (!(BUF_BEGV (bp1) <= begp1
1053 && begp1 <= endp1
1054 && endp1 <= BUF_ZV (bp1)))
1055 args_out_of_range (start1, end1);
1056
1057 /* Likewise for second substring. */
1058
1059 if (NILP (buffer2))
1060 bp2 = current_buffer;
1061 else
1062 {
3fff2dfa
RS
1063 Lisp_Object buf2;
1064 buf2 = Fget_buffer (buffer2);
1065 if (NILP (buf2))
1066 nsberror (buffer2);
e9cf2084
RS
1067 bp2 = XBUFFER (buffer2);
1068 }
1069
1070 if (NILP (start2))
1071 begp2 = BUF_BEGV (bp2);
1072 else
1073 {
1074 CHECK_NUMBER_COERCE_MARKER (start2, 4);
1075 begp2 = XINT (start2);
1076 }
1077 if (NILP (end2))
1078 endp2 = BUF_ZV (bp2);
1079 else
1080 {
1081 CHECK_NUMBER_COERCE_MARKER (end2, 5);
1082 endp2 = XINT (end2);
1083 }
1084
1085 if (begp2 > endp2)
1086 temp = begp2, begp2 = endp2, endp2 = temp;
1087
1088 if (!(BUF_BEGV (bp2) <= begp2
1089 && begp2 <= endp2
1090 && endp2 <= BUF_ZV (bp2)))
1091 args_out_of_range (start2, end2);
1092
1093 len1 = endp1 - begp1;
1094 len2 = endp2 - begp2;
1095 length = len1;
1096 if (len2 < length)
1097 length = len2;
1098
1099 for (i = 0; i < length; i++)
1100 {
1101 int c1 = *BUF_CHAR_ADDRESS (bp1, begp1 + i);
1102 int c2 = *BUF_CHAR_ADDRESS (bp2, begp2 + i);
1103 if (trt)
1104 {
1105 c1 = trt[c1];
1106 c2 = trt[c2];
1107 }
1108 if (c1 < c2)
1109 return make_number (- 1 - i);
1110 if (c1 > c2)
1111 return make_number (i + 1);
1112 }
1113
1114 /* The strings match as far as they go.
1115 If one is shorter, that one is less. */
1116 if (length < len1)
1117 return make_number (length + 1);
1118 else if (length < len2)
1119 return make_number (- length - 1);
1120
1121 /* Same length too => they are equal. */
1122 return make_number (0);
1123}
35692fe0
JB
1124\f
1125DEFUN ("subst-char-in-region", Fsubst_char_in_region,
1126 Ssubst_char_in_region, 4, 5, 0,
1127 "From START to END, replace FROMCHAR with TOCHAR each time it occurs.\n\
1128If optional arg NOUNDO is non-nil, don't record this change for undo\n\
1129and don't mark the buffer as really changed.")
1130 (start, end, fromchar, tochar, noundo)
1131 Lisp_Object start, end, fromchar, tochar, noundo;
1132{
1133 register int pos, stop, look;
60b96ee7 1134 int changed = 0;
35692fe0
JB
1135
1136 validate_region (&start, &end);
1137 CHECK_NUMBER (fromchar, 2);
1138 CHECK_NUMBER (tochar, 3);
1139
1140 pos = XINT (start);
1141 stop = XINT (end);
1142 look = XINT (fromchar);
1143
56a98455 1144 if (! NILP (noundo))
35692fe0
JB
1145 {
1146 if (MODIFF - 1 == current_buffer->save_modified)
1147 current_buffer->save_modified++;
1148 if (MODIFF - 1 == current_buffer->auto_save_modified)
1149 current_buffer->auto_save_modified++;
1150 }
1151
1152 while (pos < stop)
1153 {
1154 if (FETCH_CHAR (pos) == look)
1155 {
60b96ee7
RS
1156 if (! changed)
1157 {
1158 modify_region (current_buffer, XINT (start), stop);
1159 changed = 1;
1160 }
1161
56a98455 1162 if (NILP (noundo))
35692fe0
JB
1163 record_change (pos, 1);
1164 FETCH_CHAR (pos) = XINT (tochar);
35692fe0
JB
1165 }
1166 pos++;
1167 }
1168
60b96ee7
RS
1169 if (changed)
1170 signal_after_change (XINT (start),
1171 stop - XINT (start), stop - XINT (start));
1172
35692fe0
JB
1173 return Qnil;
1174}
1175
1176DEFUN ("translate-region", Ftranslate_region, Stranslate_region, 3, 3, 0,
1177 "From START to END, translate characters according to TABLE.\n\
1178TABLE is a string; the Nth character in it is the mapping\n\
1179for the character with code N. Returns the number of characters changed.")
1180 (start, end, table)
1181 Lisp_Object start;
1182 Lisp_Object end;
1183 register Lisp_Object table;
1184{
1185 register int pos, stop; /* Limits of the region. */
1186 register unsigned char *tt; /* Trans table. */
1187 register int oc; /* Old character. */
1188 register int nc; /* New character. */
1189 int cnt; /* Number of changes made. */
1190 Lisp_Object z; /* Return. */
1191 int size; /* Size of translate table. */
1192
1193 validate_region (&start, &end);
1194 CHECK_STRING (table, 2);
1195
1196 size = XSTRING (table)->size;
1197 tt = XSTRING (table)->data;
1198
1199 pos = XINT (start);
1200 stop = XINT (end);
04a759c8 1201 modify_region (current_buffer, pos, stop);
35692fe0
JB
1202
1203 cnt = 0;
1204 for (; pos < stop; ++pos)
1205 {
1206 oc = FETCH_CHAR (pos);
1207 if (oc < size)
1208 {
1209 nc = tt[oc];
1210 if (nc != oc)
1211 {
1212 record_change (pos, 1);
1213 FETCH_CHAR (pos) = nc;
1214 signal_after_change (pos, 1, 1);
1215 ++cnt;
1216 }
1217 }
1218 }
1219
1220 XFASTINT (z) = cnt;
1221 return (z);
1222}
1223
1224DEFUN ("delete-region", Fdelete_region, Sdelete_region, 2, 2, "r",
1225 "Delete the text between point and mark.\n\
1226When called from a program, expects two arguments,\n\
1227positions (integers or markers) specifying the stretch to be deleted.")
1228 (b, e)
1229 Lisp_Object b, e;
1230{
1231 validate_region (&b, &e);
1232 del_range (XINT (b), XINT (e));
1233 return Qnil;
1234}
1235\f
1236DEFUN ("widen", Fwiden, Swiden, 0, 0, "",
1237 "Remove restrictions (narrowing) from current buffer.\n\
1238This allows the buffer's full text to be seen and edited.")
1239 ()
1240{
1241 BEGV = BEG;
1242 SET_BUF_ZV (current_buffer, Z);
1243 clip_changed = 1;
52b14ac0
JB
1244 /* Changing the buffer bounds invalidates any recorded current column. */
1245 invalidate_current_column ();
35692fe0
JB
1246 return Qnil;
1247}
1248
1249DEFUN ("narrow-to-region", Fnarrow_to_region, Snarrow_to_region, 2, 2, "r",
1250 "Restrict editing in this buffer to the current region.\n\
1251The rest of the text becomes temporarily invisible and untouchable\n\
1252but is not deleted; if you save the buffer in a file, the invisible\n\
1253text is included in the file. \\[widen] makes all visible again.\n\
1254See also `save-restriction'.\n\
1255\n\
1256When calling from a program, pass two arguments; positions (integers\n\
1257or markers) bounding the text that should remain visible.")
1258 (b, e)
1259 register Lisp_Object b, e;
1260{
1261 register int i;
1262
1263 CHECK_NUMBER_COERCE_MARKER (b, 0);
1264 CHECK_NUMBER_COERCE_MARKER (e, 1);
1265
1266 if (XINT (b) > XINT (e))
1267 {
1268 i = XFASTINT (b);
1269 b = e;
1270 XFASTINT (e) = i;
1271 }
1272
1273 if (!(BEG <= XINT (b) && XINT (b) <= XINT (e) && XINT (e) <= Z))
1274 args_out_of_range (b, e);
1275
1276 BEGV = XFASTINT (b);
1277 SET_BUF_ZV (current_buffer, XFASTINT (e));
1278 if (point < XFASTINT (b))
1279 SET_PT (XFASTINT (b));
1280 if (point > XFASTINT (e))
1281 SET_PT (XFASTINT (e));
1282 clip_changed = 1;
52b14ac0
JB
1283 /* Changing the buffer bounds invalidates any recorded current column. */
1284 invalidate_current_column ();
35692fe0
JB
1285 return Qnil;
1286}
1287
1288Lisp_Object
1289save_restriction_save ()
1290{
1291 register Lisp_Object bottom, top;
1292 /* Note: I tried using markers here, but it does not win
1293 because insertion at the end of the saved region
1294 does not advance mh and is considered "outside" the saved region. */
1295 XFASTINT (bottom) = BEGV - BEG;
1296 XFASTINT (top) = Z - ZV;
1297
1298 return Fcons (Fcurrent_buffer (), Fcons (bottom, top));
1299}
1300
1301Lisp_Object
1302save_restriction_restore (data)
1303 Lisp_Object data;
1304{
1305 register struct buffer *buf;
1306 register int newhead, newtail;
1307 register Lisp_Object tem;
1308
1309 buf = XBUFFER (XCONS (data)->car);
1310
1311 data = XCONS (data)->cdr;
1312
1313 tem = XCONS (data)->car;
1314 newhead = XINT (tem);
1315 tem = XCONS (data)->cdr;
1316 newtail = XINT (tem);
1317 if (newhead + newtail > BUF_Z (buf) - BUF_BEG (buf))
1318 {
1319 newhead = 0;
1320 newtail = 0;
1321 }
1322 BUF_BEGV (buf) = BUF_BEG (buf) + newhead;
1323 SET_BUF_ZV (buf, BUF_Z (buf) - newtail);
1324 clip_changed = 1;
1325
1326 /* If point is outside the new visible range, move it inside. */
1327 SET_BUF_PT (buf,
1328 clip_to_bounds (BUF_BEGV (buf), BUF_PT (buf), BUF_ZV (buf)));
1329
1330 return Qnil;
1331}
1332
1333DEFUN ("save-restriction", Fsave_restriction, Ssave_restriction, 0, UNEVALLED, 0,
1334 "Execute BODY, saving and restoring current buffer's restrictions.\n\
1335The buffer's restrictions make parts of the beginning and end invisible.\n\
1336\(They are set up with `narrow-to-region' and eliminated with `widen'.)\n\
1337This special form, `save-restriction', saves the current buffer's restrictions\n\
1338when it is entered, and restores them when it is exited.\n\
1339So any `narrow-to-region' within BODY lasts only until the end of the form.\n\
1340The old restrictions settings are restored\n\
1341even in case of abnormal exit (throw or error).\n\
1342\n\
1343The value returned is the value of the last form in BODY.\n\
1344\n\
1345`save-restriction' can get confused if, within the BODY, you widen\n\
1346and then make changes outside the area within the saved restrictions.\n\
1347\n\
1348Note: if you are using both `save-excursion' and `save-restriction',\n\
1349use `save-excursion' outermost:\n\
1350 (save-excursion (save-restriction ...))")
1351 (body)
1352 Lisp_Object body;
1353{
1354 register Lisp_Object val;
1355 int count = specpdl_ptr - specpdl;
1356
1357 record_unwind_protect (save_restriction_restore, save_restriction_save ());
1358 val = Fprogn (body);
1359 return unbind_to (count, val);
1360}
1361\f
1362DEFUN ("message", Fmessage, Smessage, 1, MANY, 0,
1363 "Print a one-line message at the bottom of the screen.\n\
1364The first argument is a control string.\n\
1365It may contain %s or %d or %c to print successive following arguments.\n\
1366%s means print an argument as a string, %d means print as number in decimal,\n\
1367%c means print a number as a single character.\n\
1368The argument used by %s must be a string or a symbol;\n\
ccdac5be
JB
1369the argument used by %d or %c must be a number.\n\
1370If the first argument is nil, clear any existing message; let the\n\
1371minibuffer contents show.")
35692fe0
JB
1372 (nargs, args)
1373 int nargs;
1374 Lisp_Object *args;
1375{
ccdac5be 1376 if (NILP (args[0]))
f0250249
JB
1377 {
1378 message (0);
1379 return Qnil;
1380 }
ccdac5be
JB
1381 else
1382 {
1383 register Lisp_Object val;
1384 val = Fformat (nargs, args);
1385 message ("%s", XSTRING (val)->data);
1386 return val;
1387 }
35692fe0
JB
1388}
1389
1390DEFUN ("format", Fformat, Sformat, 1, MANY, 0,
1391 "Format a string out of a control-string and arguments.\n\
1392The first argument is a control string.\n\
1393The other arguments are substituted into it to make the result, a string.\n\
1394It may contain %-sequences meaning to substitute the next argument.\n\
1395%s means print a string argument. Actually, prints any object, with `princ'.\n\
1396%d means print as number in decimal (%o octal, %x hex).\n\
1397%c means print a number as a single character.\n\
1398%S means print any object as an s-expression (using prin1).\n\
52b14ac0
JB
1399 The argument used for %d, %o, %x or %c must be a number.\n\
1400Use %% to put a single % into the output.")
35692fe0
JB
1401 (nargs, args)
1402 int nargs;
1403 register Lisp_Object *args;
1404{
1405 register int n; /* The number of the next arg to substitute */
1406 register int total = 5; /* An estimate of the final length */
1407 char *buf;
1408 register unsigned char *format, *end;
1409 int length;
1410 extern char *index ();
1411 /* It should not be necessary to GCPRO ARGS, because
1412 the caller in the interpreter should take care of that. */
1413
1414 CHECK_STRING (args[0], 0);
1415 format = XSTRING (args[0])->data;
1416 end = format + XSTRING (args[0])->size;
1417
1418 n = 0;
1419 while (format != end)
1420 if (*format++ == '%')
1421 {
1422 int minlen;
1423
1424 /* Process a numeric arg and skip it. */
1425 minlen = atoi (format);
1426 if (minlen > 0)
1427 total += minlen;
1428 else
1429 total -= minlen;
1430 while ((*format >= '0' && *format <= '9')
1431 || *format == '-' || *format == ' ' || *format == '.')
1432 format++;
1433
1434 if (*format == '%')
1435 format++;
1436 else if (++n >= nargs)
1437 ;
1438 else if (*format == 'S')
1439 {
1440 /* For `S', prin1 the argument and then treat like a string. */
1441 register Lisp_Object tem;
1442 tem = Fprin1_to_string (args[n], Qnil);
1443 args[n] = tem;
1444 goto string;
1445 }
1446 else if (XTYPE (args[n]) == Lisp_Symbol)
1447 {
1448 XSET (args[n], Lisp_String, XSYMBOL (args[n])->name);
1449 goto string;
1450 }
1451 else if (XTYPE (args[n]) == Lisp_String)
1452 {
1453 string:
1454 total += XSTRING (args[n])->size;
1455 }
1456 /* Would get MPV otherwise, since Lisp_Int's `point' to low memory. */
1457 else if (XTYPE (args[n]) == Lisp_Int && *format != 's')
1458 {
4746118a 1459#ifdef LISP_FLOAT_TYPE
eb8c3be9 1460 /* The following loop assumes the Lisp type indicates
35692fe0
JB
1461 the proper way to pass the argument.
1462 So make sure we have a flonum if the argument should
1463 be a double. */
1464 if (*format == 'e' || *format == 'f' || *format == 'g')
1465 args[n] = Ffloat (args[n]);
4746118a 1466#endif
35692fe0
JB
1467 total += 10;
1468 }
4746118a 1469#ifdef LISP_FLOAT_TYPE
35692fe0
JB
1470 else if (XTYPE (args[n]) == Lisp_Float && *format != 's')
1471 {
1472 if (! (*format == 'e' || *format == 'f' || *format == 'g'))
1473 args[n] = Ftruncate (args[n]);
1474 total += 20;
1475 }
4746118a 1476#endif
35692fe0
JB
1477 else
1478 {
1479 /* Anything but a string, convert to a string using princ. */
1480 register Lisp_Object tem;
1481 tem = Fprin1_to_string (args[n], Qt);
1482 args[n] = tem;
1483 goto string;
1484 }
1485 }
1486
1487 {
1488 register int nstrings = n + 1;
50aa2f90
JB
1489
1490 /* Allocate twice as many strings as we have %-escapes; floats occupy
1491 two slots, and we're not sure how many of those we have. */
35692fe0 1492 register unsigned char **strings
50aa2f90
JB
1493 = (unsigned char **) alloca (2 * nstrings * sizeof (unsigned char *));
1494 int i;
35692fe0 1495
50aa2f90 1496 i = 0;
35692fe0
JB
1497 for (n = 0; n < nstrings; n++)
1498 {
1499 if (n >= nargs)
50aa2f90 1500 strings[i++] = (unsigned char *) "";
35692fe0
JB
1501 else if (XTYPE (args[n]) == Lisp_Int)
1502 /* We checked above that the corresponding format effector
1503 isn't %s, which would cause MPV. */
50aa2f90 1504 strings[i++] = (unsigned char *) XINT (args[n]);
4746118a 1505#ifdef LISP_FLOAT_TYPE
35692fe0
JB
1506 else if (XTYPE (args[n]) == Lisp_Float)
1507 {
1508 union { double d; int half[2]; } u;
1509
1510 u.d = XFLOAT (args[n])->data;
50aa2f90
JB
1511 strings[i++] = (unsigned char *) u.half[0];
1512 strings[i++] = (unsigned char *) u.half[1];
35692fe0 1513 }
4746118a 1514#endif
35692fe0 1515 else
50aa2f90 1516 strings[i++] = XSTRING (args[n])->data;
35692fe0
JB
1517 }
1518
1519 /* Format it in bigger and bigger buf's until it all fits. */
1520 while (1)
1521 {
1522 buf = (char *) alloca (total + 1);
1523 buf[total - 1] = 0;
1524
50aa2f90 1525 length = doprnt (buf, total + 1, strings[0], end, i-1, strings + 1);
35692fe0
JB
1526 if (buf[total - 1] == 0)
1527 break;
1528
1529 total *= 2;
1530 }
1531 }
1532
1533 /* UNGCPRO; */
1534 return make_string (buf, length);
1535}
1536
1537/* VARARGS 1 */
1538Lisp_Object
1539#ifdef NO_ARG_ARRAY
1540format1 (string1, arg0, arg1, arg2, arg3, arg4)
1541 int arg0, arg1, arg2, arg3, arg4;
1542#else
1543format1 (string1)
1544#endif
1545 char *string1;
1546{
1547 char buf[100];
1548#ifdef NO_ARG_ARRAY
1549 int args[5];
1550 args[0] = arg0;
1551 args[1] = arg1;
1552 args[2] = arg2;
1553 args[3] = arg3;
1554 args[4] = arg4;
1555 doprnt (buf, sizeof buf, string1, 0, 5, args);
1556#else
1557 doprnt (buf, sizeof buf, string1, 0, 5, &string1 + 1);
1558#endif
1559 return build_string (buf);
1560}
1561\f
1562DEFUN ("char-equal", Fchar_equal, Schar_equal, 2, 2, 0,
1563 "Return t if two characters match, optionally ignoring case.\n\
1564Both arguments must be characters (i.e. integers).\n\
1565Case is ignored if `case-fold-search' is non-nil in the current buffer.")
1566 (c1, c2)
1567 register Lisp_Object c1, c2;
1568{
1569 unsigned char *downcase = DOWNCASE_TABLE;
1570 CHECK_NUMBER (c1, 0);
1571 CHECK_NUMBER (c2, 1);
1572
56a98455 1573 if (!NILP (current_buffer->case_fold_search)
c34beca9
RS
1574 ? (downcase[0xff & XFASTINT (c1)] == downcase[0xff & XFASTINT (c2)]
1575 && (XFASTINT (c1) & ~0xff) == (XFASTINT (c2) & ~0xff))
35692fe0
JB
1576 : XINT (c1) == XINT (c2))
1577 return Qt;
1578 return Qnil;
1579}
1580
35692fe0
JB
1581\f
1582void
1583syms_of_editfns ()
1584{
f5ff08b0
RS
1585 staticpro (&Vuser_name);
1586 staticpro (&Vuser_full_name);
1587 staticpro (&Vuser_real_name);
1588 staticpro (&Vsystem_name);
35692fe0
JB
1589
1590 defsubr (&Schar_equal);
1591 defsubr (&Sgoto_char);
1592 defsubr (&Sstring_to_char);
1593 defsubr (&Schar_to_string);
1594 defsubr (&Sbuffer_substring);
1595 defsubr (&Sbuffer_string);
1596
1597 defsubr (&Spoint_marker);
1598 defsubr (&Smark_marker);
1599 defsubr (&Spoint);
1600 defsubr (&Sregion_beginning);
1601 defsubr (&Sregion_end);
1602/* defsubr (&Smark); */
1603/* defsubr (&Sset_mark); */
1604 defsubr (&Ssave_excursion);
1605
1606 defsubr (&Sbufsize);
1607 defsubr (&Spoint_max);
1608 defsubr (&Spoint_min);
1609 defsubr (&Spoint_min_marker);
1610 defsubr (&Spoint_max_marker);
1611
1612 defsubr (&Sbobp);
1613 defsubr (&Seobp);
1614 defsubr (&Sbolp);
1615 defsubr (&Seolp);
850a8179
JB
1616 defsubr (&Sfollowing_char);
1617 defsubr (&Sprevious_char);
35692fe0
JB
1618 defsubr (&Schar_after);
1619 defsubr (&Sinsert);
1620 defsubr (&Sinsert_before_markers);
be91036a
RS
1621 defsubr (&Sinsert_and_inherit);
1622 defsubr (&Sinsert_and_inherit_before_markers);
35692fe0
JB
1623 defsubr (&Sinsert_char);
1624
1625 defsubr (&Suser_login_name);
1626 defsubr (&Suser_real_login_name);
1627 defsubr (&Suser_uid);
1628 defsubr (&Suser_real_uid);
1629 defsubr (&Suser_full_name);
d940e0e4 1630 defsubr (&Scurrent_time);
35692fe0 1631 defsubr (&Scurrent_time_string);
c2662aea 1632 defsubr (&Scurrent_time_zone);
35692fe0 1633 defsubr (&Ssystem_name);
35692fe0
JB
1634 defsubr (&Smessage);
1635 defsubr (&Sformat);
35692fe0
JB
1636
1637 defsubr (&Sinsert_buffer_substring);
e9cf2084 1638 defsubr (&Scompare_buffer_substrings);
35692fe0
JB
1639 defsubr (&Ssubst_char_in_region);
1640 defsubr (&Stranslate_region);
1641 defsubr (&Sdelete_region);
1642 defsubr (&Swiden);
1643 defsubr (&Snarrow_to_region);
1644 defsubr (&Ssave_restriction);
1645}