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