![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to editfns.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Apple XNU] / GNUtools / emacs / src|
Return to editfns.c CVS log | Up to [Apple XNU] / GNUtools / emacs / src |
1.1 root 1: /* Lisp functions pertaining to editing.
2: Copyright (C) 1985, 1986, 1987, 1990 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 "config.h"
22: #ifdef hpux
23: /* needed by <pwd.h> */
24: #include <stdio.h>
25: #undef NULL
26: #endif
27:
28: #ifdef VMS
29: #include "vms-pwd.h"
30: #else
31: #include <pwd.h>
32: #endif
33:
34: #include "lisp.h"
35: #include "buffer.h"
36: #include "window.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: static Lisp_Object Vsystem_name;
44: static Lisp_Object Vuser_real_name; /* login name of current user ID */
45: static Lisp_Object Vuser_full_name; /* full name of current user */
46: static Lisp_Object Vuser_name; /* user name from USER or LOGNAME. */
47:
48: void
49: init_editfns ()
50: {
51: char *user_name;
52: register unsigned char *p, *q;
53: struct passwd *pw; /* password entry for the current user */
54: Lisp_Object tem;
55: extern char *index ();
56:
57: /* Turn off polling so the SIGALRM won't bother getpwuid. */
58: stop_polling ();
59:
60: /* Set up system_name even when dumping. */
61:
62: Vsystem_name = build_string (get_system_name ());
63: p = XSTRING (Vsystem_name)->data;
64: while (*p)
65: {
66: if (*p == ' ' || *p == '\t')
67: *p = '-';
68: p++;
69: }
70:
71: #ifndef CANNOT_DUMP
72: /* Don't bother with this on initial start when just dumping out */
73: if (!initialized)
74: return;
75: #endif /* not CANNOT_DUMP */
76:
77: pw = (struct passwd *) getpwuid (getuid ());
78: Vuser_real_name = build_string (pw ? pw->pw_name : "unknown");
79:
80: /* Get the effective user name, by consulting environment variables,
81: or the effective uid if those are unset. */
82: user_name = (char *) getenv ("USER");
83: if (!user_name)
84: user_name = (char *) getenv ("LOGNAME"); /* USG equivalent */
85: if (!user_name)
86: {
87: pw = (struct passwd *) getpwuid (geteuid ());
88: user_name = pw ? pw->pw_name : "unknown";
89: }
90: Vuser_name = build_string (user_name);
91:
92: /* If the user name claimed in the environment vars differs from
93: the real uid, use the claimed name to find the full name. */
94: tem = Fstring_equal (Vuser_name, Vuser_real_name);
95: if (NULL (tem))
96: pw = (struct passwd *) getpwnam (XSTRING (Vuser_name)->data);
97:
98: p = (unsigned char *) (pw ? USER_FULL_NAME : "unknown");
99: q = (unsigned char *) index (p, ',');
100: Vuser_full_name = make_string (p, q ? q - p : strlen (p));
101:
102: #ifdef AMPERSAND_FULL_NAME
103: p = XSTRING (Vuser_full_name)->data;
104: q = (unsigned char *) index (p, '&');
105: /* Substitute the login name for the &, upcasing the first character. */
106: if (q)
107: {
108: char *r
109: = (char *) alloca (strlen (p) + XSTRING (Vuser_name)->size + 1);
110: bcopy (p, r, q - p);
111: r[q - p] = 0;
112: strcat (r, XSTRING (Vuser_real_name)->data);
113: r[q - p] = UPCASE (r[q - p]);
114: strcat (r, q + 1);
115: Vuser_full_name = build_string (r);
116: }
117: #endif /* AMPERSAND_FULL_NAME */
118:
119: start_polling ();
120: }
121:
122: DEFUN ("char-to-string", Fchar_to_string, Schar_to_string, 1, 1, 0,
123: "Convert arg CHAR to a string containing that character.")
124: (n)
125: Lisp_Object n;
126: {
127: char c;
128: CHECK_NUMBER (n, 0);
129:
130: c = XINT (n);
131: return make_string (&c, 1);
132: }
133:
134: DEFUN ("string-to-char", Fstring_to_char, Sstring_to_char, 1, 1, 0,
135: "Convert arg STRING to a character, the first character of that string.")
136: (str)
137: register Lisp_Object str;
138: {
139: register Lisp_Object val;
140: register struct Lisp_String *p;
141: CHECK_STRING (str, 0);
142:
143: p = XSTRING (str);
144: if (p->size)
145: XFASTINT (val) = ((unsigned char *) p->data)[0];
146: else
147: XFASTINT (val) = 0;
148: return val;
149: }
150:
151: static Lisp_Object
152: buildmark (val)
153: int val;
154: {
155: register Lisp_Object mark;
156: mark = Fmake_marker ();
157: Fset_marker (mark, make_number (val), Qnil);
158: return mark;
159: }
160:
161: DEFUN ("point", Fpoint, Spoint, 0, 0, 0,
162: "Return value of point, as an integer.\n\
163: Beginning of buffer is position (point-min)")
164: ()
165: {
166: Lisp_Object temp;
167: XFASTINT (temp) = point;
168: return temp;
169: }
170:
171: DEFUN ("point-marker", Fpoint_marker, Spoint_marker, 0, 0, 0,
172: "Return value of point, as a marker object.")
173: ()
174: {
175: return buildmark (point);
176: }
177:
178: int
179: clip_to_bounds (lower, num, upper)
180: int lower, num, upper;
181: {
182: if (num < lower)
183: return lower;
184: else if (num > upper)
185: return upper;
186: else
187: return num;
188: }
189:
190: DEFUN ("goto-char", Fgoto_char, Sgoto_char, 1, 1, "NGoto char: ",
191: "One arg, a number. Set point to that number.\n\
192: Beginning of buffer is position (point-min), end is (point-max).")
193: (n)
194: register Lisp_Object n;
195: {
196: register int charno;
197: CHECK_NUMBER_COERCE_MARKER (n, 0);
198: charno = XINT (n);
199: SET_PT (clip_to_bounds (BEGV, charno, ZV));
200: return n;
201: }
202:
203: static Lisp_Object
204: region_limit (beginningp)
205: int beginningp;
206: {
207: register Lisp_Object m;
208: m = Fmarker_position (current_buffer->mark);
209: if (NULL (m)) error ("There is no region now");
210: if ((point < XFASTINT (m)) == beginningp)
211: return (make_number (point));
212: else
213: return (m);
214: }
215:
216: DEFUN ("region-beginning", Fregion_beginning, Sregion_beginning, 0, 0, 0,
217: "Return position of beginning of region, as an integer.")
218: ()
219: {
220: return (region_limit (1));
221: }
222:
223: DEFUN ("region-end", Fregion_end, Sregion_end, 0, 0, 0,
224: "Return position of end of region, as an integer.")
225: ()
226: {
227: return (region_limit (0));
228: }
229:
230: #if 0 /* now in lisp code */
231: DEFUN ("mark", Fmark, Smark, 0, 0, 0,
232: "Return this buffer's mark value as integer, or nil if no mark.\n\
233: If you are using this in an editing command, you are most likely making\n\
234: a mistake; see the documentation of `set-mark'.")
235: ()
236: {
237: return Fmarker_position (current_buffer->mark);
238: }
239: #endif /* commented out code */
240:
241: DEFUN ("mark-marker", Fmark_marker, Smark_marker, 0, 0, 0,
242: "Return this buffer's mark, as a marker object.\n\
243: Watch out! Moving this marker changes the mark position.\n\
244: The marker will not point anywhere if mark is not set.")
245: ()
246: {
247: return current_buffer->mark;
248: }
249:
250: #if 0 /* this is now in lisp code */
251: DEFUN ("set-mark", Fset_mark, Sset_mark, 1, 1, 0,
252: "Set this buffer's mark to POS. Don't use this function!\n\
253: That is to say, don't use this function unless you want\n\
254: the user to see that the mark has moved, and you want the previous\n\
255: mark position to be lost.\n\
256: \n\
257: Normally, when a new mark is set, the old one should go on the stack.\n\
258: This is why most applications should use push-mark, not set-mark.\n\
259: \n\
260: Novice programmers often try to use the mark for the wrong purposes.\n\
261: The mark saves a location for the user's convenience.\n\
262: Most editing commands should not alter the mark.\n\
263: To remember a location for internal use in the Lisp program,\n\
264: store it in a Lisp variable. Example:\n\
265: \n\
266: (let ((beg (point))) (forward-line 1) (delete-region beg (point))).")
267: (pos)
268: Lisp_Object pos;
269: {
270: if (NULL (pos))
271: {
272: current_buffer->mark = Qnil;
273: return Qnil;
274: }
275: CHECK_NUMBER_COERCE_MARKER (pos, 0);
276:
277: if (NULL (current_buffer->mark))
278: current_buffer->mark = Fmake_marker ();
279:
280: Fset_marker (current_buffer->mark, pos, Qnil);
281: return pos;
282: }
283: #endif /* commented-out code */
284:
285: Lisp_Object
286: save_excursion_save ()
287: {
288: register int visible = XBUFFER (XWINDOW (selected_window)->buffer) == current_buffer;
289:
290: return Fcons (Fpoint_marker (),
291: Fcons (Fcopy_marker (current_buffer->mark), visible ? Qt : Qnil));
292: }
293:
294: Lisp_Object
295: save_excursion_restore (info)
296: register Lisp_Object info;
297: {
298: register Lisp_Object tem;
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 (NULL (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: if (XMARKER (tem)->buffer)
314: unchain_marker (tem);
315: tem = Fcdr (Fcdr (info));
316: if (!NULL (tem) && current_buffer != XBUFFER (XWINDOW (selected_window)->buffer))
317: Fswitch_to_buffer (Fcurrent_buffer (), Qnil);
318: return Qnil;
319: }
320:
321: DEFUN ("save-excursion", Fsave_excursion, Ssave_excursion, 0, UNEVALLED, 0,
322: "Save point (and mark), execute BODY, then restore point and mark.\n\
323: Executes BODY just like PROGN. Point and mark values are restored\n\
324: even in case of abnormal exit (throw or error).")
325: (args)
326: Lisp_Object args;
327: {
328: register Lisp_Object val;
329: int count = specpdl_ptr - specpdl;
330:
331: record_unwind_protect (save_excursion_restore, save_excursion_save ());
332:
333: val = Fprogn (args);
334: unbind_to (count);
335: return val;
336: }
337:
338: DEFUN ("buffer-size", Fbufsize, Sbufsize, 0, 0, 0,
339: "Return the number of characters in the current buffer.")
340: ()
341: {
342: Lisp_Object temp;
343: XFASTINT (temp) = Z - BEG;
344: return temp;
345: }
346:
347: DEFUN ("point-min", Fpoint_min, Spoint_min, 0, 0, 0,
348: "Return the minimum permissible value of point in the current buffer.\n\
349: This is 1, unless a clipping restriction is in effect.")
350: ()
351: {
352: Lisp_Object temp;
353: XFASTINT (temp) = BEGV;
354: return temp;
355: }
356:
357: DEFUN ("point-min-marker", Fpoint_min_marker, Spoint_min_marker, 0, 0, 0,
358: "Return a marker to the beginning of the currently visible part of the buffer.\n\
359: This is the beginning, unless a clipping restriction is in effect.")
360: ()
361: {
362: return buildmark (BEGV);
363: }
364:
365: DEFUN ("point-max", Fpoint_max, Spoint_max, 0, 0, 0,
366: "Return the maximum permissible value of point in the current buffer.\n\
367: This is (1+ (buffer-size)), unless a clipping restriction is in effect,\n\
368: in which case it is less.")
369: ()
370: {
371: Lisp_Object temp;
372: XFASTINT (temp) = ZV;
373: return temp;
374: }
375:
376: DEFUN ("point-max-marker", Fpoint_max_marker, Spoint_max_marker, 0, 0, 0,
377: "Return a marker to the end of the currently visible part of the buffer.\n\
378: This is the actual end, unless a clipping restriction is in effect.")
379: ()
380: {
381: return buildmark (ZV);
382: }
383:
384: DEFUN ("following-char", Ffollchar, Sfollchar, 0, 0, 0,
385: "Return the character following point, as a number.")
386: ()
387: {
388: Lisp_Object temp;
389: if (point >= ZV)
390: XFASTINT (temp) = 0;
391: else
392: XFASTINT (temp) = FETCH_CHAR (point);
393: return temp;
394: }
395:
396: DEFUN ("preceding-char", Fprevchar, Sprevchar, 0, 0, 0,
397: "Return the character preceding point, as a number.")
398: ()
399: {
400: Lisp_Object temp;
401: if (point <= BEGV)
402: XFASTINT (temp) = 0;
403: else
404: XFASTINT (temp) = FETCH_CHAR (point - 1);
405: return temp;
406: }
407:
408: DEFUN ("bobp", Fbobp, Sbobp, 0, 0, 0,
409: "Return T if point is at the beginning of the buffer.\n\
410: If the buffer is narrowed, this means the beginning of the narrowed part.")
411: ()
412: {
413: if (point == BEGV)
414: return Qt;
415: return Qnil;
416: }
417:
418: DEFUN ("eobp", Feobp, Seobp, 0, 0, 0,
419: "Return T if point is at the end of the buffer.\n\
420: If the buffer is narrowed, this means the end of the narrowed part.")
421: ()
422: {
423: if (point == ZV)
424: return Qt;
425: return Qnil;
426: }
427:
428: DEFUN ("bolp", Fbolp, Sbolp, 0, 0, 0,
429: "Return T if point is at the beginning of a line.")
430: ()
431: {
432: if (point == BEGV || FETCH_CHAR (point - 1) == '\n')
433: return Qt;
434: return Qnil;
435: }
436:
437: DEFUN ("eolp", Feolp, Seolp, 0, 0, 0,
438: "Return T if point is at the end of a line.\n\
439: `End of a line' includes point being at the end of the buffer.")
440: ()
441: {
442: if (point == ZV || FETCH_CHAR (point) == '\n')
443: return Qt;
444: return Qnil;
445: }
446:
447: DEFUN ("char-after", Fchar_after, Schar_after, 1, 1, 0,
448: "One arg, POS, a number. Return the character in the current buffer\n\
449: at position POS.\n\
450: If POS is out of range, the value is NIL.")
451: (pos)
452: Lisp_Object pos;
453: {
454: register Lisp_Object val;
455: register int n;
456:
457: CHECK_NUMBER_COERCE_MARKER (pos, 0);
458:
459: n = XINT (pos);
460: if (n < BEGV || n >= ZV) return Qnil;
461:
462: XFASTINT (val) = FETCH_CHAR (n);
463: return val;
464: }
465:
466: DEFUN ("user-login-name", Fuser_login_name, Suser_login_name, 0, 0, 0,
467: "Return the name under which user logged in, as a string.\n\
468: This is based on the effective uid, not the real uid.")
469: ()
470: {
471: return Vuser_name;
472: }
473:
474: DEFUN ("user-real-login-name", Fuser_real_login_name, Suser_real_login_name,
475: 0, 0, 0,
476: "Return the name of the user's real uid, as a string.\n\
477: Differs from user-login-name when running under su.")
478: ()
479: {
480: return Vuser_real_name;
481: }
482:
483: DEFUN ("user-uid", Fuser_uid, Suser_uid, 0, 0, 0,
484: "Return the effective uid of Emacs, as an integer.")
485: ()
486: {
487: return make_number (geteuid ());
488: }
489:
490: DEFUN ("user-real-uid", Fuser_real_uid, Suser_real_uid, 0, 0, 0,
491: "Return the real uid of Emacs, as an integer.")
492: ()
493: {
494: return make_number (getuid ());
495: }
496:
497: DEFUN ("user-full-name", Fuser_full_name, Suser_full_name, 0, 0, 0,
498: "Return the full name of the user logged in, as a string.")
499: ()
500: {
501: return Vuser_full_name;
502: }
503:
504: DEFUN ("system-name", Fsystem_name, Ssystem_name, 0, 0, 0,
505: "Return the name of the machine you are running on, as a string.")
506: ()
507: {
508: return Vsystem_name;
509: }
510:
511: DEFUN ("current-time-string", Fcurrent_time_string, Scurrent_time_string, 0, 0, 0,
512: "Return the current time, as a human-readable string.")
513: ()
514: {
515: long current_time = time (0);
516: register char *tem = (char *) ctime (¤t_time);
517: tem [24] = 0;
518: return build_string (tem);
519: }
520:
521: insert1 (arg)
522: Lisp_Object arg;
523: {
524: Finsert (1, &arg);
525: }
526:
527: DEFUN ("insert", Finsert, Sinsert, 0, MANY, 0,
528: "Any number of args, strings or chars. Insert them after point, moving point forward.")
529: (nargs, args)
530: int nargs;
531: register Lisp_Object *args;
532: {
533: register int argnum;
534: register Lisp_Object tem;
535: char str[1];
536:
537: for (argnum = 0; argnum < nargs; argnum++)
538: {
539: tem = args[argnum];
540: retry:
541: if (XTYPE (tem) == Lisp_Int)
542: {
543: str[0] = XINT (tem);
544: insert (str, 1);
545: }
546: else if (XTYPE (tem) == Lisp_String)
547: {
548: insert_from_string (tem, 0, XSTRING (tem)->size);
549: }
550: else
551: {
552: tem = wrong_type_argument (Qchar_or_string_p, tem);
553: goto retry;
554: }
555: }
556: return Qnil;
557: }
558:
559: DEFUN ("insert-before-markers", Finsert_before_markers, Sinsert_before_markers, 0, MANY, 0,
560: "Any number of args, strings or chars. Insert them after point,\n\
561: moving point forward. Also, any markers pointing at the insertion point\n\
562: get relocated to point after the newly inserted text.")
563: (nargs, args)
564: int nargs;
565: register Lisp_Object *args;
566: {
567: register int argnum;
568: register Lisp_Object tem;
569: char str[1];
570:
571: for (argnum = 0; argnum < nargs; argnum++)
572: {
573: tem = args[argnum];
574: retry:
575: if (XTYPE (tem) == Lisp_Int)
576: {
577: str[0] = XINT (tem);
578: insert_before_markers (str, 1);
579: }
580: else if (XTYPE (tem) == Lisp_String)
581: {
582: insert_from_string_before_markers (tem, 0, XSTRING (tem)->size);
583: }
584: else
585: {
586: tem = wrong_type_argument (Qchar_or_string_p, tem);
587: goto retry;
588: }
589: }
590: return Qnil;
591: }
592:
593: DEFUN ("insert-char", Finsert_char, Sinsert_char, 2, 2, 0,
594: "Insert COUNT (second arg) copies of CHAR (first arg).\n\
595: Both arguments are required.")
596: (chr, count)
597: Lisp_Object chr, count;
598: {
599: register unsigned char *string;
600: register int strlen;
601: register int i, n;
602:
603: CHECK_NUMBER (chr, 0);
604: CHECK_NUMBER (count, 1);
605:
606: n = XINT (count);
607: if (n <= 0)
608: return Qnil;
609: strlen = max (n, 256);
610: string = (unsigned char *) alloca (strlen);
611: for (i = 0; i < strlen; i++)
612: string[i] = XFASTINT (chr);
613: while (n >= strlen)
614: {
615: insert (string, strlen);
616: n -= strlen;
617: }
618: if (n > 0)
619: insert (string, n);
620: return Qnil;
621: }
622:
623:
624: /* Return a string with the contents of the current region */
625:
626: DEFUN ("buffer-substring", Fbuffer_substring, Sbuffer_substring, 2, 2, 0,
627: "Return the contents of part of the current buffer as a string.\n\
628: The two arguments specify the start and end, as character numbers.")
629: (b, e)
630: Lisp_Object b, e;
631: {
632: register int beg, end;
633:
634: validate_region (&b, &e);
635: beg = XINT (b);
636: end = XINT (e);
637:
638: if (beg < GPT && end > GPT)
639: move_gap (beg);
640: return make_string (&FETCH_CHAR (beg), end - beg);
641: }
642:
643: DEFUN ("buffer-string", Fbuffer_string, Sbuffer_string, 0, 0, 0,
644: "Return the contents of the current buffer as a string.")
645: ()
646: {
647: if (BEGV < GPT && ZV > GPT)
648: move_gap (BEGV);
649: return make_string (BEGV_ADDR, ZV - BEGV);
650: }
651:
652: DEFUN ("insert-buffer-substring", Finsert_buffer_substring, Sinsert_buffer_substring,
653: 1, 3, 0,
654: "Insert before point a substring of the contents buffer BUFFER.\n\
655: BUFFER may be a buffer or a buffer name.\n\
656: Arguments START and END are character numbers specifying the substring.\n\
657: They default to the beginning and the end of BUFFER.")
658: (buf, b, e)
659: Lisp_Object buf, b, e;
660: {
661: register int beg, end, exch;
662: register struct buffer *bp;
663:
664: buf = Fget_buffer (buf);
665: bp = XBUFFER (buf);
666:
667: if (NULL (b))
668: beg = BUF_BEGV (bp);
669: else
670: {
671: CHECK_NUMBER_COERCE_MARKER (b, 0);
672: beg = XINT (b);
673: }
674: if (NULL (e))
675: end = BUF_ZV (bp);
676: else
677: {
678: CHECK_NUMBER_COERCE_MARKER (e, 1);
679: end = XINT (e);
680: }
681:
682: if (beg > end)
683: exch = beg, beg = end, end = exch;
684:
685: /* Move the gap or create enough gap in the current buffer. */
686:
687: if (point != GPT)
688: move_gap (point);
689: if (GAP_SIZE < end - beg)
690: make_gap (end - beg - GAP_SIZE);
691:
692: if (!(BUF_BEGV (bp) <= beg
693: && beg <= end
694: && end <= BUF_ZV (bp)))
695: args_out_of_range (b, e);
696:
697: /* Now the actual insertion will not do any gap motion,
698: so it matters not if BUF is the current buffer. */
699:
700: if (beg < BUF_GPT (bp))
701: {
702: insert (BUF_CHAR_ADDRESS (bp, beg), min (end, BUF_GPT (bp)) - beg);
703: beg = min (end, BUF_GPT (bp));
704: }
705: if (beg < end)
706: insert (BUF_CHAR_ADDRESS (bp, beg), end - beg);
707:
708: return Qnil;
709: }
710:
711: DEFUN ("subst-char-in-region", Fsubst_char_in_region,
712: Ssubst_char_in_region, 4, 5, 0,
713: "From START to END, replace FROMCHAR with TOCHAR each time it occurs.\n\
714: If optional arg NOUNDO is non-nil, don't record this change for undo\n\
715: and don't mark the buffer as really changed.")
716: (start, end, fromchar, tochar, noundo)
717: Lisp_Object start, end, fromchar, tochar, noundo;
718: {
719: register int pos, stop, look;
720:
721: validate_region (&start, &end);
722: CHECK_NUMBER (fromchar, 2);
723: CHECK_NUMBER (tochar, 3);
724:
725: pos = XINT (start);
726: stop = XINT (end);
727: look = XINT (fromchar);
728:
729: modify_region (pos, stop);
730: if (! NULL (noundo))
731: {
732: if (MODIFF - 1 == current_buffer->save_modified)
733: current_buffer->save_modified++;
734: if (MODIFF - 1 == current_buffer->auto_save_modified)
735: current_buffer->auto_save_modified++;
736: }
737:
738: while (pos < stop)
739: {
740: if (FETCH_CHAR (pos) == look)
741: {
742: if (NULL (noundo))
743: record_change (pos, 1);
744: FETCH_CHAR (pos) = XINT (tochar);
745: }
746: pos++;
747: }
748:
749: return Qnil;
750: }
751:
752: DEFUN ("delete-region", Fdelete_region, Sdelete_region, 2, 2, "r",
753: "Delete the text between point and mark.\n\
754: When called from a program, expects two arguments,\n\
755: character numbers specifying the stretch to be deleted.")
756: (b, e)
757: Lisp_Object b, e;
758: {
759: validate_region (&b, &e);
760: del_range (XINT (b), XINT (e));
761: return Qnil;
762: }
763:
764: DEFUN ("widen", Fwiden, Swiden, 0, 0, "",
765: "Remove restrictions from current buffer, allowing full text to be seen and edited.")
766: ()
767: {
768: BEGV = BEG;
769: SET_BUF_ZV (current_buffer, Z);
770: clip_changed = 1;
771: /* Changing the buffer bounds invalidates any recorded current column. */
772: invalidate_current_column ();
773: return Qnil;
774: }
775:
776: DEFUN ("narrow-to-region", Fnarrow_to_region, Snarrow_to_region, 2, 2, "r",
777: "Restrict editing in this buffer to the current region.\n\
778: The rest of the text becomes temporarily invisible and untouchable\n\
779: but is not deleted; if you save the buffer in a file, the invisible\n\
780: text is included in the file. \\[widen] makes all visible again.\n\
781: \n\
782: When calling from a program, pass two arguments; character numbers\n\
783: bounding the text that should remain visible.")
784: (b, e)
785: register Lisp_Object b, e;
786: {
787: register int i;
788:
789: CHECK_NUMBER_COERCE_MARKER (b, 0);
790: CHECK_NUMBER_COERCE_MARKER (e, 1);
791:
792: if (XINT (b) > XINT (e))
793: {
794: i = XFASTINT (b);
795: b = e;
796: XFASTINT (e) = i;
797: }
798:
799: if (!(BEG <= XINT (b) && XINT (b) <= XINT (e) && XINT (e) <= Z))
800: args_out_of_range (b, e);
801:
802: BEGV = XFASTINT (b);
803: SET_BUF_ZV (current_buffer, XFASTINT (e));
804: if (point < XFASTINT (b))
805: SET_PT (XFASTINT (b));
806: if (point > XFASTINT (e))
807: SET_PT (XFASTINT (e));
808: clip_changed = 1;
809: /* Changing the buffer bounds invalidates any recorded current column. */
810: invalidate_current_column ();
811: return Qnil;
812: }
813:
814: Lisp_Object
815: save_restriction_save ()
816: {
817: register Lisp_Object bottom, top;
818: /* Note: I tried using markers here, but it does not win
819: because insertion at the end of the saved region
820: does not advance top and is considered "outside" the saved region. */
821: XFASTINT (bottom) = BEGV - BEG;
822: XFASTINT (top) = Z - ZV;
823:
824: return Fcons (Fcurrent_buffer (), Fcons (bottom, top));
825: }
826:
827: Lisp_Object
828: save_restriction_restore (data)
829: Lisp_Object data;
830: {
831: register struct buffer *buf;
832: register int newhead, newtail;
833: register Lisp_Object tem;
834:
835: buf = XBUFFER (XCONS (data)->car);
836:
837: data = XCONS (data)->cdr;
838:
839: tem = XCONS (data)->car;
840: newhead = XINT (tem);
841: tem = XCONS (data)->cdr;
842: newtail = XINT (tem);
843: if (newhead + newtail > BUF_Z (buf) - BUF_BEG (buf))
844: {
845: newhead = 0;
846: newtail = 0;
847: }
848: BUF_BEGV (buf) = BUF_BEG (buf) + newhead;
849: SET_BUF_ZV (buf, BUF_Z (buf) - newtail);
850: clip_changed = 1;
851:
852: /* If point is outside the new visible range, move it inside. */
853: SET_BUF_PT (buf,
854: clip_to_bounds (BUF_BEGV (buf), BUF_PT (buf), BUF_ZV (buf)));
855:
856: return Qnil;
857: }
858:
859: DEFUN ("save-restriction", Fsave_restriction, Ssave_restriction, 0, UNEVALLED, 0,
860: "Execute the body, undoing at the end any changes to current buffer's restrictions.\n\
861: Changes to restrictions are made by narrow-to-region or by widen.\n\
862: Thus, the restrictions are the same after this function as they were before it.\n\
863: The value returned is that returned by the last form in the body.\n\
864: \n\
865: This function can be confused if, within the body, you widen\n\
866: and then make changes outside the area within the saved restrictions.\n\
867: \n\
868: Note: if you are using both save-excursion and save-restriction,\n\
869: use save-excursion outermost.")
870: (body)
871: Lisp_Object body;
872: {
873: register Lisp_Object val;
874: int count = specpdl_ptr - specpdl;
875:
876: record_unwind_protect (save_restriction_restore, save_restriction_save ());
877: val = Fprogn (body);
878: unbind_to (count);
879: return val;
880: }
881:
882: DEFUN ("message", Fmessage, Smessage, 1, MANY, 0,
883: "Print a one-line message at the bottom of the screen.\n\
884: The first argument is a control string.\n\
885: It may contain %s or %d or %c to print successive following arguments.\n\
886: %s means print an argument as a string, %d means print as number in decimal,\n\
887: %c means print a number as a single character.\n\
888: The argument used by %s must be a string or a symbol;\n\
889: the argument used by %d or %c must be a number.")
890: (nargs, args)
891: int nargs;
892: Lisp_Object *args;
893: {
894: register Lisp_Object val;
895:
896: val = Fformat (nargs, args);
897: message ("%s", XSTRING (val)->data);
898: return val;
899: }
900:
901: DEFUN ("format", Fformat, Sformat, 1, MANY, 0,
902: "Format a string out of a control-string and arguments.\n\
903: The first argument is a control string.\n\
904: It, and subsequent arguments substituted into it, become the value, which is a string.\n\
905: It may contain %s or %d or %c to substitute successive following arguments.\n\
906: %s means print an argument as a string, %d means print as number in decimal,\n\
907: %c means print a number as a single character.\n\
908: The argument used by %s must be a string or a symbol;\n\
909: the argument used by %d, %b, %o, %x or %c must be a number.")
910: (nargs, args)
911: int nargs;
912: register Lisp_Object *args;
913: {
914: register int n;
915: register int total = 5;
916: char *buf;
917: register unsigned char *format;
918: register unsigned char **strings;
919: extern char *index ();
920: /* It should not be necessary to GCPRO ARGS, because
921: the caller in the interpreter should take care of that. */
922:
923: CHECK_STRING (args[0], 0);
924: format = XSTRING (args[0])->data;
925:
926: /* We have to do so much work in order to prepare to call doprnt
927: that we might as well do all of it ourself... (Which would also
928: circumvent C asciz cretinism by allowing ascii 000 chars to appear)
929: */
930: n = 0;
931: while (format = (unsigned char *) index (format, '%'))
932: {
933: format++;
934: while ((*format >= '0' && *format <= '9')
935: || *format == '-' || *format == ' ')
936: format++;
937: if (*format == '%')
938: format++;
939: else if (++n >= nargs)
940: ;
941: else if (XTYPE (args[n]) == Lisp_Symbol)
942: {
943: XSET (args[n], Lisp_String, XSYMBOL (args[n])->name);
944: goto string;
945: }
946: else if (XTYPE (args[n]) == Lisp_String)
947: {
948: string:
949: total += XSTRING (args[n])->size;
950: }
951: /* would get MPV otherwise, since Lisp_Int's `point' to low memory */
952: else if (XTYPE (args[n]) == Lisp_Int && *format != 's')
953: total += 10;
954: else
955: {
956: register Lisp_Object tem;
957: tem = Fprin1_to_string (args[n]);
958: args[n] = tem;
959: goto string;
960: }
961: }
962:
963: strings = (unsigned char **) alloca ((n + 1) * sizeof (unsigned char *));
964: for (; n >= 0; n--)
965: {
966: if (n >= nargs)
967: strings[n] = (unsigned char *) "";
968: else if (XTYPE (args[n]) == Lisp_Int)
969: /* We checked above that the correspondiong format effector
970: isn't %s, which would cause MPV */
971: strings[n] = (unsigned char *) XINT (args[n]);
972: else
973: strings[n] = XSTRING (args[n])->data;
974: }
975:
976: /* Format it in bigger and bigger buf's until it all fits. */
977: while (1)
978: {
979: buf = (char *) alloca (total + 1);
980: buf[total - 1] = 0;
981:
982: doprnt (buf, total + 1, strings[0], nargs, strings + 1);
983: if (buf[total - 1] == 0)
984: break;
985:
986: total *= 2;
987: }
988:
989: /* UNGCPRO; */
990: return build_string (buf);
991: }
992:
993: /* VARARGS 1 */
994: Lisp_Object
995: #ifdef NO_ARG_ARRAY
996: format1 (string1, arg0, arg1, arg2, arg3, arg4)
997: int arg0, arg1, arg2, arg3, arg4;
998: #else
999: format1 (string1)
1000: #endif
1001: char *string1;
1002: {
1003: char buf[100];
1004: #ifdef NO_ARG_ARRAY
1005: int args[5];
1006: args[0] = arg0;
1007: args[1] = arg1;
1008: args[2] = arg2;
1009: args[3] = arg3;
1010: args[4] = arg4;
1011: doprnt (buf, sizeof buf, string1, 5, args);
1012: #else
1013: doprnt (buf, sizeof buf, string1, 5, &string1 + 1);
1014: #endif
1015: return build_string (buf);
1016: }
1017:
1018: DEFUN ("char-equal", Fchar_equal, Schar_equal, 2, 2, 0,
1019: "T if args (both characters (numbers)) match. May ignore case.\n\
1020: Case is ignored if the current buffer specifies to do so.")
1021: (c1, c2)
1022: register Lisp_Object c1, c2;
1023: {
1024: CHECK_NUMBER (c1, 0);
1025: CHECK_NUMBER (c2, 1);
1026:
1027: if (!NULL (current_buffer->case_fold_search)
1028: ? downcase_table[0xff & XFASTINT (c1)] == downcase_table[0xff & XFASTINT (c2)]
1029: : XINT (c1) == XINT (c2))
1030: return Qt;
1031: return Qnil;
1032: }
1033:
1034: #ifndef MAINTAIN_ENVIRONMENT /* it is done in environ.c in that case */
1035: DEFUN ("getenv", Fgetenv, Sgetenv, 1, 2, 0,
1036: "Return the value of environment variable VAR, as a string.\n\
1037: VAR should be a string. If the environment variable VAR is not defined,\n\
1038: the value is nil.")
1039: (str)
1040: Lisp_Object str;
1041: {
1042: register char *val;
1043: CHECK_STRING (str, 0);
1044: val = (char *) egetenv (XSTRING (str)->data);
1045: if (!val)
1046: return Qnil;
1047: return build_string (val);
1048: }
1049: #endif MAINTAIN_ENVIRONMENT
1050:
1051: void
1052: syms_of_editfns ()
1053: {
1054: staticpro (&Vsystem_name);
1055: staticpro (&Vuser_name);
1056: staticpro (&Vuser_full_name);
1057: staticpro (&Vuser_real_name);
1058:
1059: defsubr (&Schar_equal);
1060: defsubr (&Sgoto_char);
1061: defsubr (&Sstring_to_char);
1062: defsubr (&Schar_to_string);
1063: defsubr (&Sbuffer_substring);
1064: defsubr (&Sbuffer_string);
1065:
1066: defsubr (&Spoint_marker);
1067: defsubr (&Smark_marker);
1068: defsubr (&Spoint);
1069: defsubr (&Sregion_beginning);
1070: defsubr (&Sregion_end);
1071: /* defsubr (&Smark); */
1072: /* defsubr (&Sset_mark); */
1073: defsubr (&Ssave_excursion);
1074:
1075: defsubr (&Sbufsize);
1076: defsubr (&Spoint_max);
1077: defsubr (&Spoint_min);
1078: defsubr (&Spoint_min_marker);
1079: defsubr (&Spoint_max_marker);
1080:
1081: defsubr (&Sbobp);
1082: defsubr (&Seobp);
1083: defsubr (&Sbolp);
1084: defsubr (&Seolp);
1085: defsubr (&Sfollchar);
1086: defsubr (&Sprevchar);
1087: defsubr (&Schar_after);
1088: defsubr (&Sinsert);
1089: defsubr (&Sinsert_before_markers);
1090: defsubr (&Sinsert_char);
1091:
1092: defsubr (&Suser_login_name);
1093: defsubr (&Suser_real_login_name);
1094: defsubr (&Suser_uid);
1095: defsubr (&Suser_real_uid);
1096: defsubr (&Suser_full_name);
1097: defsubr (&Scurrent_time_string);
1098: defsubr (&Ssystem_name);
1099: defsubr (&Smessage);
1100: defsubr (&Sformat);
1101: #ifndef MAINTAIN_ENVIRONMENT /* in environ.c */
1102: defsubr (&Sgetenv);
1103: #endif
1104:
1105: defsubr (&Sinsert_buffer_substring);
1106: defsubr (&Ssubst_char_in_region);
1107: defsubr (&Sdelete_region);
1108: defsubr (&Swiden);
1109: defsubr (&Snarrow_to_region);
1110: defsubr (&Ssave_restriction);
1111: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.