![[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.