305
|
1 /* Lisp functions pertaining to editing.
|
37046
|
2 Copyright (C) 1985,86,87,89,93,94,95,96,97,98, 1999, 2000, 2001
|
31016
|
3 Free Software Foundation, Inc.
|
305
|
4
|
|
5 This file is part of GNU Emacs.
|
|
6
|
|
7 GNU Emacs is free software; you can redistribute it and/or modify
|
|
8 it under the terms of the GNU General Public License as published by
|
12244
|
9 the Free Software Foundation; either version 2, or (at your option)
|
305
|
10 any later version.
|
|
11
|
|
12 GNU Emacs is distributed in the hope that it will be useful,
|
|
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
15 GNU General Public License for more details.
|
|
16
|
|
17 You should have received a copy of the GNU General Public License
|
|
18 along with GNU Emacs; see the file COPYING. If not, write to
|
14862
|
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
|
20 Boston, MA 02111-1307, USA. */
|
305
|
21
|
|
22
|
26088
b7aa6ac26872
Add support for large files, 64-bit Solaris, system locale codings.
Paul Eggert <eggert@twinsun.com>
diff
changeset
|
23 #include <config.h>
|
2962
|
24 #include <sys/types.h>
|
|
25
|
372
|
26 #ifdef VMS
|
577
|
27 #include "vms-pwd.h"
|
372
|
28 #else
|
305
|
29 #include <pwd.h>
|
372
|
30 #endif
|
|
31
|
21514
|
32 #ifdef HAVE_UNISTD_H
|
|
33 #include <unistd.h>
|
|
34 #endif
|
|
35
|
40699
|
36 #include <ctype.h>
|
|
37
|
305
|
38 #include "lisp.h"
|
1285
d50533e23dff
* editfns.c (make_buffer_string): Call copy_intervals_to_string().
Joseph Arceneaux <jla@gnu.org>
diff
changeset
|
39 #include "intervals.h"
|
305
|
40 #include "buffer.h"
|
17031
|
41 #include "charset.h"
|
26088
b7aa6ac26872
Add support for large files, 64-bit Solaris, system locale codings.
Paul Eggert <eggert@twinsun.com>
diff
changeset
|
42 #include "coding.h"
|
38059
|
43 #include "frame.h"
|
305
|
44 #include "window.h"
|
|
45
|
577
|
46 #include "systime.h"
|
305
|
47
|
38519
|
48 #ifdef STDC_HEADERS
|
|
49 #include <float.h>
|
|
50 #define MAX_10_EXP DBL_MAX_10_EXP
|
|
51 #else
|
|
52 #define MAX_10_EXP 310
|
|
53 #endif
|
|
54
|
19441
|
55 #ifndef NULL
|
|
56 #define NULL 0
|
|
57 #endif
|
|
58
|
31095
|
59 #ifndef USE_CRT_DLL
|
13025
|
60 extern char **environ;
|
31095
|
61 #endif
|
|
62
|
31016
|
63 extern Lisp_Object make_time P_ ((time_t));
|
|
64 extern size_t emacs_strftimeu P_ ((char *, size_t, const char *,
|
|
65 const struct tm *, int));
|
|
66 static int tm_diff P_ ((struct tm *, struct tm *));
|
41065
|
67 static void find_field P_ ((Lisp_Object, Lisp_Object, Lisp_Object, int *, Lisp_Object, int *));
|
31016
|
68 static void update_buffer_properties P_ ((int, int));
|
|
69 static Lisp_Object region_limit P_ ((int));
|
|
70 static int lisp_time_argument P_ ((Lisp_Object, time_t *, int *));
|
|
71 static size_t emacs_memftimeu P_ ((char *, size_t, const char *,
|
|
72 size_t, const struct tm *, int));
|
|
73 static void general_insert_function P_ ((void (*) (unsigned char *, int),
|
|
74 void (*) (Lisp_Object, int, int, int,
|
|
75 int, int),
|
|
76 int, int, Lisp_Object *));
|
|
77 static Lisp_Object subst_char_in_region_unwind P_ ((Lisp_Object));
|
|
78 static Lisp_Object subst_char_in_region_unwind_1 P_ ((Lisp_Object));
|
|
79 static void transpose_markers P_ ((int, int, int, int, int, int, int, int));
|
13767
|
80
|
31336
|
81 #ifdef HAVE_INDEX
|
|
82 extern char *index P_ ((const char *, int));
|
|
83 #endif
|
|
84
|
13767
|
85 Lisp_Object Vbuffer_access_fontify_functions;
|
|
86 Lisp_Object Qbuffer_access_fontify_functions;
|
|
87 Lisp_Object Vbuffer_access_fontified_property;
|
9657
|
88
|
31016
|
89 Lisp_Object Fuser_full_name P_ ((Lisp_Object));
|
17829
|
90
|
27077
|
91 /* Non-nil means don't stop at field boundary in text motion commands. */
|
|
92
|
|
93 Lisp_Object Vinhibit_field_text_motion;
|
|
94
|
305
|
95 /* Some static data, and a function to initialize it for each run */
|
|
96
|
|
97 Lisp_Object Vsystem_name;
|
12026
|
98 Lisp_Object Vuser_real_login_name; /* login name of current user ID */
|
|
99 Lisp_Object Vuser_full_name; /* full name of current user */
|
|
100 Lisp_Object Vuser_login_name; /* user name from LOGNAME or USER */
|
305
|
101
|
31016
|
102 /* Symbol for the text property used to mark fields. */
|
|
103
|
|
104 Lisp_Object Qfield;
|
|
105
|
|
106 /* A special value for Qfield properties. */
|
|
107
|
|
108 Lisp_Object Qboundary;
|
|
109
|
|
110
|
305
|
111 void
|
|
112 init_editfns ()
|
|
113 {
|
330
|
114 char *user_name;
|
25782
|
115 register unsigned char *p;
|
305
|
116 struct passwd *pw; /* password entry for the current user */
|
|
117 Lisp_Object tem;
|
|
118
|
|
119 /* Set up system_name even when dumping. */
|
7907
|
120 init_system_name ();
|
305
|
121
|
|
122 #ifndef CANNOT_DUMP
|
|
123 /* Don't bother with this on initial start when just dumping out */
|
|
124 if (!initialized)
|
|
125 return;
|
|
126 #endif /* not CANNOT_DUMP */
|
|
127
|
|
128 pw = (struct passwd *) getpwuid (getuid ());
|
9572
|
129 #ifdef MSDOS
|
|
130 /* We let the real user name default to "root" because that's quite
|
|
131 accurate on MSDOG and because it lets Emacs find the init file.
|
|
132 (The DVX libraries override the Djgpp libraries here.) */
|
12026
|
133 Vuser_real_login_name = build_string (pw ? pw->pw_name : "root");
|
9572
|
134 #else
|
12026
|
135 Vuser_real_login_name = build_string (pw ? pw->pw_name : "unknown");
|
9572
|
136 #endif
|
305
|
137
|
330
|
138 /* Get the effective user name, by consulting environment variables,
|
|
139 or the effective uid if those are unset. */
|
5907
|
140 user_name = (char *) getenv ("LOGNAME");
|
330
|
141 if (!user_name)
|
9801
|
142 #ifdef WINDOWSNT
|
|
143 user_name = (char *) getenv ("USERNAME"); /* it's USERNAME on NT */
|
|
144 #else /* WINDOWSNT */
|
5907
|
145 user_name = (char *) getenv ("USER");
|
9801
|
146 #endif /* WINDOWSNT */
|
305
|
147 if (!user_name)
|
330
|
148 {
|
|
149 pw = (struct passwd *) getpwuid (geteuid ());
|
|
150 user_name = (char *) (pw ? pw->pw_name : "unknown");
|
|
151 }
|
12026
|
152 Vuser_login_name = build_string (user_name);
|
305
|
153
|
330
|
154 /* If the user name claimed in the environment vars differs from
|
|
155 the real uid, use the claimed name to find the full name. */
|
12026
|
156 tem = Fstring_equal (Vuser_login_name, Vuser_real_login_name);
|
16641
|
157 Vuser_full_name = Fuser_full_name (NILP (tem)? make_number (geteuid())
|
|
158 : Vuser_login_name);
|
30480
|
159
|
11447
|
160 p = (unsigned char *) getenv ("NAME");
|
11135
|
161 if (p)
|
|
162 Vuser_full_name = build_string (p);
|
16683
6802dbd07a80
(Fuser_full_name): Return nil if the specified user doesn't exist.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
163 else if (NILP (Vuser_full_name))
|
6802dbd07a80
(Fuser_full_name): Return nil if the specified user doesn't exist.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
164 Vuser_full_name = build_string ("unknown");
|
305
|
165 }
|
|
166
|
|
167 DEFUN ("char-to-string", Fchar_to_string, Schar_to_string, 1, 1, 0,
|
40203
9d2aeb5c05b4
(char-to-string): Fix argument names (use CHAR instead of C) and usage.
Pavel Janík <Pavel@Janik.cz>
diff
changeset
|
168 doc: /* Convert arg CHAR to a string containing that character.
|
9d2aeb5c05b4
(char-to-string): Fix argument names (use CHAR instead of C) and usage.
Pavel Janík <Pavel@Janik.cz>
diff
changeset
|
169 usage: (char-to-string CHAR) */)
|
39988
|
170 (character)
|
14071
59906ecd9b92
(Fchar_to_string, Fstring_to_char, Fgoto_char, Fencode_time, Finsert_char,
Erik Naggum <erik@naggum.no>
diff
changeset
|
171 Lisp_Object character;
|
305
|
172 {
|
17031
|
173 int len;
|
26853
|
174 unsigned char str[MAX_MULTIBYTE_LENGTH];
|
17031
|
175
|
40656
|
176 CHECK_NUMBER (character);
|
305
|
177
|
35998
|
178 len = (SINGLE_BYTE_CHAR_P (XFASTINT (character))
|
|
179 ? (*str = (unsigned char)(XFASTINT (character)), 1)
|
|
180 : char_to_string (XFASTINT (character), str));
|
21257
|
181 return make_string_from_bytes (str, 1, len);
|
305
|
182 }
|
|
183
|
|
184 DEFUN ("string-to-char", Fstring_to_char, Sstring_to_char, 1, 1, 0,
|
39988
|
185 doc: /* Convert arg STRING to a character, the first character of that string.
|
|
186 A multibyte character is handled correctly. */)
|
|
187 (string)
|
14071
59906ecd9b92
(Fchar_to_string, Fstring_to_char, Fgoto_char, Fencode_time, Finsert_char,
Erik Naggum <erik@naggum.no>
diff
changeset
|
188 register Lisp_Object string;
|
305
|
189 {
|
|
190 register Lisp_Object val;
|
|
191 register struct Lisp_String *p;
|
40656
|
192 CHECK_STRING (string);
|
14071
59906ecd9b92
(Fchar_to_string, Fstring_to_char, Fgoto_char, Fencode_time, Finsert_char,
Erik Naggum <erik@naggum.no>
diff
changeset
|
193 p = XSTRING (string);
|
305
|
194 if (p->size)
|
23650
|
195 {
|
|
196 if (STRING_MULTIBYTE (string))
|
|
197 XSETFASTINT (val, STRING_CHAR (p->data, STRING_BYTES (p)));
|
|
198 else
|
|
199 XSETFASTINT (val, p->data[0]);
|
|
200 }
|
305
|
201 else
|
9305
ac077e2a75f1
(Fstring_to_char, Fpoint, Fbufsize, Fpoint_min, Fpoint_max, Ffollowing_char,
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
202 XSETFASTINT (val, 0);
|
305
|
203 return val;
|
|
204 }
|
|
205
|
|
206 static Lisp_Object
|
20558
|
207 buildmark (charpos, bytepos)
|
|
208 int charpos, bytepos;
|
305
|
209 {
|
|
210 register Lisp_Object mark;
|
|
211 mark = Fmake_marker ();
|
20558
|
212 set_marker_both (mark, Qnil, charpos, bytepos);
|
305
|
213 return mark;
|
|
214 }
|
|
215
|
|
216 DEFUN ("point", Fpoint, Spoint, 0, 0, 0,
|
39988
|
217 doc: /* Return value of point, as an integer.
|
|
218 Beginning of buffer is position (point-min). */)
|
|
219 ()
|
305
|
220 {
|
|
221 Lisp_Object temp;
|
16039
|
222 XSETFASTINT (temp, PT);
|
305
|
223 return temp;
|
|
224 }
|
|
225
|
|
226 DEFUN ("point-marker", Fpoint_marker, Spoint_marker, 0, 0, 0,
|
39988
|
227 doc: /* Return value of point, as a marker object. */)
|
|
228 ()
|
305
|
229 {
|
20558
|
230 return buildmark (PT, PT_BYTE);
|
305
|
231 }
|
|
232
|
|
233 int
|
|
234 clip_to_bounds (lower, num, upper)
|
|
235 int lower, num, upper;
|
|
236 {
|
|
237 if (num < lower)
|
|
238 return lower;
|
|
239 else if (num > upper)
|
|
240 return upper;
|
|
241 else
|
|
242 return num;
|
|
243 }
|
|
244
|
|
245 DEFUN ("goto-char", Fgoto_char, Sgoto_char, 1, 1, "NGoto char: ",
|
39988
|
246 doc: /* Set point to POSITION, a number or marker.
|
39966
|
247 Beginning of buffer is position (point-min), end is (point-max).
|
|
248 If the position is in the middle of a multibyte form,
|
|
249 the actual point is set at the head of the multibyte form
|
39988
|
250 except in the case that `enable-multibyte-characters' is nil. */)
|
|
251 (position)
|
14071
59906ecd9b92
(Fchar_to_string, Fstring_to_char, Fgoto_char, Fencode_time, Finsert_char,
Erik Naggum <erik@naggum.no>
diff
changeset
|
252 register Lisp_Object position;
|
305
|
253 {
|
17031
|
254 int pos;
|
|
255
|
21226
|
256 if (MARKERP (position)
|
|
257 && current_buffer == XMARKER (position)->buffer)
|
20558
|
258 {
|
|
259 pos = marker_position (position);
|
|
260 if (pos < BEGV)
|
|
261 SET_PT_BOTH (BEGV, BEGV_BYTE);
|
|
262 else if (pos > ZV)
|
|
263 SET_PT_BOTH (ZV, ZV_BYTE);
|
|
264 else
|
|
265 SET_PT_BOTH (pos, marker_byte_position (position));
|
|
266
|
|
267 return position;
|
|
268 }
|
|
269
|
40656
|
270 CHECK_NUMBER_COERCE_MARKER (position);
|
305
|
271
|
17031
|
272 pos = clip_to_bounds (BEGV, XINT (position), ZV);
|
|
273 SET_PT (pos);
|
14071
59906ecd9b92
(Fchar_to_string, Fstring_to_char, Fgoto_char, Fencode_time, Finsert_char,
Erik Naggum <erik@naggum.no>
diff
changeset
|
274 return position;
|
305
|
275 }
|
|
276
|
31016
|
277
|
|
278 /* Return the start or end position of the region.
|
|
279 BEGINNINGP non-zero means return the start.
|
|
280 If there is no region active, signal an error. */
|
|
281
|
305
|
282 static Lisp_Object
|
|
283 region_limit (beginningp)
|
|
284 int beginningp;
|
|
285 {
|
4047
|
286 extern Lisp_Object Vmark_even_if_inactive; /* Defined in callint.c. */
|
31016
|
287 Lisp_Object m;
|
|
288
|
|
289 if (!NILP (Vtransient_mark_mode)
|
|
290 && NILP (Vmark_even_if_inactive)
|
4038
03a4c3912c13
(region_limit): Don't error if Vmark_even_if_inactive is set. When the
Roland McGrath <roland@gnu.org>
diff
changeset
|
291 && NILP (current_buffer->mark_active))
|
03a4c3912c13
(region_limit): Don't error if Vmark_even_if_inactive is set. When the
Roland McGrath <roland@gnu.org>
diff
changeset
|
292 Fsignal (Qmark_inactive, Qnil);
|
31016
|
293
|
305
|
294 m = Fmarker_position (current_buffer->mark);
|
31016
|
295 if (NILP (m))
|
|
296 error ("There is no region now");
|
|
297
|
16039
|
298 if ((PT < XFASTINT (m)) == beginningp)
|
31016
|
299 m = make_number (PT);
|
|
300 return m;
|
305
|
301 }
|
|
302
|
|
303 DEFUN ("region-beginning", Fregion_beginning, Sregion_beginning, 0, 0, 0,
|
39988
|
304 doc: /* Return position of beginning of region, as an integer. */)
|
|
305 ()
|
305
|
306 {
|
31016
|
307 return region_limit (1);
|
305
|
308 }
|
|
309
|
|
310 DEFUN ("region-end", Fregion_end, Sregion_end, 0, 0, 0,
|
39988
|
311 doc: /* Return position of end of region, as an integer. */)
|
|
312 ()
|
305
|
313 {
|
31016
|
314 return region_limit (0);
|
305
|
315 }
|
|
316
|
|
317 DEFUN ("mark-marker", Fmark_marker, Smark_marker, 0, 0, 0,
|
39988
|
318 doc: /* Return this buffer's mark, as a marker object.
|
39966
|
319 Watch out! Moving this marker changes the mark position.
|
39988
|
320 If you set the marker not to point anywhere, the buffer will have no mark. */)
|
|
321 ()
|
305
|
322 {
|
|
323 return current_buffer->mark;
|
|
324 }
|
31016
|
325
|
16639
|
326
|
37916
|
327 #if 0 /* Not used. */
|
|
328
|
26389
|
329 /* Return nonzero if POS1 and POS2 have the same value
|
|
330 for the text property PROP. */
|
|
331
|
26058
|
332 static int
|
30244
|
333 char_property_eq (prop, pos1, pos2)
|
26058
|
334 Lisp_Object prop;
|
|
335 Lisp_Object pos1, pos2;
|
|
336 {
|
|
337 Lisp_Object pval1, pval2;
|
|
338
|
30244
|
339 pval1 = Fget_char_property (pos1, prop, Qnil);
|
|
340 pval2 = Fget_char_property (pos2, prop, Qnil);
|
26058
|
341
|
|
342 return EQ (pval1, pval2);
|
|
343 }
|
|
344
|
37916
|
345 #endif /* 0 */
|
|
346
|
32850
|
347 /* Return the direction from which the text-property PROP would be
|
26389
|
348 inherited by any new text inserted at POS: 1 if it would be
|
|
349 inherited from the char after POS, -1 if it would be inherited from
|
|
350 the char before POS, and 0 if from neither. */
|
|
351
|
26058
|
352 static int
|
32850
|
353 text_property_stickiness (prop, pos)
|
26058
|
354 Lisp_Object prop;
|
|
355 Lisp_Object pos;
|
|
356 {
|
40046
|
357 Lisp_Object prev_pos, front_sticky;
|
|
358 int is_rear_sticky = 1, is_front_sticky = 0; /* defaults */
|
26058
|
359
|
26389
|
360 if (XINT (pos) > BEGV)
|
|
361 /* Consider previous character. */
|
26058
|
362 {
|
40046
|
363 Lisp_Object rear_non_sticky;
|
|
364
|
|
365 prev_pos = make_number (XINT (pos) - 1);
|
|
366 rear_non_sticky = Fget_text_property (prev_pos, Qrear_nonsticky, Qnil);
|
|
367
|
40287
5798240154fd
(text_property_stickiness): Fix Lisp_Object used as boolean.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
368 if (!NILP (CONSP (rear_non_sticky)
|
5798240154fd
(text_property_stickiness): Fix Lisp_Object used as boolean.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
369 ? Fmemq (prop, rear_non_sticky)
|
5798240154fd
(text_property_stickiness): Fix Lisp_Object used as boolean.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
370 : rear_non_sticky))
|
40046
|
371 /* PROP is rear-non-sticky. */
|
|
372 is_rear_sticky = 0;
|
26058
|
373 }
|
|
374
|
26389
|
375 /* Consider following character. */
|
32850
|
376 front_sticky = Fget_text_property (pos, Qfront_sticky, Qnil);
|
26058
|
377
|
|
378 if (EQ (front_sticky, Qt)
|
|
379 || (CONSP (front_sticky)
|
28470
93996c44b23a
* editfns.c (text_property_stickiness, Fmessage_or_box): Use NILP to test
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
380 && !NILP (Fmemq (prop, front_sticky))))
|
26389
|
381 /* PROP is inherited from after. */
|
40046
|
382 is_front_sticky = 1;
|
|
383
|
|
384 /* Simple cases, where the properties are consistent. */
|
|
385 if (is_rear_sticky && !is_front_sticky)
|
|
386 return -1;
|
|
387 else if (!is_rear_sticky && is_front_sticky)
|
26058
|
388 return 1;
|
40046
|
389 else if (!is_rear_sticky && !is_front_sticky)
|
|
390 return 0;
|
|
391
|
|
392 /* The stickiness properties are inconsistent, so we have to
|
|
393 disambiguate. Basically, rear-sticky wins, _except_ if the
|
|
394 property that would be inherited has a value of nil, in which case
|
|
395 front-sticky wins. */
|
|
396 if (XINT (pos) == BEGV || NILP (Fget_text_property (prev_pos, prop, Qnil)))
|
|
397 return 1;
|
|
398 else
|
|
399 return -1;
|
26058
|
400 }
|
31016
|
401
|
26058
|
402
|
26389
|
403 /* Find the field surrounding POS in *BEG and *END. If POS is nil,
|
31016
|
404 the value of point is used instead. If BEG or END null,
|
|
405 means don't store the beginning or end of the field.
|
26389
|
406
|
41065
|
407 BEG_LIMIT and END_LIMIT serve to limit the ranged of the returned
|
|
408 results; they do not effect boundary behavior.
|
|
409
|
26389
|
410 If MERGE_AT_BOUNDARY is nonzero, then if POS is at the very first
|
30439
|
411 position of a field, then the beginning of the previous field is
|
|
412 returned instead of the beginning of POS's field (since the end of a
|
|
413 field is actually also the beginning of the next input field, this
|
|
414 behavior is sometimes useful). Additionally in the MERGE_AT_BOUNDARY
|
|
415 true case, if two fields are separated by a field with the special
|
|
416 value `boundary', and POS lies within it, then the two separated
|
|
417 fields are considered to be adjacent, and POS between them, when
|
|
418 finding the beginning and ending of the "merged" field.
|
26389
|
419
|
|
420 Either BEG or END may be 0, in which case the corresponding value
|
|
421 is not stored. */
|
|
422
|
31016
|
423 static void
|
41065
|
424 find_field (pos, merge_at_boundary, beg_limit, beg, end_limit, end)
|
26058
|
425 Lisp_Object pos;
|
|
426 Lisp_Object merge_at_boundary;
|
41065
|
427 Lisp_Object beg_limit, end_limit;
|
26058
|
428 int *beg, *end;
|
|
429 {
|
30439
|
430 /* Fields right before and after the point. */
|
|
431 Lisp_Object before_field, after_field;
|
32850
|
432 /* If the fields came from overlays, the associated overlays.
|
|
433 Qnil means they came from text-properties. */
|
|
434 Lisp_Object before_overlay = Qnil, after_overlay = Qnil;
|
26389
|
435 /* 1 if POS counts as the start of a field. */
|
|
436 int at_field_start = 0;
|
|
437 /* 1 if POS counts as the end of a field. */
|
|
438 int at_field_end = 0;
|
30439
|
439
|
26058
|
440 if (NILP (pos))
|
|
441 XSETFASTINT (pos, PT);
|
|
442 else
|
40656
|
443 CHECK_NUMBER_COERCE_MARKER (pos);
|
26058
|
444
|
31016
|
445 after_field
|
32850
|
446 = get_char_property_and_overlay (pos, Qfield, Qnil, &after_overlay);
|
31016
|
447 before_field
|
|
448 = (XFASTINT (pos) > BEGV
|
32850
|
449 ? get_char_property_and_overlay (make_number (XINT (pos) - 1),
|
|
450 Qfield, Qnil,
|
|
451 &before_overlay)
|
31016
|
452 : Qnil);
|
30439
|
453
|
|
454 /* See if we need to handle the case where MERGE_AT_BOUNDARY is nil
|
|
455 and POS is at beginning of a field, which can also be interpreted
|
|
456 as the end of the previous field. Note that the case where if
|
|
457 MERGE_AT_BOUNDARY is non-nil (see function comment) is actually the
|
|
458 more natural one; then we avoid treating the beginning of a field
|
|
459 specially. */
|
|
460 if (NILP (merge_at_boundary) && !EQ (after_field, before_field))
|
|
461 /* We are at a boundary, see which direction is inclusive. We
|
|
462 decide by seeing which field the `field' property sticks to. */
|
26058
|
463 {
|
32850
|
464 /* -1 means insertions go into before_field, 1 means they go
|
|
465 into after_field, 0 means neither. */
|
|
466 int stickiness;
|
|
467 /* Whether the before/after_field come from overlays. */
|
|
468 int bop = !NILP (before_overlay);
|
|
469 int aop = !NILP (after_overlay);
|
|
470
|
|
471 if (bop && XMARKER (OVERLAY_END (before_overlay))->insertion_type == 1)
|
|
472 /* before_field is from an overlay, which expands upon
|
|
473 end-insertions. Note that it's possible for after_overlay to
|
|
474 also eat insertions here, but then they will overlap, and
|
|
475 there's not much we can do. */
|
|
476 stickiness = -1;
|
32857
|
477 else if (aop
|
|
478 && XMARKER (OVERLAY_START (after_overlay))->insertion_type == 0)
|
32850
|
479 /* after_field is from an overlay, which expand to contain
|
|
480 start-insertions. */
|
|
481 stickiness = 1;
|
|
482 else if (bop && aop)
|
|
483 /* Both fields come from overlays, but neither will contain any
|
|
484 insertion here. */
|
|
485 stickiness = 0;
|
|
486 else if (bop)
|
|
487 /* before_field is an overlay that won't eat any insertion, but
|
|
488 after_field is from a text-property. Assume that the
|
|
489 text-property continues underneath the overlay, and so will
|
|
490 be inherited by any insertion, regardless of any stickiness
|
|
491 settings. */
|
|
492 stickiness = 1;
|
|
493 else if (aop)
|
|
494 /* Similarly, when after_field is the overlay. */
|
|
495 stickiness = -1;
|
|
496 else
|
|
497 /* Both fields come from text-properties. Look for explicit
|
|
498 stickiness properties. */
|
|
499 stickiness = text_property_stickiness (Qfield, pos);
|
30439
|
500
|
|
501 if (stickiness > 0)
|
|
502 at_field_start = 1;
|
|
503 else if (stickiness < 0)
|
|
504 at_field_end = 1;
|
|
505 else
|
|
506 /* STICKINESS == 0 means that any inserted text will get a
|
|
507 `field' char-property of nil, so check to see if that
|
|
508 matches either of the adjacent characters (this being a
|
|
509 kind of "stickiness by default"). */
|
26058
|
510 {
|
30439
|
511 if (NILP (before_field))
|
|
512 at_field_end = 1; /* Sticks to the left. */
|
|
513 else if (NILP (after_field))
|
|
514 at_field_start = 1; /* Sticks to the right. */
|
26058
|
515 }
|
|
516 }
|
|
517
|
30439
|
518 /* Note about special `boundary' fields:
|
|
519
|
|
520 Consider the case where the point (`.') is between the fields `x' and `y':
|
|
521
|
|
522 xxxx.yyyy
|
|
523
|
|
524 In this situation, if merge_at_boundary is true, we consider the
|
|
525 `x' and `y' fields as forming one big merged field, and so the end
|
|
526 of the field is the end of `y'.
|
|
527
|
|
528 However, if `x' and `y' are separated by a special `boundary' field
|
|
529 (a field with a `field' char-property of 'boundary), then we ignore
|
|
530 this special field when merging adjacent fields. Here's the same
|
|
531 situation, but with a `boundary' field between the `x' and `y' fields:
|
|
532
|
|
533 xxx.BBBByyyy
|
|
534
|
|
535 Here, if point is at the end of `x', the beginning of `y', or
|
|
536 anywhere in-between (within the `boundary' field), we merge all
|
|
537 three fields and consider the beginning as being the beginning of
|
|
538 the `x' field, and the end as being the end of the `y' field. */
|
|
539
|
26058
|
540 if (beg)
|
31016
|
541 {
|
|
542 if (at_field_start)
|
|
543 /* POS is at the edge of a field, and we should consider it as
|
|
544 the beginning of the following field. */
|
|
545 *beg = XFASTINT (pos);
|
|
546 else
|
|
547 /* Find the previous field boundary. */
|
|
548 {
|
|
549 if (!NILP (merge_at_boundary) && EQ (before_field, Qboundary))
|
|
550 /* Skip a `boundary' field. */
|
41065
|
551 pos = Fprevious_single_char_property_change (pos, Qfield, Qnil,
|
|
552 beg_limit);
|
|
553
|
|
554 pos = Fprevious_single_char_property_change (pos, Qfield, Qnil,
|
|
555 beg_limit);
|
31016
|
556 *beg = NILP (pos) ? BEGV : XFASTINT (pos);
|
|
557 }
|
|
558 }
|
26058
|
559
|
|
560 if (end)
|
31016
|
561 {
|
|
562 if (at_field_end)
|
|
563 /* POS is at the edge of a field, and we should consider it as
|
|
564 the end of the previous field. */
|
|
565 *end = XFASTINT (pos);
|
|
566 else
|
|
567 /* Find the next field boundary. */
|
|
568 {
|
|
569 if (!NILP (merge_at_boundary) && EQ (after_field, Qboundary))
|
|
570 /* Skip a `boundary' field. */
|
41065
|
571 pos = Fnext_single_char_property_change (pos, Qfield, Qnil,
|
|
572 end_limit);
|
|
573
|
|
574 pos = Fnext_single_char_property_change (pos, Qfield, Qnil,
|
|
575 end_limit);
|
31016
|
576 *end = NILP (pos) ? ZV : XFASTINT (pos);
|
|
577 }
|
|
578 }
|
26058
|
579 }
|
31016
|
580
|
26058
|
581
|
26629
|
582 DEFUN ("delete-field", Fdelete_field, Sdelete_field, 0, 1, 0,
|
39988
|
583 doc: /* Delete the field surrounding POS.
|
39966
|
584 A field is a region of text with the same `field' property.
|
39988
|
585 If POS is nil, the value of point is used for POS. */)
|
|
586 (pos)
|
26058
|
587 Lisp_Object pos;
|
|
588 {
|
|
589 int beg, end;
|
41065
|
590 find_field (pos, Qnil, Qnil, &beg, Qnil, &end);
|
26058
|
591 if (beg != end)
|
|
592 del_range (beg, end);
|
26629
|
593 return Qnil;
|
26058
|
594 }
|
|
595
|
|
596 DEFUN ("field-string", Ffield_string, Sfield_string, 0, 1, 0,
|
39988
|
597 doc: /* Return the contents of the field surrounding POS as a string.
|
39966
|
598 A field is a region of text with the same `field' property.
|
39988
|
599 If POS is nil, the value of point is used for POS. */)
|
|
600 (pos)
|
26058
|
601 Lisp_Object pos;
|
|
602 {
|
|
603 int beg, end;
|
41065
|
604 find_field (pos, Qnil, Qnil, &beg, Qnil, &end);
|
26058
|
605 return make_buffer_string (beg, end, 1);
|
|
606 }
|
|
607
|
|
608 DEFUN ("field-string-no-properties", Ffield_string_no_properties, Sfield_string_no_properties, 0, 1, 0,
|
39988
|
609 doc: /* Return the contents of the field around POS, without text-properties.
|
39966
|
610 A field is a region of text with the same `field' property.
|
39988
|
611 If POS is nil, the value of point is used for POS. */)
|
|
612 (pos)
|
26058
|
613 Lisp_Object pos;
|
|
614 {
|
|
615 int beg, end;
|
41065
|
616 find_field (pos, Qnil, Qnil, &beg, Qnil, &end);
|
26058
|
617 return make_buffer_string (beg, end, 0);
|
|
618 }
|
|
619
|
41065
|
620 DEFUN ("field-beginning", Ffield_beginning, Sfield_beginning, 0, 3, 0,
|
39988
|
621 doc: /* Return the beginning of the field surrounding POS.
|
39966
|
622 A field is a region of text with the same `field' property.
|
|
623 If POS is nil, the value of point is used for POS.
|
|
624 If ESCAPE-FROM-EDGE is non-nil and POS is at the beginning of its
|
41065
|
625 field, then the beginning of the *previous* field is returned.
|
|
626 If LIMIT is non-nil, it is a buffer position; if the beginning of the field
|
|
627 is before LIMIT, then LIMIT will be returned instead. */)
|
|
628 (pos, escape_from_edge, limit)
|
|
629 Lisp_Object pos, escape_from_edge, limit;
|
26058
|
630 {
|
|
631 int beg;
|
41065
|
632 find_field (pos, escape_from_edge, limit, &beg, Qnil, 0);
|
26058
|
633 return make_number (beg);
|
|
634 }
|
|
635
|
41065
|
636 DEFUN ("field-end", Ffield_end, Sfield_end, 0, 3, 0,
|
39988
|
637 doc: /* Return the end of the field surrounding POS.
|
39966
|
638 A field is a region of text with the same `field' property.
|
|
639 If POS is nil, the value of point is used for POS.
|
|
640 If ESCAPE-FROM-EDGE is non-nil and POS is at the end of its field,
|
41065
|
641 then the end of the *following* field is returned.
|
|
642 If LIMIT is non-nil, it is a buffer position; if the end of the field
|
|
643 is after LIMIT, then LIMIT will be returned instead. */)
|
|
644 (pos, escape_from_edge, limit)
|
|
645 Lisp_Object pos, escape_from_edge, limit;
|
26058
|
646 {
|
|
647 int end;
|
41065
|
648 find_field (pos, escape_from_edge, Qnil, 0, limit, &end);
|
26058
|
649 return make_number (end);
|
|
650 }
|
|
651
|
30439
|
652 DEFUN ("constrain-to-field", Fconstrain_to_field, Sconstrain_to_field, 2, 5, 0,
|
39988
|
653 doc: /* Return the position closest to NEW-POS that is in the same field as OLD-POS.
|
39966
|
654
|
|
655 A field is a region of text with the same `field' property.
|
|
656 If NEW-POS is nil, then the current point is used instead, and set to the
|
|
657 constrained position if that is different.
|
|
658
|
|
659 If OLD-POS is at the boundary of two fields, then the allowable
|
|
660 positions for NEW-POS depends on the value of the optional argument
|
|
661 ESCAPE-FROM-EDGE: If ESCAPE-FROM-EDGE is nil, then NEW-POS is
|
|
662 constrained to the field that has the same `field' char-property
|
|
663 as any new characters inserted at OLD-POS, whereas if ESCAPE-FROM-EDGE
|
|
664 is non-nil, NEW-POS is constrained to the union of the two adjacent
|
|
665 fields. Additionally, if two fields are separated by another field with
|
|
666 the special value `boundary', then any point within this special field is
|
|
667 also considered to be `on the boundary'.
|
|
668
|
|
669 If the optional argument ONLY-IN-LINE is non-nil and constraining
|
|
670 NEW-POS would move it to a different line, NEW-POS is returned
|
|
671 unconstrained. This useful for commands that move by line, like
|
|
672 \\[next-line] or \\[beginning-of-line], which should generally respect field boundaries
|
|
673 only in the case where they can still move to the right line.
|
|
674
|
|
675 If the optional argument INHIBIT-CAPTURE-PROPERTY is non-nil, and OLD-POS has
|
|
676 a non-nil property of that name, then any field boundaries are ignored.
|
|
677
|
39988
|
678 Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */)
|
|
679 (new_pos, old_pos, escape_from_edge, only_in_line, inhibit_capture_property)
|
30439
|
680 Lisp_Object new_pos, old_pos;
|
|
681 Lisp_Object escape_from_edge, only_in_line, inhibit_capture_property;
|
26058
|
682 {
|
|
683 /* If non-zero, then the original point, before re-positioning. */
|
|
684 int orig_point = 0;
|
|
685
|
|
686 if (NILP (new_pos))
|
|
687 /* Use the current point, and afterwards, set it. */
|
|
688 {
|
|
689 orig_point = PT;
|
|
690 XSETFASTINT (new_pos, PT);
|
|
691 }
|
|
692
|
27081
|
693 if (NILP (Vinhibit_field_text_motion)
|
|
694 && !EQ (new_pos, old_pos)
|
32517
78c3fdea490c
(Fconstrain_to_field): Check carefully for field boundaries if either
Miles Bader <miles@gnu.org>
diff
changeset
|
695 && (!NILP (Fget_char_property (new_pos, Qfield, Qnil))
|
78c3fdea490c
(Fconstrain_to_field): Check carefully for field boundaries if either
Miles Bader <miles@gnu.org>
diff
changeset
|
696 || !NILP (Fget_char_property (old_pos, Qfield, Qnil)))
|
30439
|
697 && (NILP (inhibit_capture_property)
|
|
698 || NILP (Fget_char_property(old_pos, inhibit_capture_property, Qnil))))
|
26058
|
699 /* NEW_POS is not within the same field as OLD_POS; try to
|
|
700 move NEW_POS so that it is. */
|
|
701 {
|
30439
|
702 int fwd, shortage;
|
26058
|
703 Lisp_Object field_bound;
|
|
704
|
40656
|
705 CHECK_NUMBER_COERCE_MARKER (new_pos);
|
|
706 CHECK_NUMBER_COERCE_MARKER (old_pos);
|
26058
|
707
|
|
708 fwd = (XFASTINT (new_pos) > XFASTINT (old_pos));
|
|
709
|
|
710 if (fwd)
|
41065
|
711 field_bound = Ffield_end (old_pos, escape_from_edge, new_pos);
|
26058
|
712 else
|
41065
|
713 field_bound = Ffield_beginning (old_pos, escape_from_edge, new_pos);
|
26058
|
714
|
30550
73040724e653
(Fconstrain_to_field): Fix the conditions for deciding when to constrain
Miles Bader <miles@gnu.org>
diff
changeset
|
715 if (/* See if ESCAPE_FROM_EDGE caused FIELD_BOUND to jump to the
|
73040724e653
(Fconstrain_to_field): Fix the conditions for deciding when to constrain
Miles Bader <miles@gnu.org>
diff
changeset
|
716 other side of NEW_POS, which would mean that NEW_POS is
|
73040724e653
(Fconstrain_to_field): Fix the conditions for deciding when to constrain
Miles Bader <miles@gnu.org>
diff
changeset
|
717 already acceptable, and it's not necessary to constrain it
|
73040724e653
(Fconstrain_to_field): Fix the conditions for deciding when to constrain
Miles Bader <miles@gnu.org>
diff
changeset
|
718 to FIELD_BOUND. */
|
73040724e653
(Fconstrain_to_field): Fix the conditions for deciding when to constrain
Miles Bader <miles@gnu.org>
diff
changeset
|
719 ((XFASTINT (field_bound) < XFASTINT (new_pos)) ? fwd : !fwd)
|
73040724e653
(Fconstrain_to_field): Fix the conditions for deciding when to constrain
Miles Bader <miles@gnu.org>
diff
changeset
|
720 /* NEW_POS should be constrained, but only if either
|
73040724e653
(Fconstrain_to_field): Fix the conditions for deciding when to constrain
Miles Bader <miles@gnu.org>
diff
changeset
|
721 ONLY_IN_LINE is nil (in which case any constraint is OK),
|
73040724e653
(Fconstrain_to_field): Fix the conditions for deciding when to constrain
Miles Bader <miles@gnu.org>
diff
changeset
|
722 or NEW_POS and FIELD_BOUND are on the same line (in which
|
73040724e653
(Fconstrain_to_field): Fix the conditions for deciding when to constrain
Miles Bader <miles@gnu.org>
diff
changeset
|
723 case the constraint is OK even if ONLY_IN_LINE is non-nil). */
|
73040724e653
(Fconstrain_to_field): Fix the conditions for deciding when to constrain
Miles Bader <miles@gnu.org>
diff
changeset
|
724 && (NILP (only_in_line)
|
73040724e653
(Fconstrain_to_field): Fix the conditions for deciding when to constrain
Miles Bader <miles@gnu.org>
diff
changeset
|
725 /* This is the ONLY_IN_LINE case, check that NEW_POS and
|
73040724e653
(Fconstrain_to_field): Fix the conditions for deciding when to constrain
Miles Bader <miles@gnu.org>
diff
changeset
|
726 FIELD_BOUND are on the same line by seeing whether
|
73040724e653
(Fconstrain_to_field): Fix the conditions for deciding when to constrain
Miles Bader <miles@gnu.org>
diff
changeset
|
727 there's an intervening newline or not. */
|
73040724e653
(Fconstrain_to_field): Fix the conditions for deciding when to constrain
Miles Bader <miles@gnu.org>
diff
changeset
|
728 || (scan_buffer ('\n',
|
73040724e653
(Fconstrain_to_field): Fix the conditions for deciding when to constrain
Miles Bader <miles@gnu.org>
diff
changeset
|
729 XFASTINT (new_pos), XFASTINT (field_bound),
|
73040724e653
(Fconstrain_to_field): Fix the conditions for deciding when to constrain
Miles Bader <miles@gnu.org>
diff
changeset
|
730 fwd ? -1 : 1, &shortage, 1),
|
73040724e653
(Fconstrain_to_field): Fix the conditions for deciding when to constrain
Miles Bader <miles@gnu.org>
diff
changeset
|
731 shortage != 0)))
|
26058
|
732 /* Constrain NEW_POS to FIELD_BOUND. */
|
|
733 new_pos = field_bound;
|
|
734
|
|
735 if (orig_point && XFASTINT (new_pos) != orig_point)
|
|
736 /* The NEW_POS argument was originally nil, so automatically set PT. */
|
|
737 SET_PT (XFASTINT (new_pos));
|
|
738 }
|
|
739
|
|
740 return new_pos;
|
|
741 }
|
31016
|
742
|
26058
|
743
|
40042
c9ad5da1f79d
(Fline_beginning_position, Fline_end_position): Clarify documentation.
Miles Bader <miles@gnu.org>
diff
changeset
|
744 DEFUN ("line-beginning-position",
|
c9ad5da1f79d
(Fline_beginning_position, Fline_end_position): Clarify documentation.
Miles Bader <miles@gnu.org>
diff
changeset
|
745 Fline_beginning_position, Sline_beginning_position, 0, 1, 0,
|
39988
|
746 doc: /* Return the character position of the first character on the current line.
|
39966
|
747 With argument N not nil or 1, move forward N - 1 lines first.
|
|
748 If scan reaches end of buffer, return that position.
|
40042
c9ad5da1f79d
(Fline_beginning_position, Fline_end_position): Clarify documentation.
Miles Bader <miles@gnu.org>
diff
changeset
|
749
|
c9ad5da1f79d
(Fline_beginning_position, Fline_end_position): Clarify documentation.
Miles Bader <miles@gnu.org>
diff
changeset
|
750 The scan does not cross a field boundary unless doing so would move
|
c9ad5da1f79d
(Fline_beginning_position, Fline_end_position): Clarify documentation.
Miles Bader <miles@gnu.org>
diff
changeset
|
751 beyond there to a different line; if N is nil or 1, and scan starts at a
|
c9ad5da1f79d
(Fline_beginning_position, Fline_end_position): Clarify documentation.
Miles Bader <miles@gnu.org>
diff
changeset
|
752 field boundary, the scan stops as soon as it starts. To ignore field
|
c9ad5da1f79d
(Fline_beginning_position, Fline_end_position): Clarify documentation.
Miles Bader <miles@gnu.org>
diff
changeset
|
753 boundaries bind `inhibit-field-text-motion' to t.
|
39966
|
754
|
39988
|
755 This function does not move point. */)
|
|
756 (n)
|
16639
|
757 Lisp_Object n;
|
|
758 {
|
31016
|
759 int orig, orig_byte, end;
|
305
|
760
|
16639
|
761 if (NILP (n))
|
|
762 XSETFASTINT (n, 1);
|
|
763 else
|
40656
|
764 CHECK_NUMBER (n);
|
16639
|
765
|
|
766 orig = PT;
|
20558
|
767 orig_byte = PT_BYTE;
|
16639
|
768 Fforward_line (make_number (XINT (n) - 1));
|
|
769 end = PT;
|
25647
|
770
|
20558
|
771 SET_PT_BOTH (orig, orig_byte);
|
16639
|
772
|
26058
|
773 /* Return END constrained to the current input field. */
|
27081
|
774 return Fconstrain_to_field (make_number (end), make_number (orig),
|
|
775 XINT (n) != 1 ? Qt : Qnil,
|
30439
|
776 Qt, Qnil);
|
16639
|
777 }
|
|
778
|
40042
c9ad5da1f79d
(Fline_beginning_position, Fline_end_position): Clarify documentation.
Miles Bader <miles@gnu.org>
diff
changeset
|
779 DEFUN ("line-end-position", Fline_end_position, Sline_end_position, 0, 1, 0,
|
39988
|
780 doc: /* Return the character position of the last character on the current line.
|
39966
|
781 With argument N not nil or 1, move forward N - 1 lines first.
|
|
782 If scan reaches end of buffer, return that position.
|
40042
c9ad5da1f79d
(Fline_beginning_position, Fline_end_position): Clarify documentation.
Miles Bader <miles@gnu.org>
diff
changeset
|
783
|
c9ad5da1f79d
(Fline_beginning_position, Fline_end_position): Clarify documentation.
Miles Bader <miles@gnu.org>
diff
changeset
|
784 The scan does not cross a field boundary unless doing so would move
|
c9ad5da1f79d
(Fline_beginning_position, Fline_end_position): Clarify documentation.
Miles Bader <miles@gnu.org>
diff
changeset
|
785 beyond there to a different line; if N is nil or 1, and scan starts at a
|
c9ad5da1f79d
(Fline_beginning_position, Fline_end_position): Clarify documentation.
Miles Bader <miles@gnu.org>
diff
changeset
|
786 field boundary, the scan stops as soon as it starts. To ignore field
|
c9ad5da1f79d
(Fline_beginning_position, Fline_end_position): Clarify documentation.
Miles Bader <miles@gnu.org>
diff
changeset
|
787 boundaries bind `inhibit-field-text-motion' to t.
|
c9ad5da1f79d
(Fline_beginning_position, Fline_end_position): Clarify documentation.
Miles Bader <miles@gnu.org>
diff
changeset
|
788
|
39988
|
789 This function does not move point. */)
|
|
790 (n)
|
16639
|
791 Lisp_Object n;
|
|
792 {
|
26058
|
793 int end_pos;
|
31016
|
794 int orig = PT;
|
26058
|
795
|
16639
|
796 if (NILP (n))
|
|
797 XSETFASTINT (n, 1);
|
|
798 else
|
40656
|
799 CHECK_NUMBER (n);
|
16639
|
800
|
26058
|
801 end_pos = find_before_next_newline (orig, 0, XINT (n) - (XINT (n) <= 0));
|
|
802
|
|
803 /* Return END_POS constrained to the current input field. */
|
27081
|
804 return Fconstrain_to_field (make_number (end_pos), make_number (orig),
|
30439
|
805 Qnil, Qt, Qnil);
|
16639
|
806 }
|
40042
c9ad5da1f79d
(Fline_beginning_position, Fline_end_position): Clarify documentation.
Miles Bader <miles@gnu.org>
diff
changeset
|
807
|
16639
|
808
|
305
|
809 Lisp_Object
|
|
810 save_excursion_save ()
|
|
811 {
|
31016
|
812 int visible = (XBUFFER (XWINDOW (selected_window)->buffer)
|
|
813 == current_buffer);
|
305
|
814
|
|
815 return Fcons (Fpoint_marker (),
|
12982
|
816 Fcons (Fcopy_marker (current_buffer->mark, Qnil),
|
2049
|
817 Fcons (visible ? Qt : Qnil,
|
32420
|
818 Fcons (current_buffer->mark_active,
|
|
819 selected_window))));
|
305
|
820 }
|
|
821
|
|
822 Lisp_Object
|
|
823 save_excursion_restore (info)
|
15075
|
824 Lisp_Object info;
|
305
|
825 {
|
15075
|
826 Lisp_Object tem, tem1, omark, nmark;
|
|
827 struct gcpro gcpro1, gcpro2, gcpro3;
|
32420
|
828 int visible_p;
|
|
829
|
|
830 tem = Fmarker_buffer (XCAR (info));
|
305
|
831 /* If buffer being returned to is now deleted, avoid error */
|
|
832 /* Otherwise could get error here while unwinding to top level
|
|
833 and crash */
|
|
834 /* In that case, Fmarker_buffer returns nil now. */
|
488
|
835 if (NILP (tem))
|
305
|
836 return Qnil;
|
15075
|
837
|
|
838 omark = nmark = Qnil;
|
|
839 GCPRO3 (info, omark, nmark);
|
|
840
|
305
|
841 Fset_buffer (tem);
|
32420
|
842
|
|
843 /* Point marker. */
|
|
844 tem = XCAR (info);
|
305
|
845 Fgoto_char (tem);
|
|
846 unchain_marker (tem);
|
32420
|
847
|
|
848 /* Mark marker. */
|
|
849 info = XCDR (info);
|
|
850 tem = XCAR (info);
|
7485
|
851 omark = Fmarker_position (current_buffer->mark);
|
305
|
852 Fset_marker (current_buffer->mark, tem, Fcurrent_buffer ());
|
7485
|
853 nmark = Fmarker_position (tem);
|
305
|
854 unchain_marker (tem);
|
32420
|
855
|
|
856 /* visible */
|
|
857 info = XCDR (info);
|
|
858 visible_p = !NILP (XCAR (info));
|
|
859
|
4420
|
860 #if 0 /* We used to make the current buffer visible in the selected window
|
|
861 if that was true previously. That avoids some anomalies.
|
|
862 But it creates others, and it wasn't documented, and it is simpler
|
|
863 and cleaner never to alter the window/buffer connections. */
|
2049
|
864 tem1 = Fcar (tem);
|
|
865 if (!NILP (tem1)
|
1254
|
866 && current_buffer != XBUFFER (XWINDOW (selected_window)->buffer))
|
305
|
867 Fswitch_to_buffer (Fcurrent_buffer (), Qnil);
|
4420
|
868 #endif /* 0 */
|
2049
|
869
|
32420
|
870 /* Mark active */
|
|
871 info = XCDR (info);
|
|
872 tem = XCAR (info);
|
2049
|
873 tem1 = current_buffer->mark_active;
|
32420
|
874 current_buffer->mark_active = tem;
|
|
875
|
6206
|
876 if (!NILP (Vrun_hooks))
|
|
877 {
|
7485
|
878 /* If mark is active now, and either was not active
|
|
879 or was at a different place, run the activate hook. */
|
6206
|
880 if (! NILP (current_buffer->mark_active))
|
7485
|
881 {
|
|
882 if (! EQ (omark, nmark))
|
|
883 call1 (Vrun_hooks, intern ("activate-mark-hook"));
|
|
884 }
|
|
885 /* If mark has ceased to be active, run deactivate hook. */
|
6206
|
886 else if (! NILP (tem1))
|
|
887 call1 (Vrun_hooks, intern ("deactivate-mark-hook"));
|
|
888 }
|
32420
|
889
|
|
890 /* If buffer was visible in a window, and a different window was
|
34165
|
891 selected, and the old selected window is still showing this
|
|
892 buffer, restore point in that window. */
|
32420
|
893 tem = XCDR (info);
|
|
894 if (visible_p
|
|
895 && !EQ (tem, selected_window)
|
37492
|
896 && (tem1 = XWINDOW (tem)->buffer,
|
|
897 (/* Window is live... */
|
|
898 BUFFERP (tem1)
|
|
899 /* ...and it shows the current buffer. */
|
|
900 && XBUFFER (tem1) == current_buffer)))
|
32420
|
901 Fset_window_point (tem, make_number (PT));
|
|
902
|
15075
|
903 UNGCPRO;
|
305
|
904 return Qnil;
|
|
905 }
|
|
906
|
|
907 DEFUN ("save-excursion", Fsave_excursion, Ssave_excursion, 0, UNEVALLED, 0,
|
39988
|
908 doc: /* Save point, mark, and current buffer; execute BODY; restore those things.
|
39966
|
909 Executes BODY just like `progn'.
|
|
910 The values of point, mark and the current buffer are restored
|
|
911 even in case of abnormal exit (throw or error).
|
|
912 The state of activation of the mark is also restored.
|
|
913
|
|
914 This construct does not save `deactivate-mark', and therefore
|
|
915 functions that change the buffer will still cause deactivation
|
|
916 of the mark at the end of the command. To prevent that, bind
|
40140
|
917 `deactivate-mark' with `let'.
|
|
918
|
|
919 usage: (save-excursion &rest BODY) */)
|
39988
|
920 (args)
|
305
|
921 Lisp_Object args;
|
|
922 {
|
|
923 register Lisp_Object val;
|
|
924 int count = specpdl_ptr - specpdl;
|
|
925
|
|
926 record_unwind_protect (save_excursion_restore, save_excursion_save ());
|
16298
|
927
|
|
928 val = Fprogn (args);
|
|
929 return unbind_to (count, val);
|
|
930 }
|
|
931
|
|
932 DEFUN ("save-current-buffer", Fsave_current_buffer, Ssave_current_buffer, 0, UNEVALLED, 0,
|
39988
|
933 doc: /* Save the current buffer; execute BODY; restore the current buffer.
|
40140
|
934 Executes BODY just like `progn'.
|
|
935 usage: (save-current-buffer &rest BODY) */)
|
39988
|
936 (args)
|
16298
|
937 Lisp_Object args;
|
|
938 {
|
31016
|
939 Lisp_Object val;
|
16298
|
940 int count = specpdl_ptr - specpdl;
|
|
941
|
20696
|
942 record_unwind_protect (set_buffer_if_live, Fcurrent_buffer ());
|
16298
|
943
|
305
|
944 val = Fprogn (args);
|
|
945 return unbind_to (count, val);
|
|
946 }
|
|
947
|
25608
|
948 DEFUN ("buffer-size", Fbufsize, Sbufsize, 0, 1, 0,
|
39988
|
949 doc: /* Return the number of characters in the current buffer.
|
|
950 If BUFFER, return the number of characters in that buffer instead. */)
|
|
951 (buffer)
|
25608
|
952 Lisp_Object buffer;
|
305
|
953 {
|
25608
|
954 if (NILP (buffer))
|
|
955 return make_number (Z - BEG);
|
25609
|
956 else
|
|
957 {
|
40656
|
958 CHECK_BUFFER (buffer);
|
25609
|
959 return make_number (BUF_Z (XBUFFER (buffer))
|
|
960 - BUF_BEG (XBUFFER (buffer)));
|
|
961 }
|
305
|
962 }
|
|
963
|
|
964 DEFUN ("point-min", Fpoint_min, Spoint_min, 0, 0, 0,
|
39988
|
965 doc: /* Return the minimum permissible value of point in the current buffer.
|
|
966 This is 1, unless narrowing (a buffer restriction) is in effect. */)
|
|
967 ()
|
305
|
968 {
|
|
969 Lisp_Object temp;
|
9305
ac077e2a75f1
(Fstring_to_char, Fpoint, Fbufsize, Fpoint_min, Fpoint_max, Ffollowing_char,
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
970 XSETFASTINT (temp, BEGV);
|
305
|
971 return temp;
|
|
972 }
|
|
973
|
|
974 DEFUN ("point-min-marker", Fpoint_min_marker, Spoint_min_marker, 0, 0, 0,
|
39988
|
975 doc: /* Return a marker to the minimum permissible value of point in this buffer.
|
|
976 This is the beginning, unless narrowing (a buffer restriction) is in effect. */)
|
|
977 ()
|
305
|
978 {
|
20558
|
979 return buildmark (BEGV, BEGV_BYTE);
|
305
|
980 }
|
|
981
|
|
982 DEFUN ("point-max", Fpoint_max, Spoint_max, 0, 0, 0,
|
39988
|
983 doc: /* Return the maximum permissible value of point in the current buffer.
|
39966
|
984 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
|
39988
|
985 is in effect, in which case it is less. */)
|
|
986 ()
|
305
|
987 {
|
|
988 Lisp_Object temp;
|
9305
ac077e2a75f1
(Fstring_to_char, Fpoint, Fbufsize, Fpoint_min, Fpoint_max, Ffollowing_char,
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
989 XSETFASTINT (temp, ZV);
|
305
|
990 return temp;
|
|
991 }
|
|
992
|
|
993 DEFUN ("point-max-marker", Fpoint_max_marker, Spoint_max_marker, 0, 0, 0,
|
39988
|
994 doc: /* Return a marker to the maximum permissible value of point in this buffer.
|
39966
|
995 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
|
39988
|
996 is in effect, in which case it is less. */)
|
|
997 ()
|
305
|
998 {
|
20558
|
999 return buildmark (ZV, ZV_BYTE);
|
305
|
1000 }
|
|
1001
|
21821
|
1002 DEFUN ("gap-position", Fgap_position, Sgap_position, 0, 0, 0,
|
39988
|
1003 doc: /* Return the position of the gap, in the current buffer.
|
|
1004 See also `gap-size'. */)
|
|
1005 ()
|
21821
|
1006 {
|
|
1007 Lisp_Object temp;
|
|
1008 XSETFASTINT (temp, GPT);
|
|
1009 return temp;
|
|
1010 }
|
|
1011
|
|
1012 DEFUN ("gap-size", Fgap_size, Sgap_size, 0, 0, 0,
|
39988
|
1013 doc: /* Return the size of the current buffer's gap.
|
|
1014 See also `gap-position'. */)
|
|
1015 ()
|
21821
|
1016 {
|
|
1017 Lisp_Object temp;
|
|
1018 XSETFASTINT (temp, GAP_SIZE);
|
|
1019 return temp;
|
|
1020 }
|
|
1021
|
20861
|
1022 DEFUN ("position-bytes", Fposition_bytes, Sposition_bytes, 1, 1, 0,
|
39988
|
1023 doc: /* Return the byte position for character position POSITION.
|
|
1024 If POSITION is out of range, the value is nil. */)
|
|
1025 (position)
|
20879
|
1026 Lisp_Object position;
|
20861
|
1027 {
|
40656
|
1028 CHECK_NUMBER_COERCE_MARKER (position);
|
23132
|
1029 if (XINT (position) < BEG || XINT (position) > Z)
|
|
1030 return Qnil;
|
20878
|
1031 return make_number (CHAR_TO_BYTE (XINT (position)));
|
20861
|
1032 }
|
22645
|
1033
|
|
1034 DEFUN ("byte-to-position", Fbyte_to_position, Sbyte_to_position, 1, 1, 0,
|
39988
|
1035 doc: /* Return the character position for byte position BYTEPOS.
|
|
1036 If BYTEPOS is out of range, the value is nil. */)
|
|
1037 (bytepos)
|
22645
|
1038 Lisp_Object bytepos;
|
|
1039 {
|
40656
|
1040 CHECK_NUMBER (bytepos);
|
23132
|
1041 if (XINT (bytepos) < BEG_BYTE || XINT (bytepos) > Z_BYTE)
|
|
1042 return Qnil;
|
22645
|
1043 return make_number (BYTE_TO_CHAR (XINT (bytepos)));
|
|
1044 }
|
20861
|
1045
|
512
|
1046 DEFUN ("following-char", Ffollowing_char, Sfollowing_char, 0, 0, 0,
|
39988
|
1047 doc: /* Return the character following point, as a number.
|
|
1048 At the end of the buffer or accessible region, return 0. */)
|
|
1049 ()
|
305
|
1050 {
|
|
1051 Lisp_Object temp;
|
16039
|
1052 if (PT >= ZV)
|
9305
ac077e2a75f1
(Fstring_to_char, Fpoint, Fbufsize, Fpoint_min, Fpoint_max, Ffollowing_char,
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
1053 XSETFASTINT (temp, 0);
|
512
|
1054 else
|
20558
|
1055 XSETFASTINT (temp, FETCH_CHAR (PT_BYTE));
|
305
|
1056 return temp;
|
|
1057 }
|
|
1058
|
512
|
1059 DEFUN ("preceding-char", Fprevious_char, Sprevious_char, 0, 0, 0,
|
39988
|
1060 doc: /* Return the character preceding point, as a number.
|
|
1061 At the beginning of the buffer or accessible region, return 0. */)
|
|
1062 ()
|
305
|
1063 {
|
|
1064 Lisp_Object temp;
|
16039
|
1065 if (PT <= BEGV)
|
9305
ac077e2a75f1
(Fstring_to_char, Fpoint, Fbufsize, Fpoint_min, Fpoint_max, Ffollowing_char,
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
1066 XSETFASTINT (temp, 0);
|
17031
|
1067 else if (!NILP (current_buffer->enable_multibyte_characters))
|
|
1068 {
|
20558
|
1069 int pos = PT_BYTE;
|
17031
|
1070 DEC_POS (pos);
|
|
1071 XSETFASTINT (temp, FETCH_CHAR (pos));
|
|
1072 }
|
305
|
1073 else
|
20558
|
1074 XSETFASTINT (temp, FETCH_BYTE (PT_BYTE - 1));
|
305
|
1075 return temp;
|
|
1076 }
|
|
1077
|
|
1078 DEFUN ("bobp", Fbobp, Sbobp, 0, 0, 0,
|
39988
|
1079 doc: /* Return t if point is at the beginning of the buffer.
|
|
1080 If the buffer is narrowed, this means the beginning of the narrowed part. */)
|
|
1081 ()
|
305
|
1082 {
|
16039
|
1083 if (PT == BEGV)
|
305
|
1084 return Qt;
|
|
1085 return Qnil;
|
|
1086 }
|
|
1087
|
|
1088 DEFUN ("eobp", Feobp, Seobp, 0, 0, 0,
|
39988
|
1089 doc: /* Return t if point is at the end of the buffer.
|
|
1090 If the buffer is narrowed, this means the end of the narrowed part. */)
|
|
1091 ()
|
305
|
1092 {
|
16039
|
1093 if (PT == ZV)
|
305
|
1094 return Qt;
|
|
1095 return Qnil;
|
|
1096 }
|
|
1097
|
|
1098 DEFUN ("bolp", Fbolp, Sbolp, 0, 0, 0,
|
39988
|
1099 doc: /* Return t if point is at the beginning of a line. */)
|
|
1100 ()
|
305
|
1101 {
|
20558
|
1102 if (PT == BEGV || FETCH_BYTE (PT_BYTE - 1) == '\n')
|
305
|
1103 return Qt;
|
|
1104 return Qnil;
|
|
1105 }
|
|
1106
|
|
1107 DEFUN ("eolp", Feolp, Seolp, 0, 0, 0,
|
39988
|
1108 doc: /* Return t if point is at the end of a line.
|
|
1109 `End of a line' includes point being at the end of the buffer. */)
|
|
1110 ()
|
305
|
1111 {
|
20558
|
1112 if (PT == ZV || FETCH_BYTE (PT_BYTE) == '\n')
|
305
|
1113 return Qt;
|
|
1114 return Qnil;
|
|
1115 }
|
|
1116
|
18252
|
1117 DEFUN ("char-after", Fchar_after, Schar_after, 0, 1, 0,
|
39988
|
1118 doc: /* Return character in current buffer at position POS.
|
39966
|
1119 POS is an integer or a marker.
|
39988
|
1120 If POS is out of range, the value is nil. */)
|
|
1121 (pos)
|
305
|
1122 Lisp_Object pos;
|
|
1123 {
|
20558
|
1124 register int pos_byte;
|
305
|
1125
|
18252
|
1126 if (NILP (pos))
|
22199
|
1127 {
|
|
1128 pos_byte = PT_BYTE;
|
23577
|
1129 XSETFASTINT (pos, PT);
|
22199
|
1130 }
|
|
1131
|
|
1132 if (MARKERP (pos))
|
21200
|
1133 {
|
|
1134 pos_byte = marker_byte_position (pos);
|
|
1135 if (pos_byte < BEGV_BYTE || pos_byte >= ZV_BYTE)
|
|
1136 return Qnil;
|
|
1137 }
|
18252
|
1138 else
|
|
1139 {
|
40656
|
1140 CHECK_NUMBER_COERCE_MARKER (pos);
|
21521
|
1141 if (XINT (pos) < BEGV || XINT (pos) >= ZV)
|
21200
|
1142 return Qnil;
|
30480
|
1143
|
20558
|
1144 pos_byte = CHAR_TO_BYTE (XINT (pos));
|
18252
|
1145 }
|
305
|
1146
|
20558
|
1147 return make_number (FETCH_CHAR (pos_byte));
|
305
|
1148 }
|
17031
|
1149
|
18252
|
1150 DEFUN ("char-before", Fchar_before, Schar_before, 0, 1, 0,
|
39988
|
1151 doc: /* Return character in current buffer preceding position POS.
|
39966
|
1152 POS is an integer or a marker.
|
39988
|
1153 If POS is out of range, the value is nil. */)
|
|
1154 (pos)
|
17031
|
1155 Lisp_Object pos;
|
|
1156 {
|
|
1157 register Lisp_Object val;
|
20558
|
1158 register int pos_byte;
|
17031
|
1159
|
18252
|
1160 if (NILP (pos))
|
22199
|
1161 {
|
|
1162 pos_byte = PT_BYTE;
|
23577
|
1163 XSETFASTINT (pos, PT);
|
22199
|
1164 }
|
|
1165
|
|
1166 if (MARKERP (pos))
|
21200
|
1167 {
|
|
1168 pos_byte = marker_byte_position (pos);
|
|
1169
|
|
1170 if (pos_byte <= BEGV_BYTE || pos_byte > ZV_BYTE)
|
|
1171 return Qnil;
|
|
1172 }
|
18252
|
1173 else
|
|
1174 {
|
40656
|
1175 CHECK_NUMBER_COERCE_MARKER (pos);
|
17031
|
1176
|
21521
|
1177 if (XINT (pos) <= BEGV || XINT (pos) > ZV)
|
21200
|
1178 return Qnil;
|
|
1179
|
20558
|
1180 pos_byte = CHAR_TO_BYTE (XINT (pos));
|
18252
|
1181 }
|
17031
|
1182
|
|
1183 if (!NILP (current_buffer->enable_multibyte_characters))
|
|
1184 {
|
20558
|
1185 DEC_POS (pos_byte);
|
|
1186 XSETFASTINT (val, FETCH_CHAR (pos_byte));
|
17031
|
1187 }
|
|
1188 else
|
|
1189 {
|
20558
|
1190 pos_byte--;
|
|
1191 XSETFASTINT (val, FETCH_BYTE (pos_byte));
|
17031
|
1192 }
|
|
1193 return val;
|
|
1194 }
|
305
|
1195
|
9572
|
1196 DEFUN ("user-login-name", Fuser_login_name, Suser_login_name, 0, 1, 0,
|
39988
|
1197 doc: /* Return the name under which the user logged in, as a string.
|
39966
|
1198 This is based on the effective uid, not the real uid.
|
|
1199 Also, if the environment variable LOGNAME or USER is set,
|
|
1200 that determines the value of this function.
|
|
1201
|
|
1202 If optional argument UID is an integer, return the login name of the user
|
39988
|
1203 with that uid, or nil if there is no such user. */)
|
|
1204 (uid)
|
9572
|
1205 Lisp_Object uid;
|
305
|
1206 {
|
9572
|
1207 struct passwd *pw;
|
|
1208
|
9520
|
1209 /* Set up the user name info if we didn't do it before.
|
|
1210 (That can happen if Emacs is dumpable
|
|
1211 but you decide to run `temacs -l loadup' and not dump. */
|
12026
|
1212 if (INTEGERP (Vuser_login_name))
|
9520
|
1213 init_editfns ();
|
9572
|
1214
|
|
1215 if (NILP (uid))
|
12026
|
1216 return Vuser_login_name;
|
9572
|
1217
|
40656
|
1218 CHECK_NUMBER (uid);
|
9572
|
1219 pw = (struct passwd *) getpwuid (XINT (uid));
|
|
1220 return (pw ? build_string (pw->pw_name) : Qnil);
|
305
|
1221 }
|
|
1222
|
|
1223 DEFUN ("user-real-login-name", Fuser_real_login_name, Suser_real_login_name,
|
40981
|
1224 0, 0, 0,
|
39988
|
1225 doc: /* Return the name of the user's real uid, as a string.
|
39966
|
1226 This ignores the environment variables LOGNAME and USER, so it differs from
|
39988
|
1227 `user-login-name' when running under `su'. */)
|
|
1228 ()
|
305
|
1229 {
|
9520
|
1230 /* Set up the user name info if we didn't do it before.
|
|
1231 (That can happen if Emacs is dumpable
|
|
1232 but you decide to run `temacs -l loadup' and not dump. */
|
12026
|
1233 if (INTEGERP (Vuser_login_name))
|
9520
|
1234 init_editfns ();
|
12026
|
1235 return Vuser_real_login_name;
|
305
|
1236 }
|
|
1237
|
|
1238 DEFUN ("user-uid", Fuser_uid, Suser_uid, 0, 0, 0,
|
39988
|
1239 doc: /* Return the effective uid of Emacs.
|
|
1240 Value is an integer or float, depending on the value. */)
|
|
1241 ()
|
305
|
1242 {
|
39774
|
1243 return make_fixnum_or_float (geteuid ());
|
305
|
1244 }
|
|
1245
|
|
1246 DEFUN ("user-real-uid", Fuser_real_uid, Suser_real_uid, 0, 0, 0,
|
39988
|
1247 doc: /* Return the real uid of Emacs.
|
|
1248 Value is an integer or float, depending on the value. */)
|
|
1249 ()
|
305
|
1250 {
|
39774
|
1251 return make_fixnum_or_float (getuid ());
|
305
|
1252 }
|
|
1253
|
16639
|
1254 DEFUN ("user-full-name", Fuser_full_name, Suser_full_name, 0, 1, 0,
|
39988
|
1255 doc: /* Return the full name of the user logged in, as a string.
|
39966
|
1256 If the full name corresponding to Emacs's userid is not known,
|
|
1257 return "unknown".
|
|
1258
|
|
1259 If optional argument UID is an integer or float, return the full name
|
|
1260 of the user with that uid, or nil if there is no such user.
|
|
1261 If UID is a string, return the full name of the user with that login
|
39988
|
1262 name, or nil if there is no such user. */)
|
|
1263 (uid)
|
16639
|
1264 Lisp_Object uid;
|
305
|
1265 {
|
16639
|
1266 struct passwd *pw;
|
18661
|
1267 register unsigned char *p, *q;
|
16641
|
1268 Lisp_Object full;
|
16639
|
1269
|
|
1270 if (NILP (uid))
|
30480
|
1271 return Vuser_full_name;
|
16641
|
1272 else if (NUMBERP (uid))
|
39774
|
1273 pw = (struct passwd *) getpwuid ((uid_t) XFLOATINT (uid));
|
30480
|
1274 else if (STRINGP (uid))
|
16641
|
1275 pw = (struct passwd *) getpwnam (XSTRING (uid)->data);
|
|
1276 else
|
|
1277 error ("Invalid UID specification");
|
16639
|
1278
|
16641
|
1279 if (!pw)
|
16683
6802dbd07a80
(Fuser_full_name): Return nil if the specified user doesn't exist.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
1280 return Qnil;
|
30480
|
1281
|
16641
|
1282 p = (unsigned char *) USER_FULL_NAME;
|
|
1283 /* Chop off everything after the first comma. */
|
|
1284 q = (unsigned char *) index (p, ',');
|
|
1285 full = make_string (p, q ? q - p : strlen (p));
|
30480
|
1286
|
16641
|
1287 #ifdef AMPERSAND_FULL_NAME
|
|
1288 p = XSTRING (full)->data;
|
|
1289 q = (unsigned char *) index (p, '&');
|
|
1290 /* Substitute the login name for the &, upcasing the first character. */
|
|
1291 if (q)
|
|
1292 {
|
18661
|
1293 register unsigned char *r;
|
16641
|
1294 Lisp_Object login;
|
|
1295
|
|
1296 login = Fuser_login_name (make_number (pw->pw_uid));
|
|
1297 r = (unsigned char *) alloca (strlen (p) + XSTRING (login)->size + 1);
|
|
1298 bcopy (p, r, q - p);
|
|
1299 r[q - p] = 0;
|
|
1300 strcat (r, XSTRING (login)->data);
|
|
1301 r[q - p] = UPCASE (r[q - p]);
|
|
1302 strcat (r, q + 1);
|
|
1303 full = build_string (r);
|
|
1304 }
|
|
1305 #endif /* AMPERSAND_FULL_NAME */
|
|
1306
|
|
1307 return full;
|
305
|
1308 }
|
|
1309
|
|
1310 DEFUN ("system-name", Fsystem_name, Ssystem_name, 0, 0, 0,
|
39988
|
1311 doc: /* Return the name of the machine you are running on, as a string. */)
|
|
1312 ()
|
305
|
1313 {
|
|
1314 return Vsystem_name;
|
|
1315 }
|
|
1316
|
7907
|
1317 /* For the benefit of callers who don't want to include lisp.h */
|
31016
|
1318
|
7907
|
1319 char *
|
|
1320 get_system_name ()
|
|
1321 {
|
18756
751f531e5a20
(get_system_name): Don't crash if Vsystem_name does not contain a string.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
1322 if (STRINGP (Vsystem_name))
|
751f531e5a20
(get_system_name): Don't crash if Vsystem_name does not contain a string.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
1323 return (char *) XSTRING (Vsystem_name)->data;
|
751f531e5a20
(get_system_name): Don't crash if Vsystem_name does not contain a string.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
1324 else
|
751f531e5a20
(get_system_name): Don't crash if Vsystem_name does not contain a string.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
1325 return "";
|
7907
|
1326 }
|
|
1327
|
5373
|
1328 DEFUN ("emacs-pid", Femacs_pid, Semacs_pid, 0, 0, 0,
|
39988
|
1329 doc: /* Return the process ID of Emacs, as an integer. */)
|
|
1330 ()
|
5373
|
1331 {
|
|
1332 return make_number (getpid ());
|
|
1333 }
|
|
1334
|
448
|
1335 DEFUN ("current-time", Fcurrent_time, Scurrent_time, 0, 0, 0,
|
39988
|
1336 doc: /* Return the current time, as the number of seconds since 1970-01-01 00:00:00.
|
39966
|
1337 The time is returned as a list of three integers. The first has the
|
|
1338 most significant 16 bits of the seconds, while the second has the
|
|
1339 least significant 16 bits. The third integer gives the microsecond
|
|
1340 count.
|
|
1341
|
|
1342 The microsecond count is zero on systems that do not provide
|
39988
|
1343 resolution finer than a second. */)
|
|
1344 ()
|
448
|
1345 {
|
577
|
1346 EMACS_TIME t;
|
|
1347 Lisp_Object result[3];
|
|
1348
|
|
1349 EMACS_GET_TIME (t);
|
9265
e44908d7323b
(Fcurrent_time, Fformat): Use new accessor macros instead of calling XSET
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
1350 XSETINT (result[0], (EMACS_SECS (t) >> 16) & 0xffff);
|
e44908d7323b
(Fcurrent_time, Fformat): Use new accessor macros instead of calling XSET
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
1351 XSETINT (result[1], (EMACS_SECS (t) >> 0) & 0xffff);
|
e44908d7323b
(Fcurrent_time, Fformat): Use new accessor macros instead of calling XSET
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
1352 XSETINT (result[2], EMACS_USECS (t));
|
577
|
1353
|
|
1354 return Flist (3, result);
|
448
|
1355 }
|
|
1356
|
|
1357
|
2921
|
1358 static int
|
30480
|
1359 lisp_time_argument (specified_time, result, usec)
|
2921
|
1360 Lisp_Object specified_time;
|
|
1361 time_t *result;
|
30480
|
1362 int *usec;
|
2921
|
1363 {
|
|
1364 if (NILP (specified_time))
|
30480
|
1365 {
|
|
1366 if (usec)
|
|
1367 {
|
|
1368 EMACS_TIME t;
|
|
1369
|
30503
|
1370 EMACS_GET_TIME (t);
|
30480
|
1371 *usec = EMACS_USECS (t);
|
|
1372 *result = EMACS_SECS (t);
|
|
1373 return 1;
|
|
1374 }
|
|
1375 else
|
|
1376 return time (result) != -1;
|
|
1377 }
|
2921
|
1378 else
|
|
1379 {
|
|
1380 Lisp_Object high, low;
|
|
1381 high = Fcar (specified_time);
|
40656
|
1382 CHECK_NUMBER (high);
|
2921
|
1383 low = Fcdr (specified_time);
|
9163
41fe5f636879
(lisp_time_argument, Finsert, Finsert_and_inherit, Finsert_before_markers,
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
1384 if (CONSP (low))
|
30480
|
1385 {
|
|
1386 if (usec)
|
|
1387 {
|
|
1388 Lisp_Object usec_l = Fcdr (low);
|
|
1389 if (CONSP (usec_l))
|
|
1390 usec_l = Fcar (usec_l);
|
|
1391 if (NILP (usec_l))
|
|
1392 *usec = 0;
|
|
1393 else
|
|
1394 {
|
40656
|
1395 CHECK_NUMBER (usec_l);
|
30480
|
1396 *usec = XINT (usec_l);
|
|
1397 }
|
|
1398 }
|
|
1399 low = Fcar (low);
|
|
1400 }
|
|
1401 else if (usec)
|
|
1402 *usec = 0;
|
40656
|
1403 CHECK_NUMBER (low);
|
2921
|
1404 *result = (XINT (high) << 16) + (XINT (low) & 0xffff);
|
|
1405 return *result >> 16 == XINT (high);
|
|
1406 }
|
|
1407 }
|
|
1408
|
30480
|
1409 DEFUN ("float-time", Ffloat_time, Sfloat_time, 0, 1, 0,
|
39988
|
1410 doc: /* Return the current time, as a float number of seconds since the epoch.
|
39966
|
1411 If an argument is given, it specifies a time to convert to float
|
|
1412 instead of the current time. The argument should have the forms:
|
|
1413 (HIGH . LOW) or (HIGH LOW USEC) or (HIGH LOW . USEC).
|
|
1414 Thus, you can use times obtained from `current-time'
|
|
1415 and from `file-attributes'.
|
|
1416
|
|
1417 WARNING: Since the result is floating point, it may not be exact.
|
39988
|
1418 Do not use this function if precise time stamps are required. */)
|
|
1419 (specified_time)
|
30480
|
1420 Lisp_Object specified_time;
|
|
1421 {
|
|
1422 time_t sec;
|
|
1423 int usec;
|
|
1424
|
|
1425 if (! lisp_time_argument (specified_time, &sec, &usec))
|
|
1426 error ("Invalid time specification");
|
|
1427
|
37046
|
1428 return make_float ((sec * 1e6 + usec) / 1e6);
|
30480
|
1429 }
|
|
1430
|
23213
|
1431 /* Write information into buffer S of size MAXSIZE, according to the
|
|
1432 FORMAT of length FORMAT_LEN, using time information taken from *TP.
|
26088
b7aa6ac26872
Add support for large files, 64-bit Solaris, system locale codings.
Paul Eggert <eggert@twinsun.com>
diff
changeset
|
1433 Default to Universal Time if UT is nonzero, local time otherwise.
|
23213
|
1434 Return the number of bytes written, not including the terminating
|
|
1435 '\0'. If S is NULL, nothing will be written anywhere; so to
|
|
1436 determine how many bytes would be written, use NULL for S and
|
|
1437 ((size_t) -1) for MAXSIZE.
|
|
1438
|
26088
b7aa6ac26872
Add support for large files, 64-bit Solaris, system locale codings.
Paul Eggert <eggert@twinsun.com>
diff
changeset
|
1439 This function behaves like emacs_strftimeu, except it allows null
|
23213
|
1440 bytes in FORMAT. */
|
|
1441 static size_t
|
26088
b7aa6ac26872
Add support for large files, 64-bit Solaris, system locale codings.
Paul Eggert <eggert@twinsun.com>
diff
changeset
|
1442 emacs_memftimeu (s, maxsize, format, format_len, tp, ut)
|
23213
|
1443 char *s;
|
|
1444 size_t maxsize;
|
|
1445 const char *format;
|
|
1446 size_t format_len;
|
|
1447 const struct tm *tp;
|
26088
b7aa6ac26872
Add support for large files, 64-bit Solaris, system locale codings.
Paul Eggert <eggert@twinsun.com>
diff
changeset
|
1448 int ut;
|
23213
|
1449 {
|
|
1450 size_t total = 0;
|
|
1451
|
23218
90e5d916ebd9
Add a comment to emacs_memftime, explaining why it needs to loop.
Paul Eggert <eggert@twinsun.com>
diff
changeset
|
1452 /* Loop through all the null-terminated strings in the format
|
90e5d916ebd9
Add a comment to emacs_memftime, explaining why it needs to loop.
Paul Eggert <eggert@twinsun.com>
diff
changeset
|
1453 argument. Normally there's just one null-terminated string, but
|
90e5d916ebd9
Add a comment to emacs_memftime, explaining why it needs to loop.
Paul Eggert <eggert@twinsun.com>
diff
changeset
|
1454 there can be arbitrarily many, concatenated together, if the
|
26088
b7aa6ac26872
Add support for large files, 64-bit Solaris, system locale codings.
Paul Eggert <eggert@twinsun.com>
diff
changeset
|
1455 format contains '\0' bytes. emacs_strftimeu stops at the first
|
23218
90e5d916ebd9
Add a comment to emacs_memftime, explaining why it needs to loop.
Paul Eggert <eggert@twinsun.com>
diff
changeset
|
1456 '\0' byte so we must invoke it separately for each such string. */
|
23213
|
1457 for (;;)
|
|
1458 {
|
|
1459 size_t len;
|
|
1460 size_t result;
|
|
1461
|
|
1462 if (s)
|
|
1463 s[0] = '\1';
|
|
1464
|
26088
b7aa6ac26872
Add support for large files, 64-bit Solaris, system locale codings.
Paul Eggert <eggert@twinsun.com>
diff
changeset
|
1465 result = emacs_strftimeu (s, maxsize, format, tp, ut);
|
23213
|
1466
|
|
1467 if (s)
|
|
1468 {
|
|
1469 if (result == 0 && s[0] != '\0')
|
|
1470 return 0;
|
|
1471 s += result + 1;
|
|
1472 }
|
|
1473
|
|
1474 maxsize -= result + 1;
|
|
1475 total += result;
|
|
1476 len = strlen (format);
|
|
1477 if (len == format_len)
|
|
1478 return total;
|
|
1479 total++;
|
|
1480 format += len + 1;
|
|
1481 format_len -= len + 1;
|
|
1482 }
|
|
1483 }
|
|
1484
|
17907
|
1485 DEFUN ("format-time-string", Fformat_time_string, Sformat_time_string, 1, 3, 0,
|
39988
|
1486 doc: /* Use FORMAT-STRING to format the time TIME, or now if omitted.
|
39966
|
1487 TIME is specified as (HIGH LOW . IGNORED) or (HIGH . LOW), as returned by
|
|
1488 `current-time' or `file-attributes'.
|
|
1489 The third, optional, argument UNIVERSAL, if non-nil, means describe TIME
|
|
1490 as Universal Time; nil means describe TIME in the local time zone.
|
|
1491 The value is a copy of FORMAT-STRING, but with certain constructs replaced
|
|
1492 by text that describes the specified date and time in TIME:
|
|
1493
|
|
1494 %Y is the year, %y within the century, %C the century.
|
|
1495 %G is the year corresponding to the ISO week, %g within the century.
|
|
1496 %m is the numeric month.
|
|
1497 %b and %h are the locale's abbreviated month name, %B the full name.
|
|
1498 %d is the day of the month, zero-padded, %e is blank-padded.
|
|
1499 %u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.
|
|
1500 %a is the locale's abbreviated name of the day of week, %A the full name.
|
|
1501 %U is the week number starting on Sunday, %W starting on Monday,
|
|
1502 %V according to ISO 8601.
|
|
1503 %j is the day of the year.
|
|
1504
|
|
1505 %H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H
|
|
1506 only blank-padded, %l is like %I blank-padded.
|
|
1507 %p is the locale's equivalent of either AM or PM.
|
|
1508 %M is the minute.
|
|
1509 %S is the second.
|
|
1510 %Z is the time zone name, %z is the numeric form.
|
|
1511 %s is the number of seconds since 1970-01-01 00:00:00 +0000.
|
|
1512
|
|
1513 %c is the locale's date and time format.
|
|
1514 %x is the locale's "preferred" date format.
|
|
1515 %D is like "%m/%d/%y".
|
|
1516
|
|
1517 %R is like "%H:%M", %T is like "%H:%M:%S", %r is like "%I:%M:%S %p".
|
|
1518 %X is the locale's "preferred" time format.
|
|
1519
|
|
1520 Finally, %n is a newline, %t is a tab, %% is a literal %.
|
|
1521
|
|
1522 Certain flags and modifiers are available with some format controls.
|
|
1523 The flags are `_', `-', `^' and `#'. For certain characters X,
|
|
1524 %_X is like %X, but padded with blanks; %-X is like %X,
|
|
1525 ut without padding. %^X is like %X but with all textual
|
|
1526 characters up-cased; %#X is like %X but with letter-case of
|
|
1527 all textual characters reversed.
|
|
1528 %NX (where N stands for an integer) is like %X,
|
|
1529 but takes up at least N (a number) positions.
|
|
1530 The modifiers are `E' and `O'. For certain characters X,
|
|
1531 %EX is a locale's alternative version of %X;
|
|
1532 %OX is like %X, but uses the locale's number symbols.
|
|
1533
|
39988
|
1534 For example, to produce full ISO 8601 format, use "%Y-%m-%dT%T%z". */)
|
|
1535 (format_string, time, universal)
|
17907
|
1536 Lisp_Object format_string, time, universal;
|
9154
|
1537 {
|
|
1538 time_t value;
|
|
1539 int size;
|
23198
|
1540 struct tm *tm;
|
26088
b7aa6ac26872
Add support for large files, 64-bit Solaris, system locale codings.
Paul Eggert <eggert@twinsun.com>
diff
changeset
|
1541 int ut = ! NILP (universal);
|
9154
|
1542
|
40656
|
1543 CHECK_STRING (format_string);
|
9154
|
1544
|
30480
|
1545 if (! lisp_time_argument (time, &value, NULL))
|
9154
|
1546 error ("Invalid time specification");
|
|
1547
|
26088
b7aa6ac26872
Add support for large files, 64-bit Solaris, system locale codings.
Paul Eggert <eggert@twinsun.com>
diff
changeset
|
1548 format_string = code_convert_string_norecord (format_string,
|
b7aa6ac26872
Add support for large files, 64-bit Solaris, system locale codings.
Paul Eggert <eggert@twinsun.com>
diff
changeset
|
1549 Vlocale_coding_system, 1);
|
b7aa6ac26872
Add support for large files, 64-bit Solaris, system locale codings.
Paul Eggert <eggert@twinsun.com>
diff
changeset
|
1550
|
9154
|
1551 /* This is probably enough. */
|
21245
|
1552 size = STRING_BYTES (XSTRING (format_string)) * 6 + 50;
|
9154
|
1553
|
26088
b7aa6ac26872
Add support for large files, 64-bit Solaris, system locale codings.
Paul Eggert <eggert@twinsun.com>
diff
changeset
|
1554 tm = ut ? gmtime (&value) : localtime (&value);
|
23198
|
1555 if (! tm)
|
|
1556 error ("Specified time is not representable");
|
|
1557
|
26526
|
1558 synchronize_system_time_locale ();
|
26088
b7aa6ac26872
Add support for large files, 64-bit Solaris, system locale codings.
Paul Eggert <eggert@twinsun.com>
diff
changeset
|
1559
|
9154
|
1560 while (1)
|
|
1561 {
|
17907
|
1562 char *buf = (char *) alloca (size + 1);
|
|
1563 int result;
|
|
1564
|
19032
|
1565 buf[0] = '\1';
|
26088
b7aa6ac26872
Add support for large files, 64-bit Solaris, system locale codings.
Paul Eggert <eggert@twinsun.com>
diff
changeset
|
1566 result = emacs_memftimeu (buf, size, XSTRING (format_string)->data,
|
b7aa6ac26872
Add support for large files, 64-bit Solaris, system locale codings.
Paul Eggert <eggert@twinsun.com>
diff
changeset
|
1567 STRING_BYTES (XSTRING (format_string)),
|
b7aa6ac26872
Add support for large files, 64-bit Solaris, system locale codings.
Paul Eggert <eggert@twinsun.com>
diff
changeset
|
1568 tm, ut);
|
19032
|
1569 if ((result > 0 && result < size) || (result == 0 && buf[0] == '\0'))
|
26088
b7aa6ac26872
Add support for large files, 64-bit Solaris, system locale codings.
Paul Eggert <eggert@twinsun.com>
diff
changeset
|
1570 return code_convert_string_norecord (make_string (buf, result),
|
b7aa6ac26872
Add support for large files, 64-bit Solaris, system locale codings.
Paul Eggert <eggert@twinsun.com>
diff
changeset
|
1571 Vlocale_coding_system, 0);
|
17907
|
1572
|
|
1573 /* If buffer was too small, make it bigger and try again. */
|
26088
b7aa6ac26872
Add support for large files, 64-bit Solaris, system locale codings.
Paul Eggert <eggert@twinsun.com>
diff
changeset
|
1574 result = emacs_memftimeu (NULL, (size_t) -1,
|
b7aa6ac26872
Add support for large files, 64-bit Solaris, system locale codings.
Paul Eggert <eggert@twinsun.com>
diff
changeset
|
1575 XSTRING (format_string)->data,
|
b7aa6ac26872
Add support for large files, 64-bit Solaris, system locale codings.
Paul Eggert <eggert@twinsun.com>
diff
changeset
|
1576 STRING_BYTES (XSTRING (format_string)),
|
b7aa6ac26872
Add support for large files, 64-bit Solaris, system locale codings.
Paul Eggert <eggert@twinsun.com>
diff
changeset
|
1577 tm, ut);
|
17907
|
1578 size = result + 1;
|
9154
|
1579 }
|
|
1580 }
|
|
1581
|
9801
|
1582 DEFUN ("decode-time", Fdecode_time, Sdecode_time, 0, 1, 0,
|
39988
|
1583 doc: /* Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST ZONE).
|
39966
|
1584 The optional SPECIFIED-TIME should be a list of (HIGH LOW . IGNORED)
|
|
1585 or (HIGH . LOW), as from `current-time' and `file-attributes', or `nil'
|
|
1586 to use the current time. The list has the following nine members:
|
|
1587 SEC is an integer between 0 and 60; SEC is 60 for a leap second, which
|
|
1588 only some operating systems support. MINUTE is an integer between 0 and 59.
|
|
1589 HOUR is an integer between 0 and 23. DAY is an integer between 1 and 31.
|
|
1590 MONTH is an integer between 1 and 12. YEAR is an integer indicating the
|
|
1591 four-digit year. DOW is the day of week, an integer between 0 and 6, where
|
|
1592 0 is Sunday. DST is t if daylight savings time is effect, otherwise nil.
|
|
1593 ZONE is an integer indicating the number of seconds east of Greenwich.
|
39988
|
1594 (Note that Common Lisp has different meanings for DOW and ZONE.) */)
|
|
1595 (specified_time)
|
9801
|
1596 Lisp_Object specified_time;
|
|
1597 {
|
|
1598 time_t time_spec;
|
9812
|
1599 struct tm save_tm;
|
9801
|
1600 struct tm *decoded_time;
|
|
1601 Lisp_Object list_args[9];
|
30480
|
1602
|
|
1603 if (! lisp_time_argument (specified_time, &time_spec, NULL))
|
9801
|
1604 error ("Invalid time specification");
|
|
1605
|
|
1606 decoded_time = localtime (&time_spec);
|
23198
|
1607 if (! decoded_time)
|
|
1608 error ("Specified time is not representable");
|
9812
|
1609 XSETFASTINT (list_args[0], decoded_time->tm_sec);
|
|
1610 XSETFASTINT (list_args[1], decoded_time->tm_min);
|
|
1611 XSETFASTINT (list_args[2], decoded_time->tm_hour);
|
|
1612 XSETFASTINT (list_args[3], decoded_time->tm_mday);
|
|
1613 XSETFASTINT (list_args[4], decoded_time->tm_mon + 1);
|
15757
|
1614 XSETINT (list_args[5], decoded_time->tm_year + 1900);
|
9812
|
1615 XSETFASTINT (list_args[6], decoded_time->tm_wday);
|
9801
|
1616 list_args[7] = (decoded_time->tm_isdst)? Qt : Qnil;
|
9812
|
1617
|
|
1618 /* Make a copy, in case gmtime modifies the struct. */
|
|
1619 save_tm = *decoded_time;
|
|
1620 decoded_time = gmtime (&time_spec);
|
|
1621 if (decoded_time == 0)
|
|
1622 list_args[8] = Qnil;
|
|
1623 else
|
16269
|
1624 XSETINT (list_args[8], tm_diff (&save_tm, decoded_time));
|
9801
|
1625 return Flist (9, list_args);
|
|
1626 }
|
|
1627
|
15180
|
1628 DEFUN ("encode-time", Fencode_time, Sencode_time, 6, MANY, 0,
|
39988
|
1629 doc: /* Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.
|
39966
|
1630 This is the reverse operation of `decode-time', which see.
|
|
1631 ZONE defaults to the current time zone rule. This can
|
|
1632 be a string or t (as from `set-time-zone-rule'), or it can be a list
|
40044
|
1633 \(as from `current-time-zone') or an integer (as from `decode-time')
|
39966
|
1634 applied without consideration for daylight savings time.
|
|
1635
|
|
1636 You can pass more than 7 arguments; then the first six arguments
|
|
1637 are used as SECOND through YEAR, and the *last* argument is used as ZONE.
|
|
1638 The intervening arguments are ignored.
|
|
1639 This feature lets (apply 'encode-time (decode-time ...)) work.
|
|
1640
|
|
1641 Out-of-range values for SEC, MINUTE, HOUR, DAY, or MONTH are allowed;
|
|
1642 for example, a DAY of 0 means the day preceding the given month.
|
|
1643 Year numbers less than 100 are treated just like other year numbers.
|
40131
|
1644 If you want them to stand for years in this century, you must do that yourself.
|
|
1645
|
|
1646 usage: (encode-time SECOND MINUTE HOUR DAY MONTH YEAR &optional ZONE) */)
|
39988
|
1647 (nargs, args)
|
15180
|
1648 int nargs;
|
|
1649 register Lisp_Object *args;
|
11402
|
1650 {
|
11468
|
1651 time_t time;
|
13025
|
1652 struct tm tm;
|
16874
|
1653 Lisp_Object zone = (nargs > 6 ? args[nargs - 1] : Qnil);
|
11402
|
1654
|
40656
|
1655 CHECK_NUMBER (args[0]); /* second */
|
|
1656 CHECK_NUMBER (args[1]); /* minute */
|
|
1657 CHECK_NUMBER (args[2]); /* hour */
|
|
1658 CHECK_NUMBER (args[3]); /* day */
|
|
1659 CHECK_NUMBER (args[4]); /* month */
|
|
1660 CHECK_NUMBER (args[5]); /* year */
|
11468
|
1661
|
15180
|
1662 tm.tm_sec = XINT (args[0]);
|
|
1663 tm.tm_min = XINT (args[1]);
|
|
1664 tm.tm_hour = XINT (args[2]);
|
|
1665 tm.tm_mday = XINT (args[3]);
|
|
1666 tm.tm_mon = XINT (args[4]) - 1;
|
|
1667 tm.tm_year = XINT (args[5]) - 1900;
|
13025
|
1668 tm.tm_isdst = -1;
|
11468
|
1669
|
13025
|
1670 if (CONSP (zone))
|
|
1671 zone = Fcar (zone);
|
11468
|
1672 if (NILP (zone))
|
13025
|
1673 time = mktime (&tm);
|
|
1674 else
|
11468
|
1675 {
|
13025
|
1676 char tzbuf[100];
|
|
1677 char *tzstring;
|
|
1678 char **oldenv = environ, **newenv;
|
30480
|
1679
|
18613
|
1680 if (EQ (zone, Qt))
|
15910
|
1681 tzstring = "UTC0";
|
|
1682 else if (STRINGP (zone))
|
13347
|
1683 tzstring = (char *) XSTRING (zone)->data;
|
13025
|
1684 else if (INTEGERP (zone))
|
11468
|
1685 {
|
13025
|
1686 int abszone = abs (XINT (zone));
|
|
1687 sprintf (tzbuf, "XXX%s%d:%02d:%02d", "-" + (XINT (zone) < 0),
|
|
1688 abszone / (60*60), (abszone/60) % 60, abszone % 60);
|
|
1689 tzstring = tzbuf;
|
11468
|
1690 }
|
13025
|
1691 else
|
|
1692 error ("Invalid time zone specification");
|
|
1693
|
30480
|
1694 /* Set TZ before calling mktime; merely adjusting mktime's returned
|
13025
|
1695 value doesn't suffice, since that would mishandle leap seconds. */
|
|
1696 set_time_zone_rule (tzstring);
|
|
1697
|
|
1698 time = mktime (&tm);
|
|
1699
|
|
1700 /* Restore TZ to previous value. */
|
|
1701 newenv = environ;
|
|
1702 environ = oldenv;
|
16521
|
1703 xfree (newenv);
|
13025
|
1704 #ifdef LOCALTIME_CACHE
|
|
1705 tzset ();
|
|
1706 #endif
|
11468
|
1707 }
|
11402
|
1708
|
13025
|
1709 if (time == (time_t) -1)
|
|
1710 error ("Specified time is not representable");
|
|
1711
|
|
1712 return make_time (time);
|
11402
|
1713 }
|
|
1714
|
2154
|
1715 DEFUN ("current-time-string", Fcurrent_time_string, Scurrent_time_string, 0, 1, 0,
|
39988
|
1716 doc: /* Return the current time, as a human-readable string.
|
39966
|
1717 Programs can use this function to decode a time,
|
|
1718 since the number of columns in each field is fixed.
|
|
1719 The format is `Sun Sep 16 01:03:52 1973'.
|
|
1720 However, see also the functions `decode-time' and `format-time-string'
|
|
1721 which provide a much more powerful and general facility.
|
|
1722
|
|
1723 If an argument is given, it specifies a time to format
|
|
1724 instead of the current time. The argument should have the form:
|
|
1725 (HIGH . LOW)
|
|
1726 or the form:
|
|
1727 (HIGH LOW . IGNORED).
|
|
1728 Thus, you can use times obtained from `current-time'
|
39988
|
1729 and from `file-attributes'. */)
|
|
1730 (specified_time)
|
2154
|
1731 Lisp_Object specified_time;
|
305
|
1732 {
|
2921
|
1733 time_t value;
|
305
|
1734 char buf[30];
|
2154
|
1735 register char *tem;
|
|
1736
|
30480
|
1737 if (! lisp_time_argument (specified_time, &value, NULL))
|
2921
|
1738 value = -1;
|
2154
|
1739 tem = (char *) ctime (&value);
|
305
|
1740
|
|
1741 strncpy (buf, tem, 24);
|
|
1742 buf[24] = 0;
|
|
1743
|
|
1744 return build_string (buf);
|
|
1745 }
|
962
|
1746
|
16269
|
1747 #define TM_YEAR_BASE 1900
|
2921
|
1748
|
16269
|
1749 /* Yield A - B, measured in seconds.
|
|
1750 This function is copied from the GNU C Library. */
|
|
1751 static int
|
|
1752 tm_diff (a, b)
|
2921
|
1753 struct tm *a, *b;
|
|
1754 {
|
16269
|
1755 /* Compute intervening leap days correctly even if year is negative.
|
|
1756 Take care to avoid int overflow in leap day calculations,
|
|
1757 but it's OK to assume that A and B are close to each other. */
|
|
1758 int a4 = (a->tm_year >> 2) + (TM_YEAR_BASE >> 2) - ! (a->tm_year & 3);
|
|
1759 int b4 = (b->tm_year >> 2) + (TM_YEAR_BASE >> 2) - ! (b->tm_year & 3);
|
|
1760 int a100 = a4 / 25 - (a4 % 25 < 0);
|
|
1761 int b100 = b4 / 25 - (b4 % 25 < 0);
|
|
1762 int a400 = a100 >> 2;
|
|
1763 int b400 = b100 >> 2;
|
|
1764 int intervening_leap_days = (a4 - b4) - (a100 - b100) + (a400 - b400);
|
|
1765 int years = a->tm_year - b->tm_year;
|
|
1766 int days = (365 * years + intervening_leap_days
|
|
1767 + (a->tm_yday - b->tm_yday));
|
|
1768 return (60 * (60 * (24 * days + (a->tm_hour - b->tm_hour))
|
|
1769 + (a->tm_min - b->tm_min))
|
5882
|
1770 + (a->tm_sec - b->tm_sec));
|
2921
|
1771 }
|
|
1772
|
|
1773 DEFUN ("current-time-zone", Fcurrent_time_zone, Scurrent_time_zone, 0, 1, 0,
|
39988
|
1774 doc: /* Return the offset and name for the local time zone.
|
39966
|
1775 This returns a list of the form (OFFSET NAME).
|
|
1776 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).
|
|
1777 A negative value means west of Greenwich.
|
|
1778 NAME is a string giving the name of the time zone.
|
|
1779 If an argument is given, it specifies when the time zone offset is determined
|
|
1780 instead of using the current time. The argument should have the form:
|
|
1781 (HIGH . LOW)
|
|
1782 or the form:
|
|
1783 (HIGH LOW . IGNORED).
|
|
1784 Thus, you can use times obtained from `current-time'
|
|
1785 and from `file-attributes'.
|
|
1786
|
|
1787 Some operating systems cannot provide all this information to Emacs;
|
|
1788 in this case, `current-time-zone' returns a list containing nil for
|
39988
|
1789 the data it can't find. */)
|
|
1790 (specified_time)
|
2921
|
1791 Lisp_Object specified_time;
|
962
|
1792 {
|
2921
|
1793 time_t value;
|
|
1794 struct tm *t;
|
23198
|
1795 struct tm gmt;
|
962
|
1796
|
30480
|
1797 if (lisp_time_argument (specified_time, &value, NULL)
|
23198
|
1798 && (t = gmtime (&value)) != 0
|
|
1799 && (gmt = *t, t = localtime (&value)) != 0)
|
2921
|
1800 {
|
23198
|
1801 int offset = tm_diff (t, &gmt);
|
|
1802 char *s = 0;
|
|
1803 char buf[6];
|
2921
|
1804 #ifdef HAVE_TM_ZONE
|
|
1805 if (t->tm_zone)
|
7506
|
1806 s = (char *)t->tm_zone;
|
3522
|
1807 #else /* not HAVE_TM_ZONE */
|
|
1808 #ifdef HAVE_TZNAME
|
|
1809 if (t->tm_isdst == 0 || t->tm_isdst == 1)
|
|
1810 s = tzname[t->tm_isdst];
|
962
|
1811 #endif
|
3522
|
1812 #endif /* not HAVE_TM_ZONE */
|
36479
|
1813
|
|
1814 #if defined HAVE_TM_ZONE || defined HAVE_TZNAME
|
|
1815 if (s)
|
|
1816 {
|
|
1817 /* On Japanese w32, we can get a Japanese string as time
|
|
1818 zone name. Don't accept that. */
|
|
1819 char *p;
|
39720
|
1820 for (p = s; *p && (isalnum ((unsigned char)*p) || *p == ' '); ++p)
|
36479
|
1821 ;
|
|
1822 if (p == s || *p)
|
|
1823 s = NULL;
|
|
1824 }
|
|
1825 #endif
|
|
1826
|
2921
|
1827 if (!s)
|
|
1828 {
|
|
1829 /* No local time zone name is available; use "+-NNNN" instead. */
|
2994
|
1830 int am = (offset < 0 ? -offset : offset) / 60;
|
2921
|
1831 sprintf (buf, "%c%02d%02d", (offset < 0 ? '-' : '+'), am/60, am%60);
|
|
1832 s = buf;
|
|
1833 }
|
|
1834 return Fcons (make_number (offset), Fcons (build_string (s), Qnil));
|
|
1835 }
|
|
1836 else
|
18745
192b3ebd108e
(Fcurrent_time_zone): Convert Fmake_list argument to Lisp_Integer.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
1837 return Fmake_list (make_number (2), Qnil);
|
962
|
1838 }
|
|
1839
|
13767
|
1840 /* This holds the value of `environ' produced by the previous
|
|
1841 call to Fset_time_zone_rule, or 0 if Fset_time_zone_rule
|
|
1842 has never been called. */
|
|
1843 static char **environbuf;
|
|
1844
|
13019
|
1845 DEFUN ("set-time-zone-rule", Fset_time_zone_rule, Sset_time_zone_rule, 1, 1, 0,
|
39988
|
1846 doc: /* Set the local time zone using TZ, a string specifying a time zone rule.
|
39966
|
1847 If TZ is nil, use implementation-defined default time zone information.
|
39988
|
1848 If TZ is t, use Universal Time. */)
|
|
1849 (tz)
|
13019
|
1850 Lisp_Object tz;
|
|
1851 {
|
|
1852 char *tzstring;
|
|
1853
|
|
1854 if (NILP (tz))
|
|
1855 tzstring = 0;
|
18613
|
1856 else if (EQ (tz, Qt))
|
15910
|
1857 tzstring = "UTC0";
|
13019
|
1858 else
|
|
1859 {
|
40656
|
1860 CHECK_STRING (tz);
|
13347
|
1861 tzstring = (char *) XSTRING (tz)->data;
|
13019
|
1862 }
|
|
1863
|
13025
|
1864 set_time_zone_rule (tzstring);
|
|
1865 if (environbuf)
|
|
1866 free (environbuf);
|
|
1867 environbuf = environ;
|
|
1868
|
|
1869 return Qnil;
|
|
1870 }
|
|
1871
|
16918
|
1872 #ifdef LOCALTIME_CACHE
|
|
1873
|
|
1874 /* These two values are known to load tz files in buggy implementations,
|
|
1875 i.e. Solaris 1 executables running under either Solaris 1 or Solaris 2.
|
15841
|
1876 Their values shouldn't matter in non-buggy implementations.
|
30480
|
1877 We don't use string literals for these strings,
|
15841
|
1878 since if a string in the environment is in readonly
|
|
1879 storage, it runs afoul of bugs in SVR4 and Solaris 2.3.
|
|
1880 See Sun bugs 1113095 and 1114114, ``Timezone routines
|
|
1881 improperly modify environment''. */
|
|
1882
|
16918
|
1883 static char set_time_zone_rule_tz1[] = "TZ=GMT+0";
|
|
1884 static char set_time_zone_rule_tz2[] = "TZ=GMT+1";
|
|
1885
|
|
1886 #endif
|
15841
|
1887
|
13025
|
1888 /* Set the local time zone rule to TZSTRING.
|
|
1889 This allocates memory into `environ', which it is the caller's
|
|
1890 responsibility to free. */
|
31016
|
1891
|
14201
|
1892 void
|
13025
|
1893 set_time_zone_rule (tzstring)
|
|
1894 char *tzstring;
|
|
1895 {
|
|
1896 int envptrs;
|
|
1897 char **from, **to, **newenv;
|
|
1898
|
15334
|
1899 /* Make the ENVIRON vector longer with room for TZSTRING. */
|
13019
|
1900 for (from = environ; *from; from++)
|
|
1901 continue;
|
|
1902 envptrs = from - environ + 2;
|
|
1903 newenv = to = (char **) xmalloc (envptrs * sizeof (char *)
|
|
1904 + (tzstring ? strlen (tzstring) + 4 : 0));
|
15334
|
1905
|
|
1906 /* Add TZSTRING to the end of environ, as a value for TZ. */
|
13019
|
1907 if (tzstring)
|
|
1908 {
|
|
1909 char *t = (char *) (to + envptrs);
|
|
1910 strcpy (t, "TZ=");
|
|
1911 strcat (t, tzstring);
|
|
1912 *to++ = t;
|
|
1913 }
|
|
1914
|
15334
|
1915 /* Copy the old environ vector elements into NEWENV,
|
|
1916 but don't copy the TZ variable.
|
|
1917 So we have only one definition of TZ, which came from TZSTRING. */
|
13019
|
1918 for (from = environ; *from; from++)
|
|
1919 if (strncmp (*from, "TZ=", 3) != 0)
|
|
1920 *to++ = *from;
|
|
1921 *to = 0;
|
|
1922
|
|
1923 environ = newenv;
|
|
1924
|
15334
|
1925 /* If we do have a TZSTRING, NEWENV points to the vector slot where
|
|
1926 the TZ variable is stored. If we do not have a TZSTRING,
|
|
1927 TO points to the vector slot which has the terminating null. */
|
|
1928
|
13019
|
1929 #ifdef LOCALTIME_CACHE
|
15334
|
1930 {
|
|
1931 /* In SunOS 4.1.3_U1 and 4.1.4, if TZ has a value like
|
|
1932 "US/Pacific" that loads a tz file, then changes to a value like
|
|
1933 "XXX0" that does not load a tz file, and then changes back to
|
|
1934 its original value, the last change is (incorrectly) ignored.
|
|
1935 Also, if TZ changes twice in succession to values that do
|
|
1936 not load a tz file, tzset can dump core (see Sun bug#1225179).
|
|
1937 The following code works around these bugs. */
|
|
1938
|
|
1939 if (tzstring)
|
|
1940 {
|
|
1941 /* Temporarily set TZ to a value that loads a tz file
|
|
1942 and that differs from tzstring. */
|
|
1943 char *tz = *newenv;
|
15841
|
1944 *newenv = (strcmp (tzstring, set_time_zone_rule_tz1 + 3) == 0
|
|
1945 ? set_time_zone_rule_tz2 : set_time_zone_rule_tz1);
|
15334
|
1946 tzset ();
|
|
1947 *newenv = tz;
|
|
1948 }
|
|
1949 else
|
|
1950 {
|
|
1951 /* The implied tzstring is unknown, so temporarily set TZ to
|
|
1952 two different values that each load a tz file. */
|
15841
|
1953 *to = set_time_zone_rule_tz1;
|
15334
|
1954 to[1] = 0;
|
|
1955 tzset ();
|
15841
|
1956 *to = set_time_zone_rule_tz2;
|
15334
|
1957 tzset ();
|
|
1958 *to = 0;
|
|
1959 }
|
|
1960
|
|
1961 /* Now TZ has the desired value, and tzset can be invoked safely. */
|
|
1962 }
|
|
1963
|
13019
|
1964 tzset ();
|
|
1965 #endif
|
|
1966 }
|
305
|
1967
|
17031
|
1968 /* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC
|
|
1969 (if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a
|
|
1970 type of object is Lisp_String). INHERIT is passed to
|
|
1971 INSERT_FROM_STRING_FUNC as the last argument. */
|
|
1972
|
31016
|
1973 static void
|
17031
|
1974 general_insert_function (insert_func, insert_from_string_func,
|
|
1975 inherit, nargs, args)
|
20311
|
1976 void (*insert_func) P_ ((unsigned char *, int));
|
20606
|
1977 void (*insert_from_string_func) P_ ((Lisp_Object, int, int, int, int, int));
|
17031
|
1978 int inherit, nargs;
|
|
1979 register Lisp_Object *args;
|
|
1980 {
|
|
1981 register int argnum;
|
|
1982 register Lisp_Object val;
|
|
1983
|
|
1984 for (argnum = 0; argnum < nargs; argnum++)
|
|
1985 {
|
|
1986 val = args[argnum];
|
|
1987 retry:
|
|
1988 if (INTEGERP (val))
|
|
1989 {
|
26853
|
1990 unsigned char str[MAX_MULTIBYTE_LENGTH];
|
17031
|
1991 int len;
|
|
1992
|
|
1993 if (!NILP (current_buffer->enable_multibyte_characters))
|
26853
|
1994 len = CHAR_STRING (XFASTINT (val), str);
|
17031
|
1995 else
|
22929
|
1996 {
|
26853
|
1997 str[0] = (SINGLE_BYTE_CHAR_P (XINT (val))
|
|
1998 ? XINT (val)
|
|
1999 : multibyte_char_to_unibyte (XINT (val), Qnil));
|
22929
|
2000 len = 1;
|
|
2001 }
|
17031
|
2002 (*insert_func) (str, len);
|
|
2003 }
|
|
2004 else if (STRINGP (val))
|
|
2005 {
|
20606
|
2006 (*insert_from_string_func) (val, 0, 0,
|
|
2007 XSTRING (val)->size,
|
21245
|
2008 STRING_BYTES (XSTRING (val)),
|
20606
|
2009 inherit);
|
17031
|
2010 }
|
|
2011 else
|
|
2012 {
|
|
2013 val = wrong_type_argument (Qchar_or_string_p, val);
|
|
2014 goto retry;
|
|
2015 }
|
|
2016 }
|
|
2017 }
|
|
2018
|
305
|
2019 void
|
|
2020 insert1 (arg)
|
|
2021 Lisp_Object arg;
|
|
2022 {
|
|
2023 Finsert (1, &arg);
|
|
2024 }
|
|
2025
|
330
|
2026
|
|
2027 /* Callers passing one argument to Finsert need not gcpro the
|
|
2028 argument "array", since the only element of the array will
|
|
2029 not be used after calling insert or insert_from_string, so
|
|
2030 we don't care if it gets trashed. */
|
|
2031
|
305
|
2032 DEFUN ("insert", Finsert, Sinsert, 0, MANY, 0,
|
39988
|
2033 doc: /* Insert the arguments, either strings or characters, at point.
|
39966
|
2034 Point and before-insertion markers move forward to end up
|
|
2035 after the inserted text.
|
|
2036 Any other markers at the point of insertion remain before the text.
|
|
2037
|
|
2038 If the current buffer is multibyte, unibyte strings are converted
|
|
2039 to multibyte for insertion (see `unibyte-char-to-multibyte').
|
|
2040 If the current buffer is unibyte, multibyte strings are converted
|
40131
|
2041 to unibyte for insertion.
|
|
2042
|
|
2043 usage: (insert &rest ARGS) */)
|
39988
|
2044 (nargs, args)
|
305
|
2045 int nargs;
|
|
2046 register Lisp_Object *args;
|
|
2047 {
|
17031
|
2048 general_insert_function (insert, insert_from_string, 0, nargs, args);
|
4714
|
2049 return Qnil;
|
|
2050 }
|
|
2051
|
|
2052 DEFUN ("insert-and-inherit", Finsert_and_inherit, Sinsert_and_inherit,
|
|
2053 0, MANY, 0,
|
39988
|
2054 doc: /* Insert the arguments at point, inheriting properties from adjoining text.
|
39966
|
2055 Point and before-insertion markers move forward to end up
|
|
2056 after the inserted text.
|
|
2057 Any other markers at the point of insertion remain before the text.
|
|
2058
|
|
2059 If the current buffer is multibyte, unibyte strings are converted
|
|
2060 to multibyte for insertion (see `unibyte-char-to-multibyte').
|
|
2061 If the current buffer is unibyte, multibyte strings are converted
|
40131
|
2062 to unibyte for insertion.
|
|
2063
|
|
2064 usage: (insert-and-inherit &rest ARGS) */)
|
39988
|
2065 (nargs, args)
|
4714
|
2066 int nargs;
|
|
2067 register Lisp_Object *args;
|
|
2068 {
|
17031
|
2069 general_insert_function (insert_and_inherit, insert_from_string, 1,
|
|
2070 nargs, args);
|
305
|
2071 return Qnil;
|
|
2072 }
|
|
2073
|
|
2074 DEFUN ("insert-before-markers", Finsert_before_markers, Sinsert_before_markers, 0, MANY, 0,
|
39988
|
2075 doc: /* Insert strings or characters at point, relocating markers after the text.
|
39966
|
2076 Point and markers move forward to end up after the inserted text.
|
|
2077
|
|
2078 If the current buffer is multibyte, unibyte strings are converted
|
|
2079 to multibyte for insertion (see `unibyte-char-to-multibyte').
|
|
2080 If the current buffer is unibyte, multibyte strings are converted
|
40131
|
2081 to unibyte for insertion.
|
|
2082
|
|
2083 usage: (insert-before-markers &rest ARGS) */)
|
39988
|
2084 (nargs, args)
|
305
|
2085 int nargs;
|
|
2086 register Lisp_Object *args;
|
|
2087 {
|
17031
|
2088 general_insert_function (insert_before_markers,
|
|
2089 insert_from_string_before_markers, 0,
|
|
2090 nargs, args);
|
4714
|
2091 return Qnil;
|
|
2092 }
|
|
2093
|
16485
|
2094 DEFUN ("insert-before-markers-and-inherit", Finsert_and_inherit_before_markers,
|
|
2095 Sinsert_and_inherit_before_markers, 0, MANY, 0,
|
39988
|
2096 doc: /* Insert text at point, relocating markers and inheriting properties.
|
39966
|
2097 Point and markers move forward to end up after the inserted text.
|
|
2098
|
|
2099 If the current buffer is multibyte, unibyte strings are converted
|
|
2100 to multibyte for insertion (see `unibyte-char-to-multibyte').
|
|
2101 If the current buffer is unibyte, multibyte strings are converted
|
40131
|
2102 to unibyte for insertion.
|
|
2103
|
|
2104 usage: (insert-before-markers-and-inherit &rest ARGS) */)
|
39988
|
2105 (nargs, args)
|
4714
|
2106 int nargs;
|
|
2107 register Lisp_Object *args;
|
|
2108 {
|
17031
|
2109 general_insert_function (insert_before_markers_and_inherit,
|
|
2110 insert_from_string_before_markers, 1,
|
|
2111 nargs, args);
|
305
|
2112 return Qnil;
|
|
2113 }
|
|
2114
|
8646
|
2115 DEFUN ("insert-char", Finsert_char, Sinsert_char, 2, 3, 0,
|
39988
|
2116 doc: /* Insert COUNT (second arg) copies of CHARACTER (first arg).
|
39966
|
2117 Both arguments are required.
|
|
2118 Point, and before-insertion markers, are relocated as in the function `insert'.
|
|
2119 The optional third arg INHERIT, if non-nil, says to inherit text properties
|
39988
|
2120 from adjoining text, if those properties are sticky. */)
|
|
2121 (character, count, inherit)
|
14071
59906ecd9b92
(Fchar_to_string, Fstring_to_char, Fgoto_char, Fencode_time, Finsert_char,
Erik Naggum <erik@naggum.no>
diff
changeset
|
2122 Lisp_Object character, count, inherit;
|
305
|
2123 {
|
|
2124 register unsigned char *string;
|
|
2125 register int strlen;
|
|
2126 register int i, n;
|
17031
|
2127 int len;
|
26853
|
2128 unsigned char str[MAX_MULTIBYTE_LENGTH];
|
305
|
2129
|
40656
|
2130 CHECK_NUMBER (character);
|
|
2131 CHECK_NUMBER (count);
|
305
|
2132
|
17031
|
2133 if (!NILP (current_buffer->enable_multibyte_characters))
|
26853
|
2134 len = CHAR_STRING (XFASTINT (character), str);
|
17031
|
2135 else
|
26853
|
2136 str[0] = XFASTINT (character), len = 1;
|
17031
|
2137 n = XINT (count) * len;
|
305
|
2138 if (n <= 0)
|
|
2139 return Qnil;
|
17031
|
2140 strlen = min (n, 256 * len);
|
305
|
2141 string = (unsigned char *) alloca (strlen);
|
|
2142 for (i = 0; i < strlen; i++)
|
17031
|
2143 string[i] = str[i % len];
|
305
|
2144 while (n >= strlen)
|
|
2145 {
|
18194
|
2146 QUIT;
|
8646
|
2147 if (!NILP (inherit))
|
|
2148 insert_and_inherit (string, strlen);
|
|
2149 else
|
|
2150 insert (string, strlen);
|
305
|
2151 n -= strlen;
|
|
2152 }
|
|
2153 if (n > 0)
|
10382
|
2154 {
|
|
2155 if (!NILP (inherit))
|
|
2156 insert_and_inherit (string, n);
|
|
2157 else
|
|
2158 insert (string, n);
|
|
2159 }
|
305
|
2160 return Qnil;
|
|
2161 }
|
|
2162
|
|
2163
|
648
|
2164 /* Making strings from buffer contents. */
|
|
2165
|
|
2166 /* Return a Lisp_String containing the text of the current buffer from
|
1285
d50533e23dff
* editfns.c (make_buffer_string): Call copy_intervals_to_string().
Joseph Arceneaux <jla@gnu.org>
diff
changeset
|
2167 START to END. If text properties are in use and the current buffer
|
3591
|
2168 has properties in the range specified, the resulting string will also
|
13767
|
2169 have them, if PROPS is nonzero.
|
648
|
2170
|
|
2171 We don't want to use plain old make_string here, because it calls
|
|
2172 make_uninit_string, which can cause the buffer arena to be
|
|
2173 compacted. make_string has no way of knowing that the data has
|
|
2174 been moved, and thus copies the wrong data into the string. This
|
|
2175 doesn't effect most of the other users of make_string, so it should
|
|
2176 be left as is. But we should use this function when conjuring
|
|
2177 buffer substrings. */
|
1285
d50533e23dff
* editfns.c (make_buffer_string): Call copy_intervals_to_string().
Joseph Arceneaux <jla@gnu.org>
diff
changeset
|
2178
|
648
|
2179 Lisp_Object
|
13767
|
2180 make_buffer_string (start, end, props)
|
648
|
2181 int start, end;
|
13767
|
2182 int props;
|
648
|
2183 {
|
20558
|
2184 int start_byte = CHAR_TO_BYTE (start);
|
|
2185 int end_byte = CHAR_TO_BYTE (end);
|
648
|
2186
|
21235
|
2187 return make_buffer_string_both (start, start_byte, end, end_byte, props);
|
|
2188 }
|
|
2189
|
|
2190 /* Return a Lisp_String containing the text of the current buffer from
|
|
2191 START / START_BYTE to END / END_BYTE.
|
|
2192
|
|
2193 If text properties are in use and the current buffer
|
|
2194 has properties in the range specified, the resulting string will also
|
|
2195 have them, if PROPS is nonzero.
|
|
2196
|
|
2197 We don't want to use plain old make_string here, because it calls
|
|
2198 make_uninit_string, which can cause the buffer arena to be
|
|
2199 compacted. make_string has no way of knowing that the data has
|
|
2200 been moved, and thus copies the wrong data into the string. This
|
|
2201 doesn't effect most of the other users of make_string, so it should
|
|
2202 be left as is. But we should use this function when conjuring
|
|
2203 buffer substrings. */
|
|
2204
|
|
2205 Lisp_Object
|
|
2206 make_buffer_string_both (start, start_byte, end, end_byte, props)
|
|
2207 int start, start_byte, end, end_byte;
|
|
2208 int props;
|
|
2209 {
|
|
2210 Lisp_Object result, tem, tem1;
|
|
2211
|
648
|
2212 if (start < GPT && GPT < end)
|
|
2213 move_gap (start);
|
|
2214
|
21257
|
2215 if (! NILP (current_buffer->enable_multibyte_characters))
|
|
2216 result = make_uninit_multibyte_string (end - start, end_byte - start_byte);
|
|
2217 else
|
|
2218 result = make_uninit_string (end - start);
|
20558
|
2219 bcopy (BYTE_POS_ADDR (start_byte), XSTRING (result)->data,
|
|
2220 end_byte - start_byte);
|
648
|
2221
|
13767
|
2222 /* If desired, update and copy the text properties. */
|
|
2223 if (props)
|
|
2224 {
|
|
2225 update_buffer_properties (start, end);
|
5130
|
2226
|
13767
|
2227 tem = Fnext_property_change (make_number (start), Qnil, make_number (end));
|
|
2228 tem1 = Ftext_properties_at (make_number (start), Qnil);
|
|
2229
|
|
2230 if (XINT (tem) != end || !NILP (tem1))
|
20558
|
2231 copy_intervals_to_string (result, current_buffer, start,
|
|
2232 end - start);
|
13767
|
2233 }
|
1285
d50533e23dff
* editfns.c (make_buffer_string): Call copy_intervals_to_string().
Joseph Arceneaux <jla@gnu.org>
diff
changeset
|
2234
|
648
|
2235 return result;
|
|
2236 }
|
305
|
2237
|
13767
|
2238 /* Call Vbuffer_access_fontify_functions for the range START ... END
|
|
2239 in the current buffer, if necessary. */
|
|
2240
|
|
2241 static void
|
|
2242 update_buffer_properties (start, end)
|
|
2243 int start, end;
|
|
2244 {
|
|
2245 /* If this buffer has some access functions,
|
|
2246 call them, specifying the range of the buffer being accessed. */
|
|
2247 if (!NILP (Vbuffer_access_fontify_functions))
|
|
2248 {
|
|
2249 Lisp_Object args[3];
|
|
2250 Lisp_Object tem;
|
|
2251
|
|
2252 args[0] = Qbuffer_access_fontify_functions;
|
|
2253 XSETINT (args[1], start);
|
|
2254 XSETINT (args[2], end);
|
|
2255
|
|
2256 /* But don't call them if we can tell that the work
|
|
2257 has already been done. */
|
|
2258 if (!NILP (Vbuffer_access_fontified_property))
|
|
2259 {
|
|
2260 tem = Ftext_property_any (args[1], args[2],
|
|
2261 Vbuffer_access_fontified_property,
|
|
2262 Qnil, Qnil);
|
|
2263 if (! NILP (tem))
|
14126
|
2264 Frun_hook_with_args (3, args);
|
13767
|
2265 }
|
|
2266 else
|
14126
|
2267 Frun_hook_with_args (3, args);
|
13767
|
2268 }
|
|
2269 }
|
|
2270
|
305
|
2271 DEFUN ("buffer-substring", Fbuffer_substring, Sbuffer_substring, 2, 2, 0,
|
39988
|
2272 doc: /* Return the contents of part of the current buffer as a string.
|
39966
|
2273 The two arguments START and END are character positions;
|
|
2274 they can be in either order.
|
|
2275 The string returned is multibyte if the buffer is multibyte.
|
|
2276
|
|
2277 This function copies the text properties of that part of the buffer
|
|
2278 into the result string; if you don't want the text properties,
|
39988
|
2279 use `buffer-substring-no-properties' instead. */)
|
|
2280 (start, end)
|
14071
59906ecd9b92
(Fchar_to_string, Fstring_to_char, Fgoto_char, Fencode_time, Finsert_char,
Erik Naggum <erik@naggum.no>
diff
changeset
|
2281 Lisp_Object start, end;
|
305
|
2282 {
|
14071
59906ecd9b92
(Fchar_to_string, Fstring_to_char, Fgoto_char, Fencode_time, Finsert_char,
Erik Naggum <erik@naggum.no>
diff
changeset
|
2283 register int b, e;
|
305
|
2284
|
14071
59906ecd9b92
(Fchar_to_string, Fstring_to_char, Fgoto_char, Fencode_time, Finsert_char,
Erik Naggum <erik@naggum.no>
diff
changeset
|
2285 validate_region (&start, &end);
|
59906ecd9b92
(Fchar_to_string, Fstring_to_char, Fgoto_char, Fencode_time, Finsert_char,
Erik Naggum <erik@naggum.no>
diff
changeset
|
2286 b = XINT (start);
|
59906ecd9b92
(Fchar_to_string, Fstring_to_char, Fgoto_char, Fencode_time, Finsert_char,
Erik Naggum <erik@naggum.no>
diff
changeset
|
2287 e = XINT (end);
|
305
|
2288
|
14071
59906ecd9b92
(Fchar_to_string, Fstring_to_char, Fgoto_char, Fencode_time, Finsert_char,
Erik Naggum <erik@naggum.no>
diff
changeset
|
2289 return make_buffer_string (b, e, 1);
|
13767
|
2290 }
|
|
2291
|
|
2292 DEFUN ("buffer-substring-no-properties", Fbuffer_substring_no_properties,
|
|
2293 Sbuffer_substring_no_properties, 2, 2, 0,
|
39988
|
2294 doc: /* Return the characters of part of the buffer, without the text properties.
|
39966
|
2295 The two arguments START and END are character positions;
|
39988
|
2296 they can be in either order. */)
|
|
2297 (start, end)
|
14071
59906ecd9b92
(Fchar_to_string, Fstring_to_char, Fgoto_char, Fencode_time, Finsert_char,
Erik Naggum <erik@naggum.no>
diff
changeset
|
2298 Lisp_Object start, end;
|
13767
|
2299 {
|
14071
59906ecd9b92
(Fchar_to_string, Fstring_to_char, Fgoto_char, Fencode_time, Finsert_char,
Erik Naggum <erik@naggum.no>
diff
changeset
|
2300 register int b, e;
|
13767
|
2301
|
14071
59906ecd9b92
(Fchar_to_string, Fstring_to_char, Fgoto_char, Fencode_time, Finsert_char,
Erik Naggum <erik@naggum.no>
diff
changeset
|
2302 validate_region (&start, &end);
|
59906ecd9b92
(Fchar_to_string, Fstring_to_char, Fgoto_char, Fencode_time, Finsert_char,
Erik Naggum <erik@naggum.no>
diff
changeset
|
2303 b = XINT (start);
|
59906ecd9b92
(Fchar_to_string, Fstring_to_char, Fgoto_char, Fencode_time, Finsert_char,
Erik Naggum <erik@naggum.no>
diff
changeset
|
2304 e = XINT (end);
|
13767
|
2305
|
14071
59906ecd9b92
(Fchar_to_string, Fstring_to_char, Fgoto_char, Fencode_time, Finsert_char,
Erik Naggum <erik@naggum.no>
diff
changeset
|
2306 return make_buffer_string (b, e, 0);
|
305
|
2307 }
|
|
2308
|
|
2309 DEFUN ("buffer-string", Fbuffer_string, Sbuffer_string, 0, 0, 0,
|
39988
|
2310 doc: /* Return the contents of the current buffer as a string.
|
39966
|
2311 If narrowing is in effect, this function returns only the visible part
|
39988
|
2312 of the buffer. */)
|
|
2313 ()
|
305
|
2314 {
|
26058
|
2315 return make_buffer_string (BEGV, ZV, 1);
|
305
|
2316 }
|
|
2317
|
|
2318 DEFUN ("insert-buffer-substring", Finsert_buffer_substring, Sinsert_buffer_substring,
|
40981
|
2319 1, 3, 0,
|
39988
|
2320 doc: /* Insert before point a substring of the contents of buffer BUFFER.
|
39966
|
2321 BUFFER may be a buffer or a buffer name.
|
|
2322 Arguments START and END are character numbers specifying the substring.
|
39988
|
2323 They default to the beginning and the end of BUFFER. */)
|
|
2324 (buf, start, end)
|
14071
59906ecd9b92
(Fchar_to_string, Fstring_to_char, Fgoto_char, Fencode_time, Finsert_char,
Erik Naggum <erik@naggum.no>
diff
changeset
|
2325 Lisp_Object buf, start, end;
|
305
|
2326 {
|
14071
59906ecd9b92
(Fchar_to_string, Fstring_to_char, Fgoto_char, Fencode_time, Finsert_char,
Erik Naggum <erik@naggum.no>
diff
changeset
|
2327 register int b, e, temp;
|
13767
|
2328 register struct buffer *bp, *obuf;
|
1854
|
2329 Lisp_Object buffer;
|
305
|
2330
|
1854
|
2331 buffer = Fget_buffer (buf);
|
|
2332 if (NILP (buffer))
|
|
2333 nsberror (buf);
|
|
2334 bp = XBUFFER (buffer);
|
16134
|
2335 if (NILP (bp->name))
|
|
2336 error ("Selecting deleted buffer");
|
305
|
2337
|
14071
59906ecd9b92
(Fchar_to_string, Fstring_to_char, Fgoto_char, Fencode_time, Finsert_char,
Erik Naggum <erik@naggum.no>
diff
changeset
|
2338 if (NILP (start))
|
59906ecd9b92
(Fchar_to_string, Fstring_to_char, Fgoto_char, Fencode_time, Finsert_char,
Erik Naggum <erik@naggum.no>
diff
changeset
|
2339 b = BUF_BEGV (bp);
|
305
|
2340 else
|
|
2341 {
|
40656
|
2342 CHECK_NUMBER_COERCE_MARKER (start);
|
14071
59906ecd9b92
(Fchar_to_string, Fstring_to_char, Fgoto_char, Fencode_time, Finsert_char,
Erik Naggum <erik@naggum.no>
diff
changeset
|
2343 b = XINT (start);
|
305
|
2344 }
|
14071
59906ecd9b92
(Fchar_to_string, Fstring_to_char, Fgoto_char, Fencode_time, Finsert_char,
Erik Naggum <erik@naggum.no>
diff
changeset
|
2345 if (NILP (end))
|
59906ecd9b92
(Fchar_to_string, Fstring_to_char, Fgoto_char, Fencode_time, Finsert_char,
Erik Naggum <erik@naggum.no>
diff
changeset
|
2346 e = BUF_ZV (bp);
|
305
|
2347 else
|
|
2348 {
|
40656
|
2349 CHECK_NUMBER_COERCE_MARKER (end);
|
14071
59906ecd9b92
(Fchar_to_string, Fstring_to_char, Fgoto_char, Fencode_time, Finsert_char,
Erik Naggum <erik@naggum.no>
diff
changeset
|
2350 e = XINT (end);
|
305
|
2351 }
|
|
2352
|
14071
59906ecd9b92
(Fchar_to_string, Fstring_to_char, Fgoto_char, Fencode_time, Finsert_char,
Erik Naggum <erik@naggum.no>
diff
changeset
|
2353 if (b > e)
|
59906ecd9b92
(Fchar_to_string, Fstring_to_char, Fgoto_char, Fencode_time, Finsert_char,
Erik Naggum <erik@naggum.no>
diff
changeset
|
2354 temp = b, b = e, e = temp;
|
305
|
2355
|
14071
59906ecd9b92
(Fchar_to_string, Fstring_to_char, Fgoto_char, Fencode_time, Finsert_char,
Erik Naggum <erik@naggum.no>
diff
changeset
|
2356 if (!(BUF_BEGV (bp) <= b && e <= BUF_ZV (bp)))
|
59906ecd9b92
(Fchar_to_string, Fstring_to_char, Fgoto_char, Fencode_time, Finsert_char,
Erik Naggum <erik@naggum.no>
diff
changeset
|
2357 args_out_of_range (start, end);
|
305
|
2358
|
13767
|
2359 obuf = current_buffer;
|
|
2360 set_buffer_internal_1 (bp);
|
14071
59906ecd9b92
(Fchar_to_string, Fstring_to_char, Fgoto_char, Fencode_time, Finsert_char,
Erik Naggum <erik@naggum.no>
diff
changeset
|
2361 update_buffer_properties (b, e);
|
13767
|
2362 set_buffer_internal_1 (obuf);
|
|
2363
|
14071
59906ecd9b92
(Fchar_to_string, Fstring_to_char, Fgoto_char, Fencode_time, Finsert_char,
Erik Naggum <erik@naggum.no>
diff
changeset
|
2364 insert_from_buffer (bp, b, e - b, 0);
|
305
|
2365 return Qnil;
|
|
2366 }
|
1853
|
2367
|
|
2368 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings, Scompare_buffer_substrings,
|
40981
|
2369 6, 6, 0,
|
39988
|
2370 doc: /* Compare two substrings of two buffers; return result as number.
|
39966
|
2371 the value is -N if first string is less after N-1 chars,
|
|
2372 +N if first string is greater after N-1 chars, or 0 if strings match.
|
|
2373 Each substring is represented as three arguments: BUFFER, START and END.
|
|
2374 That makes six args in all, three for each substring.
|
|
2375
|
|
2376 The value of `case-fold-search' in the current buffer
|
39988
|
2377 determines whether case is significant or ignored. */)
|
|
2378 (buffer1, start1, end1, buffer2, start2, end2)
|
1853
|
2379 Lisp_Object buffer1, start1, end1, buffer2, start2, end2;
|
|
2380 {
|
21837
|
2381 register int begp1, endp1, begp2, endp2, temp;
|
1853
|
2382 register struct buffer *bp1, *bp2;
|
14391
dfdf939f3e8c
(Fcompare_buffer_substrings): Access case_canon_table as a char_table.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
2383 register Lisp_Object *trt
|
1853
|
2384 = (!NILP (current_buffer->case_fold_search)
|
14391
dfdf939f3e8c
(Fcompare_buffer_substrings): Access case_canon_table as a char_table.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
2385 ? XCHAR_TABLE (current_buffer->case_canon_table)->contents : 0);
|
20558
|
2386 int chars = 0;
|
21837
|
2387 int i1, i2, i1_byte, i2_byte;
|
1853
|
2388
|
|
2389 /* Find the first buffer and its substring. */
|
|
2390
|
|
2391 if (NILP (buffer1))
|
|
2392 bp1 = current_buffer;
|
|
2393 else
|
|
2394 {
|
1854
|
2395 Lisp_Object buf1;
|
|
2396 buf1 = Fget_buffer (buffer1);
|
|
2397 if (NILP (buf1))
|
|
2398 nsberror (buffer1);
|
|
2399 bp1 = XBUFFER (buf1);
|
16134
|
2400 if (NILP (bp1->name))
|
|
2401 error ("Selecting deleted buffer");
|
1853
|
2402 }
|
|
2403
|
|
2404 if (NILP (start1))
|
|
2405 begp1 = BUF_BEGV (bp1);
|
|
2406 else
|
|
2407 {
|
40656
|
2408 CHECK_NUMBER_COERCE_MARKER (start1);
|
1853
|
2409 begp1 = XINT (start1);
|
|
2410 }
|
|
2411 if (NILP (end1))
|
|
2412 endp1 = BUF_ZV (bp1);
|
|
2413 else
|
|
2414 {
|
40656
|
2415 CHECK_NUMBER_COERCE_MARKER (end1);
|
1853
|
2416 endp1 = XINT (end1);
|
|
2417 }
|
|
2418
|
|
2419 if (begp1 > endp1)
|
|
2420 temp = begp1, begp1 = endp1, endp1 = temp;
|
|
2421
|
|
2422 if (!(BUF_BEGV (bp1) <= begp1
|
|
2423 && begp1 <= endp1
|
|
2424 && endp1 <= BUF_ZV (bp1)))
|
|
2425 args_out_of_range (start1, end1);
|
|
2426
|
|
2427 /* Likewise for second substring. */
|
|
2428
|
|
2429 if (NILP (buffer2))
|
|
2430 bp2 = current_buffer;
|
|
2431 else
|
|
2432 {
|
1854
|
2433 Lisp_Object buf2;
|
|
2434 buf2 = Fget_buffer (buffer2);
|
|
2435 if (NILP (buf2))
|
|
2436 nsberror (buffer2);
|
15015
8f8d48ab0a53
(Fcompare_buffer_substrings): Fix dumb bug handling buffer name as second arg.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
2437 bp2 = XBUFFER (buf2);
|
16134
|
2438 if (NILP (bp2->name))
|
|
2439 error ("Selecting deleted buffer");
|
1853
|
2440 }
|
|
2441
|
|
2442 if (NILP (start2))
|
|
2443 begp2 = BUF_BEGV (bp2);
|
|
2444 else
|
|
2445 {
|
40656
|
2446 CHECK_NUMBER_COERCE_MARKER (start2);
|
1853
|
2447 begp2 = XINT (start2);
|
|
2448 }
|
|
2449 if (NILP (end2))
|
|
2450 endp2 = BUF_ZV (bp2);
|
|
2451 else
|
|
2452 {
|
40656
|
2453 CHECK_NUMBER_COERCE_MARKER (end2);
|
1853
|
2454 endp2 = XINT (end2);
|
|
2455 }
|
|
2456
|
|
2457 if (begp2 > endp2)
|
|
2458 temp = begp2, begp2 = endp2, endp2 = temp;
|
|
2459
|
|
2460 if (!(BUF_BEGV (bp2) <= begp2
|
|
2461 && begp2 <= endp2
|
|
2462 && endp2 <= BUF_ZV (bp2)))
|
|
2463 args_out_of_range (start2, end2);
|
|
2464
|
21837
|
2465 i1 = begp1;
|
|
2466 i2 = begp2;
|
|
2467 i1_byte = buf_charpos_to_bytepos (bp1, i1);
|
|
2468 i2_byte = buf_charpos_to_bytepos (bp2, i2);
|
|
2469
|
|
2470 while (i1 < endp1 && i2 < endp2)
|
1853
|
2471 {
|
21837
|
2472 /* When we find a mismatch, we must compare the
|
|
2473 characters, not just the bytes. */
|
|
2474 int c1, c2;
|
|
2475
|
42116
|
2476 QUIT;
|
|
2477
|
21837
|
2478 if (! NILP (bp1->enable_multibyte_characters))
|
|
2479 {
|
|
2480 c1 = BUF_FETCH_MULTIBYTE_CHAR (bp1, i1_byte);
|
|
2481 BUF_INC_POS (bp1, i1_byte);
|
|
2482 i1++;
|
|
2483 }
|
|
2484 else
|
|
2485 {
|
|
2486 c1 = BUF_FETCH_BYTE (bp1, i1);
|
|
2487 c1 = unibyte_char_to_multibyte (c1);
|
|
2488 i1++;
|
|
2489 }
|
|
2490
|
|
2491 if (! NILP (bp2->enable_multibyte_characters))
|
|
2492 {
|
|
2493 c2 = BUF_FETCH_MULTIBYTE_CHAR (bp2, i2_byte);
|
|
2494 BUF_INC_POS (bp2, i2_byte);
|
|
2495 i2++;
|
|
2496 }
|
|
2497 else
|
|
2498 {
|
|
2499 c2 = BUF_FETCH_BYTE (bp2, i2);
|
|
2500 c2 = unibyte_char_to_multibyte (c2);
|
|
2501 i2++;
|
|
2502 }
|
20558
|
2503
|
1853
|
2504 if (trt)
|
|
2505 {
|
18106
|
2506 c1 = XINT (trt[c1]);
|
|
2507 c2 = XINT (trt[c2]);
|
1853
|
2508 }
|
|
2509 if (c1 < c2)
|
20558
|
2510 return make_number (- 1 - chars);
|
1853
|
2511 if (c1 > c2)
|
20558
|
2512 return make_number (chars + 1);
|
21837
|
2513
|
|
2514 chars++;
|
1853
|
2515 }
|
|
2516
|
|
2517 /* The strings match as far as they go.
|
|
2518 If one is shorter, that one is less. */
|
21837
|
2519 if (chars < endp1 - begp1)
|
20558
|
2520 return make_number (chars + 1);
|
21837
|
2521 else if (chars < endp2 - begp2)
|
20558
|
2522 return make_number (- chars - 1);
|
1853
|
2523
|
|
2524 /* Same length too => they are equal. */
|
|
2525 return make_number (0);
|
|
2526 }
|
305
|
2527
|
10480
|
2528 static Lisp_Object
|
|
2529 subst_char_in_region_unwind (arg)
|
|
2530 Lisp_Object arg;
|
|
2531 {
|
|
2532 return current_buffer->undo_list = arg;
|
|
2533 }
|
|
2534
|
12622
205232bb7efe
(Fsubst_char_in_region): Bind buffer-file-name to nil if NOUNDO is true.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
2535 static Lisp_Object
|
205232bb7efe
(Fsubst_char_in_region): Bind buffer-file-name to nil if NOUNDO is true.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
2536 subst_char_in_region_unwind_1 (arg)
|
205232bb7efe
(Fsubst_char_in_region): Bind buffer-file-name to nil if NOUNDO is true.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
2537 Lisp_Object arg;
|
205232bb7efe
(Fsubst_char_in_region): Bind buffer-file-name to nil if NOUNDO is true.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
2538 {
|
205232bb7efe
(Fsubst_char_in_region): Bind buffer-file-name to nil if NOUNDO is true.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
2539 return current_buffer->filename = arg;
|
205232bb7efe
(Fsubst_char_in_region): Bind buffer-file-name to nil if NOUNDO is true.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
2540 }
|
205232bb7efe
(Fsubst_char_in_region): Bind buffer-file-name to nil if NOUNDO is true.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
2541
|
305
|
2542 DEFUN ("subst-char-in-region", Fsubst_char_in_region,
|
40981
|
2543 Ssubst_char_in_region, 4, 5, 0,
|
39988
|
2544 doc: /* From START to END, replace FROMCHAR with TOCHAR each time it occurs.
|
39966
|
2545 If optional arg NOUNDO is non-nil, don't record this change for undo
|
|
2546 and don't mark the buffer as really changed.
|
39988
|
2547 Both characters must have the same length of multi-byte form. */)
|
|
2548 (start, end, fromchar, tochar, noundo)
|
305
|
2549 Lisp_Object start, end, fromchar, tochar, noundo;
|
|
2550 {
|
20834
|
2551 register int pos, pos_byte, stop, i, len, end_byte;
|
5130
|
2552 int changed = 0;
|
26853
|
2553 unsigned char fromstr[MAX_MULTIBYTE_LENGTH], tostr[MAX_MULTIBYTE_LENGTH];
|
|
2554 unsigned char *p;
|
10480
|
2555 int count = specpdl_ptr - specpdl;
|
25507
|
2556 #define COMBINING_NO 0
|
|
2557 #define COMBINING_BEFORE 1
|
|
2558 #define COMBINING_AFTER 2
|
|
2559 #define COMBINING_BOTH (COMBINING_BEFORE | COMBINING_AFTER)
|
|
2560 int maybe_byte_combining = COMBINING_NO;
|
32420
|
2561 int last_changed = 0;
|
28358
|
2562 int multibyte_p = !NILP (current_buffer->enable_multibyte_characters);
|
305
|
2563
|
|
2564 validate_region (&start, &end);
|
40656
|
2565 CHECK_NUMBER (fromchar);
|
|
2566 CHECK_NUMBER (tochar);
|
305
|
2567
|
28358
|
2568 if (multibyte_p)
|
17031
|
2569 {
|
26853
|
2570 len = CHAR_STRING (XFASTINT (fromchar), fromstr);
|
|
2571 if (CHAR_STRING (XFASTINT (tochar), tostr) != len)
|
17031
|
2572 error ("Characters in subst-char-in-region have different byte-lengths");
|
25507
|
2573 if (!ASCII_BYTE_P (*tostr))
|
|
2574 {
|
|
2575 /* If *TOSTR is in the range 0x80..0x9F and TOCHAR is not a
|
|
2576 complete multibyte character, it may be combined with the
|
|
2577 after bytes. If it is in the range 0xA0..0xFF, it may be
|
|
2578 combined with the before and after bytes. */
|
|
2579 if (!CHAR_HEAD_P (*tostr))
|
|
2580 maybe_byte_combining = COMBINING_BOTH;
|
|
2581 else if (BYTES_BY_CHAR_HEAD (*tostr) > len)
|
|
2582 maybe_byte_combining = COMBINING_AFTER;
|
|
2583 }
|
17031
|
2584 }
|
|
2585 else
|
|
2586 {
|
|
2587 len = 1;
|
26853
|
2588 fromstr[0] = XFASTINT (fromchar);
|
|
2589 tostr[0] = XFASTINT (tochar);
|
17031
|
2590 }
|
|
2591
|
20834
|
2592 pos = XINT (start);
|
|
2593 pos_byte = CHAR_TO_BYTE (pos);
|
20558
|
2594 stop = CHAR_TO_BYTE (XINT (end));
|
|
2595 end_byte = stop;
|
305
|
2596
|
10480
|
2597 /* If we don't want undo, turn off putting stuff on the list.
|
|
2598 That's faster than getting rid of things,
|
12622
205232bb7efe
(Fsubst_char_in_region): Bind buffer-file-name to nil if NOUNDO is true.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
2599 and it prevents even the entry for a first change.
|
205232bb7efe
(Fsubst_char_in_region): Bind buffer-file-name to nil if NOUNDO is true.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
2600 Also inhibit locking the file. */
|
10480
|
2601 if (!NILP (noundo))
|
|
2602 {
|
|
2603 record_unwind_protect (subst_char_in_region_unwind,
|
|
2604 current_buffer->undo_list);
|
|
2605 current_buffer->undo_list = Qt;
|
12622
205232bb7efe
(Fsubst_char_in_region): Bind buffer-file-name to nil if NOUNDO is true.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
2606 /* Don't do file-locking. */
|
205232bb7efe
(Fsubst_char_in_region): Bind buffer-file-name to nil if NOUNDO is true.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
2607 record_unwind_protect (subst_char_in_region_unwind_1,
|
205232bb7efe
(Fsubst_char_in_region): Bind buffer-file-name to nil if NOUNDO is true.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
2608 current_buffer->filename);
|
205232bb7efe
(Fsubst_char_in_region): Bind buffer-file-name to nil if NOUNDO is true.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
2609 current_buffer->filename = Qnil;
|
10480
|
2610 }
|
|
2611
|
20834
|
2612 if (pos_byte < GPT_BYTE)
|
20558
|
2613 stop = min (stop, GPT_BYTE);
|
17031
|
2614 while (1)
|
305
|
2615 {
|
23554
|
2616 int pos_byte_next = pos_byte;
|
|
2617
|
20834
|
2618 if (pos_byte >= stop)
|
17031
|
2619 {
|
20834
|
2620 if (pos_byte >= end_byte) break;
|
20558
|
2621 stop = end_byte;
|
17031
|
2622 }
|
20834
|
2623 p = BYTE_POS_ADDR (pos_byte);
|
28358
|
2624 if (multibyte_p)
|
|
2625 INC_POS (pos_byte_next);
|
|
2626 else
|
|
2627 ++pos_byte_next;
|
23554
|
2628 if (pos_byte_next - pos_byte == len
|
|
2629 && p[0] == fromstr[0]
|
17031
|
2630 && (len == 1
|
|
2631 || (p[1] == fromstr[1]
|
|
2632 && (len == 2 || (p[2] == fromstr[2]
|
|
2633 && (len == 3 || p[3] == fromstr[3]))))))
|
305
|
2634 {
|
5130
|
2635 if (! changed)
|
|
2636 {
|
26853
|
2637 changed = pos;
|
|
2638 modify_region (current_buffer, changed, XINT (end));
|
5242
|
2639
|
|
2640 if (! NILP (noundo))
|
|
2641 {
|
10308
|
2642 if (MODIFF - 1 == SAVE_MODIFF)
|
|
2643 SAVE_MODIFF++;
|
5242
|
2644 if (MODIFF - 1 == current_buffer->auto_save_modified)
|
|
2645 current_buffer->auto_save_modified++;
|
|
2646 }
|
5130
|
2647 }
|
|
2648
|
22895
|
2649 /* Take care of the case where the new character
|
30480
|
2650 combines with neighboring bytes. */
|
23554
|
2651 if (maybe_byte_combining
|
25507
|
2652 && (maybe_byte_combining == COMBINING_AFTER
|
|
2653 ? (pos_byte_next < Z_BYTE
|
|
2654 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next)))
|
|
2655 : ((pos_byte_next < Z_BYTE
|
|
2656 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next)))
|
|
2657 || (pos_byte > BEG_BYTE
|
|
2658 && ! ASCII_BYTE_P (FETCH_BYTE (pos_byte - 1))))))
|
22895
|
2659 {
|
|
2660 Lisp_Object tem, string;
|
|
2661
|
|
2662 struct gcpro gcpro1;
|
|
2663
|
|
2664 tem = current_buffer->undo_list;
|
|
2665 GCPRO1 (tem);
|
|
2666
|
25507
|
2667 /* Make a multibyte string containing this single character. */
|
|
2668 string = make_multibyte_string (tostr, 1, len);
|
22895
|
2669 /* replace_range is less efficient, because it moves the gap,
|
|
2670 but it handles combining correctly. */
|
|
2671 replace_range (pos, pos + 1, string,
|
23211
|
2672 0, 0, 1);
|
23554
|
2673 pos_byte_next = CHAR_TO_BYTE (pos);
|
|
2674 if (pos_byte_next > pos_byte)
|
|
2675 /* Before combining happened. We should not increment
|
23565
|
2676 POS. So, to cancel the later increment of POS,
|
|
2677 decrease it now. */
|
|
2678 pos--;
|
23554
|
2679 else
|
23565
|
2680 INC_POS (pos_byte_next);
|
30480
|
2681
|
22895
|
2682 if (! NILP (noundo))
|
|
2683 current_buffer->undo_list = tem;
|
|
2684
|
|
2685 UNGCPRO;
|
|
2686 }
|
|
2687 else
|
|
2688 {
|
|
2689 if (NILP (noundo))
|
|
2690 record_change (pos, 1);
|
|
2691 for (i = 0; i < len; i++) *p++ = tostr[i];
|
|
2692 }
|
26853
|
2693 last_changed = pos + 1;
|
305
|
2694 }
|
23565
|
2695 pos_byte = pos_byte_next;
|
|
2696 pos++;
|
305
|
2697 }
|
|
2698
|
5130
|
2699 if (changed)
|
26853
|
2700 {
|
|
2701 signal_after_change (changed,
|
|
2702 last_changed - changed, last_changed - changed);
|
|
2703 update_compositions (changed, last_changed, CHECK_ALL);
|
|
2704 }
|
5130
|
2705
|
10480
|
2706 unbind_to (count, Qnil);
|
305
|
2707 return Qnil;
|
|
2708 }
|
|
2709
|
|
2710 DEFUN ("translate-region", Ftranslate_region, Stranslate_region, 3, 3, 0,
|
39988
|
2711 doc: /* From START to END, translate characters according to TABLE.
|
39966
|
2712 TABLE is a string; the Nth character in it is the mapping
|
|
2713 for the character with code N.
|
|
2714 This function does not alter multibyte characters.
|
39988
|
2715 It returns the number of characters changed. */)
|
|
2716 (start, end, table)
|
305
|
2717 Lisp_Object start;
|
|
2718 Lisp_Object end;
|
|
2719 register Lisp_Object table;
|
|
2720 {
|
20558
|
2721 register int pos_byte, stop; /* Limits of the region. */
|
305
|
2722 register unsigned char *tt; /* Trans table. */
|
|
2723 register int nc; /* New character. */
|
|
2724 int cnt; /* Number of changes made. */
|
|
2725 int size; /* Size of translate table. */
|
20606
|
2726 int pos;
|
26415
|
2727 int multibyte = !NILP (current_buffer->enable_multibyte_characters);
|
305
|
2728
|
|
2729 validate_region (&start, &end);
|
40656
|
2730 CHECK_STRING (table);
|
305
|
2731
|
21245
|
2732 size = STRING_BYTES (XSTRING (table));
|
305
|
2733 tt = XSTRING (table)->data;
|
|
2734
|
20558
|
2735 pos_byte = CHAR_TO_BYTE (XINT (start));
|
|
2736 stop = CHAR_TO_BYTE (XINT (end));
|
|
2737 modify_region (current_buffer, XINT (start), XINT (end));
|
20606
|
2738 pos = XINT (start);
|
305
|
2739
|
|
2740 cnt = 0;
|
20606
|
2741 for (; pos_byte < stop; )
|
305
|
2742 {
|
20558
|
2743 register unsigned char *p = BYTE_POS_ADDR (pos_byte);
|
20606
|
2744 int len;
|
|
2745 int oc;
|
23554
|
2746 int pos_byte_next;
|
20558
|
2747
|
26415
|
2748 if (multibyte)
|
|
2749 oc = STRING_CHAR_AND_LENGTH (p, stop - pos_byte, len);
|
|
2750 else
|
|
2751 oc = *p, len = 1;
|
23554
|
2752 pos_byte_next = pos_byte + len;
|
20606
|
2753 if (oc < size && len == 1)
|
305
|
2754 {
|
|
2755 nc = tt[oc];
|
|
2756 if (nc != oc)
|
|
2757 {
|
22895
|
2758 /* Take care of the case where the new character
|
30480
|
2759 combines with neighboring bytes. */
|
23554
|
2760 if (!ASCII_BYTE_P (nc)
|
|
2761 && (CHAR_HEAD_P (nc)
|
|
2762 ? ! CHAR_HEAD_P (FETCH_BYTE (pos_byte + 1))
|
23596
|
2763 : (pos_byte > BEG_BYTE
|
23554
|
2764 && ! ASCII_BYTE_P (FETCH_BYTE (pos_byte - 1)))))
|
22895
|
2765 {
|
|
2766 Lisp_Object string;
|
|
2767
|
23554
|
2768 string = make_multibyte_string (tt + oc, 1, 1);
|
22895
|
2769 /* This is less efficient, because it moves the gap,
|
|
2770 but it handles combining correctly. */
|
|
2771 replace_range (pos, pos + 1, string,
|
23554
|
2772 1, 0, 1);
|
|
2773 pos_byte_next = CHAR_TO_BYTE (pos);
|
|
2774 if (pos_byte_next > pos_byte)
|
|
2775 /* Before combining happened. We should not
|
23565
|
2776 increment POS. So, to cancel the later
|
|
2777 increment of POS, we decrease it now. */
|
|
2778 pos--;
|
23554
|
2779 else
|
23565
|
2780 INC_POS (pos_byte_next);
|
22895
|
2781 }
|
|
2782 else
|
|
2783 {
|
|
2784 record_change (pos, 1);
|
|
2785 *p = nc;
|
|
2786 signal_after_change (pos, 1, 1);
|
26853
|
2787 update_compositions (pos, pos + 1, CHECK_BORDER);
|
22895
|
2788 }
|
305
|
2789 ++cnt;
|
|
2790 }
|
|
2791 }
|
23565
|
2792 pos_byte = pos_byte_next;
|
|
2793 pos++;
|
305
|
2794 }
|
|
2795
|
20558
|
2796 return make_number (cnt);
|
305
|
2797 }
|
|
2798
|
|
2799 DEFUN ("delete-region", Fdelete_region, Sdelete_region, 2, 2, "r",
|
39988
|
2800 doc: /* Delete the text between point and mark.
|
39966
|
2801 When called from a program, expects two arguments,
|
39988
|
2802 positions (integers or markers) specifying the stretch to be deleted. */)
|
|
2803 (start, end)
|
14071
59906ecd9b92
(Fchar_to_string, Fstring_to_char, Fgoto_char, Fencode_time, Finsert_char,
Erik Naggum <erik@naggum.no>
diff
changeset
|
2804 Lisp_Object start, end;
|
305
|
2805 {
|
14071
59906ecd9b92
(Fchar_to_string, Fstring_to_char, Fgoto_char, Fencode_time, Finsert_char,
Erik Naggum <erik@naggum.no>
diff
changeset
|
2806 validate_region (&start, &end);
|
59906ecd9b92
(Fchar_to_string, Fstring_to_char, Fgoto_char, Fencode_time, Finsert_char,
Erik Naggum <erik@naggum.no>
diff
changeset
|
2807 del_range (XINT (start), XINT (end));
|
305
|
2808 return Qnil;
|
|
2809 }
|
26742
936b39bd05b4
* editfns.c (Fdelete_and_extract_region): New function.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
2810
|
936b39bd05b4
* editfns.c (Fdelete_and_extract_region): New function.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
2811 DEFUN ("delete-and-extract-region", Fdelete_and_extract_region,
|
936b39bd05b4
* editfns.c (Fdelete_and_extract_region): New function.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
2812 Sdelete_and_extract_region, 2, 2, 0,
|
39988
|
2813 doc: /* Delete the text between START and END and return it. */)
|
|
2814 (start, end)
|
26742
936b39bd05b4
* editfns.c (Fdelete_and_extract_region): New function.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
2815 Lisp_Object start, end;
|
936b39bd05b4
* editfns.c (Fdelete_and_extract_region): New function.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
2816 {
|
936b39bd05b4
* editfns.c (Fdelete_and_extract_region): New function.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
2817 validate_region (&start, &end);
|
936b39bd05b4
* editfns.c (Fdelete_and_extract_region): New function.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
2818 return del_range_1 (XINT (start), XINT (end), 1, 1);
|
936b39bd05b4
* editfns.c (Fdelete_and_extract_region): New function.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
2819 }
|
305
|
2820
|
|
2821 DEFUN ("widen", Fwiden, Swiden, 0, 0, "",
|
39988
|
2822 doc: /* Remove restrictions (narrowing) from current buffer.
|
|
2823 This allows the buffer's full text to be seen and edited. */)
|
|
2824 ()
|
305
|
2825 {
|
19207
|
2826 if (BEG != BEGV || Z != ZV)
|
|
2827 current_buffer->clip_changed = 1;
|
305
|
2828 BEGV = BEG;
|
20558
|
2829 BEGV_BYTE = BEG_BYTE;
|
|
2830 SET_BUF_ZV_BOTH (current_buffer, Z, Z_BYTE);
|
330
|
2831 /* Changing the buffer bounds invalidates any recorded current column. */
|
|
2832 invalidate_current_column ();
|
305
|
2833 return Qnil;
|
|
2834 }
|
|
2835
|
|
2836 DEFUN ("narrow-to-region", Fnarrow_to_region, Snarrow_to_region, 2, 2, "r",
|
39988
|
2837 doc: /* Restrict editing in this buffer to the current region.
|
39966
|
2838 The rest of the text becomes temporarily invisible and untouchable
|
|
2839 but is not deleted; if you save the buffer in a file, the invisible
|
|
2840 text is included in the file. \\[widen] makes all visible again.
|
|
2841 See also `save-restriction'.
|
|
2842
|
|
2843 When calling from a program, pass two arguments; positions (integers
|
39988
|
2844 or markers) bounding the text that should remain visible. */)
|
|
2845 (start, end)
|
14071
59906ecd9b92
(Fchar_to_string, Fstring_to_char, Fgoto_char, Fencode_time, Finsert_char,
Erik Naggum <erik@naggum.no>
diff
changeset
|
2846 register Lisp_Object start, end;
|
305
|
2847 {
|
40656
|
2848 CHECK_NUMBER_COERCE_MARKER (start);
|
|
2849 CHECK_NUMBER_COERCE_MARKER (end);
|
305
|
2850
|
14071
59906ecd9b92
(Fchar_to_string, Fstring_to_char, Fgoto_char, Fencode_time, Finsert_char,
Erik Naggum <erik@naggum.no>
diff
changeset
|
2851 if (XINT (start) > XINT (end))
|
305
|
2852 {
|
10383
|
2853 Lisp_Object tem;
|
14071
59906ecd9b92
(Fchar_to_string, Fstring_to_char, Fgoto_char, Fencode_time, Finsert_char,
Erik Naggum <erik@naggum.no>
diff
changeset
|
2854 tem = start; start = end; end = tem;
|
305
|
2855 }
|
|
2856
|
14071
59906ecd9b92
(Fchar_to_string, Fstring_to_char, Fgoto_char, Fencode_time, Finsert_char,
Erik Naggum <erik@naggum.no>
diff
changeset
|
2857 if (!(BEG <= XINT (start) && XINT (start) <= XINT (end) && XINT (end) <= Z))
|
59906ecd9b92
(Fchar_to_string, Fstring_to_char, Fgoto_char, Fencode_time, Finsert_char,
Erik Naggum <erik@naggum.no>
diff
changeset
|
2858 args_out_of_range (start, end);
|
305
|
2859
|
19207
|
2860 if (BEGV != XFASTINT (start) || ZV != XFASTINT (end))
|
|
2861 current_buffer->clip_changed = 1;
|
|
2862
|
20558
|
2863 SET_BUF_BEGV (current_buffer, XFASTINT (start));
|
14071
59906ecd9b92
(Fchar_to_string, Fstring_to_char, Fgoto_char, Fencode_time, Finsert_char,
Erik Naggum <erik@naggum.no>
diff
changeset
|
2864 SET_BUF_ZV (current_buffer, XFASTINT (end));
|
16039
|
2865 if (PT < XFASTINT (start))
|
14071
59906ecd9b92
(Fchar_to_string, Fstring_to_char, Fgoto_char, Fencode_time, Finsert_char,
Erik Naggum <erik@naggum.no>
diff
changeset
|
2866 SET_PT (XFASTINT (start));
|
16039
|
2867 if (PT > XFASTINT (end))
|
14071
59906ecd9b92
(Fchar_to_string, Fstring_to_char, Fgoto_char, Fencode_time, Finsert_char,
Erik Naggum <erik@naggum.no>
diff
changeset
|
2868 SET_PT (XFASTINT (end));
|
330
|
2869 /* Changing the buffer bounds invalidates any recorded current column. */
|
|
2870 invalidate_current_column ();
|
305
|
2871 return Qnil;
|
|
2872 }
|
|
2873
|
|
2874 Lisp_Object
|
|
2875 save_restriction_save ()
|
|
2876 {
|
30931
|
2877 if (BEGV == BEG && ZV == Z)
|
|
2878 /* The common case that the buffer isn't narrowed.
|
|
2879 We return just the buffer object, which save_restriction_restore
|
|
2880 recognizes as meaning `no restriction'. */
|
|
2881 return Fcurrent_buffer ();
|
|
2882 else
|
|
2883 /* We have to save a restriction, so return a pair of markers, one
|
|
2884 for the beginning and one for the end. */
|
|
2885 {
|
|
2886 Lisp_Object beg, end;
|
|
2887
|
|
2888 beg = buildmark (BEGV, BEGV_BYTE);
|
|
2889 end = buildmark (ZV, ZV_BYTE);
|
|
2890
|
|
2891 /* END must move forward if text is inserted at its exact location. */
|
|
2892 XMARKER(end)->insertion_type = 1;
|
|
2893
|
|
2894 return Fcons (beg, end);
|
|
2895 }
|
305
|
2896 }
|
|
2897
|
|
2898 Lisp_Object
|
|
2899 save_restriction_restore (data)
|
|
2900 Lisp_Object data;
|
|
2901 {
|
30931
|
2902 if (CONSP (data))
|
|
2903 /* A pair of marks bounding a saved restriction. */
|
305
|
2904 {
|
30931
|
2905 struct Lisp_Marker *beg = XMARKER (XCAR (data));
|
|
2906 struct Lisp_Marker *end = XMARKER (XCDR (data));
|
|
2907 struct buffer *buf = beg->buffer; /* END should have the same buffer. */
|
|
2908
|
|
2909 if (beg->charpos != BUF_BEGV(buf) || end->charpos != BUF_ZV(buf))
|
|
2910 /* The restriction has changed from the saved one, so restore
|
|
2911 the saved restriction. */
|
|
2912 {
|
|
2913 int pt = BUF_PT (buf);
|
|
2914
|
|
2915 SET_BUF_BEGV_BOTH (buf, beg->charpos, beg->bytepos);
|
|
2916 SET_BUF_ZV_BOTH (buf, end->charpos, end->bytepos);
|
|
2917
|
|
2918 if (pt < beg->charpos || pt > end->charpos)
|
|
2919 /* The point is outside the new visible range, move it inside. */
|
|
2920 SET_BUF_PT_BOTH (buf,
|
|
2921 clip_to_bounds (beg->charpos, pt, end->charpos),
|
|
2922 clip_to_bounds (beg->bytepos, BUF_PT_BYTE(buf),
|
|
2923 end->bytepos));
|
|
2924
|
|
2925 buf->clip_changed = 1; /* Remember that the narrowing changed. */
|
|
2926 }
|
305
|
2927 }
|
30931
|
2928 else
|
|
2929 /* A buffer, which means that there was no old restriction. */
|
|
2930 {
|
|
2931 struct buffer *buf = XBUFFER (data);
|
|
2932
|
|
2933 if (BUF_BEGV(buf) != BUF_BEG(buf) || BUF_ZV(buf) != BUF_Z(buf))
|
|
2934 /* The buffer has been narrowed, get rid of the narrowing. */
|
|
2935 {
|
|
2936 SET_BUF_BEGV_BOTH (buf, BUF_BEG(buf), BUF_BEG_BYTE(buf));
|
|
2937 SET_BUF_ZV_BOTH (buf, BUF_Z(buf), BUF_Z_BYTE(buf));
|
|
2938
|
|
2939 buf->clip_changed = 1; /* Remember that the narrowing changed. */
|
|
2940 }
|
|
2941 }
|
305
|
2942
|
|
2943 return Qnil;
|
|
2944 }
|
|
2945
|
|
2946 DEFUN ("save-restriction", Fsave_restriction, Ssave_restriction, 0, UNEVALLED, 0,
|
39988
|
2947 doc: /* Execute BODY, saving and restoring current buffer's restrictions.
|
39966
|
2948 The buffer's restrictions make parts of the beginning and end invisible.
|
|
2949 (They are set up with `narrow-to-region' and eliminated with `widen'.)
|
|
2950 This special form, `save-restriction', saves the current buffer's restrictions
|
|
2951 when it is entered, and restores them when it is exited.
|
|
2952 So any `narrow-to-region' within BODY lasts only until the end of the form.
|
|
2953 The old restrictions settings are restored
|
|
2954 even in case of abnormal exit (throw or error).
|
|
2955
|
|
2956 The value returned is the value of the last form in BODY.
|
|
2957
|
|
2958 Note: if you are using both `save-excursion' and `save-restriction',
|
|
2959 use `save-excursion' outermost:
|
40140
|
2960 (save-excursion (save-restriction ...))
|
|
2961
|
|
2962 usage: (save-restriction &rest BODY) */)
|
39988
|
2963 (body)
|
305
|
2964 Lisp_Object body;
|
|
2965 {
|
|
2966 register Lisp_Object val;
|
|
2967 int count = specpdl_ptr - specpdl;
|
|
2968
|
|
2969 record_unwind_protect (save_restriction_restore, save_restriction_save ());
|
|
2970 val = Fprogn (body);
|
|
2971 return unbind_to (count, val);
|
|
2972 }
|
|
2973
|
38059
|
2974 /* Buffer for the most recent text displayed by Fmessage_box. */
|
5884
|
2975 static char *message_text;
|
|
2976
|
|
2977 /* Allocated length of that buffer. */
|
|
2978 static int message_length;
|
|
2979
|
305
|
2980 DEFUN ("message", Fmessage, Smessage, 1, MANY, 0,
|
39988
|
2981 doc: /* Print a one-line message at the bottom of the screen.
|
39966
|
2982 The first argument is a format control string, and the rest are data
|
|
2983 to be formatted under control of the string. See `format' for details.
|
|
2984
|
|
2985 If the first argument is nil, clear any existing message; let the
|
40131
|
2986 minibuffer contents show.
|
|
2987
|
|
2988 usage: (message STRING &rest ARGS) */)
|
39988
|
2989 (nargs, args)
|
305
|
2990 int nargs;
|
|
2991 Lisp_Object *args;
|
|
2992 {
|
1426
|
2993 if (NILP (args[0]))
|
1916
|
2994 {
|
|
2995 message (0);
|
|
2996 return Qnil;
|
|
2997 }
|
1426
|
2998 else
|
|
2999 {
|
|
3000 register Lisp_Object val;
|
|
3001 val = Fformat (nargs, args);
|
25018
|
3002 message3 (val, STRING_BYTES (XSTRING (val)), STRING_MULTIBYTE (val));
|
1426
|
3003 return val;
|
|
3004 }
|
305
|
3005 }
|
|
3006
|
8975
|
3007 DEFUN ("message-box", Fmessage_box, Smessage_box, 1, MANY, 0,
|
39988
|
3008 doc: /* Display a message, in a dialog box if possible.
|
39966
|
3009 If a dialog box is not available, use the echo area.
|
|
3010 The first argument is a format control string, and the rest are data
|
|
3011 to be formatted under control of the string. See `format' for details.
|
|
3012
|
|
3013 If the first argument is nil, clear any existing message; let the
|
40131
|
3014 minibuffer contents show.
|
|
3015
|
|
3016 usage: (message-box STRING &rest ARGS) */)
|
39988
|
3017 (nargs, args)
|
8975
|
3018 int nargs;
|
|
3019 Lisp_Object *args;
|
|
3020 {
|
|
3021 if (NILP (args[0]))
|
|
3022 {
|
|
3023 message (0);
|
|
3024 return Qnil;
|
|
3025 }
|
|
3026 else
|
|
3027 {
|
|
3028 register Lisp_Object val;
|
|
3029 val = Fformat (nargs, args);
|
13878
|
3030 #ifdef HAVE_MENUS
|
38059
|
3031 /* The MS-DOS frames support popup menus even though they are
|
|
3032 not FRAME_WINDOW_P. */
|
|
3033 if (FRAME_WINDOW_P (XFRAME (selected_frame))
|
|
3034 || FRAME_MSDOS_P (XFRAME (selected_frame)))
|
8975
|
3035 {
|
|
3036 Lisp_Object pane, menu, obj;
|
|
3037 struct gcpro gcpro1;
|
|
3038 pane = Fcons (Fcons (build_string ("OK"), Qt), Qnil);
|
|
3039 GCPRO1 (pane);
|
|
3040 menu = Fcons (val, pane);
|
|
3041 obj = Fx_popup_dialog (Qt, menu);
|
|
3042 UNGCPRO;
|
|
3043 return val;
|
|
3044 }
|
38059
|
3045 #endif /* HAVE_MENUS */
|
8975
|
3046 /* Copy the data so that it won't move when we GC. */
|
|
3047 if (! message_text)
|
|
3048 {
|
|
3049 message_text = (char *)xmalloc (80);
|
|
3050 message_length = 80;
|
|
3051 }
|
21245
|
3052 if (STRING_BYTES (XSTRING (val)) > message_length)
|
8975
|
3053 {
|
21245
|
3054 message_length = STRING_BYTES (XSTRING (val));
|
8975
|
3055 message_text = (char *)xrealloc (message_text, message_length);
|
|
3056 }
|
21245
|
3057 bcopy (XSTRING (val)->data, message_text, STRING_BYTES (XSTRING (val)));
|
21358
|
3058 message2 (message_text, STRING_BYTES (XSTRING (val)),
|
|
3059 STRING_MULTIBYTE (val));
|
8975
|
3060 return val;
|
|
3061 }
|
|
3062 }
|
13878
|
3063 #ifdef HAVE_MENUS
|
8975
|
3064 extern Lisp_Object last_nonmenu_event;
|
|
3065 #endif
|
13878
|
3066
|
8975
|
3067 DEFUN ("message-or-box", Fmessage_or_box, Smessage_or_box, 1, MANY, 0,
|
39988
|
3068 doc: /* Display a message in a dialog box or in the echo area.
|
39966
|
3069 If this command was invoked with the mouse, use a dialog box if
|
|
3070 `use-dialog-box' is non-nil.
|
|
3071 Otherwise, use the echo area.
|
|
3072 The first argument is a format control string, and the rest are data
|
|
3073 to be formatted under control of the string. See `format' for details.
|
|
3074
|
|
3075 If the first argument is nil, clear any existing message; let the
|
40131
|
3076 minibuffer contents show.
|
|
3077
|
|
3078 usage: (message-or-box STRING &rest ARGS) */)
|
39988
|
3079 (nargs, args)
|
8975
|
3080 int nargs;
|
|
3081 Lisp_Object *args;
|
|
3082 {
|
13878
|
3083 #ifdef HAVE_MENUS
|
26699
|
3084 if ((NILP (last_nonmenu_event) || CONSP (last_nonmenu_event))
|
28470
93996c44b23a
* editfns.c (text_property_stickiness, Fmessage_or_box): Use NILP to test
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
3085 && use_dialog_box)
|
8981
|
3086 return Fmessage_box (nargs, args);
|
8975
|
3087 #endif
|
|
3088 return Fmessage (nargs, args);
|
|
3089 }
|
|
3090
|
18937
|
3091 DEFUN ("current-message", Fcurrent_message, Scurrent_message, 0, 0, 0,
|
39988
|
3092 doc: /* Return the string currently displayed in the echo area, or nil if none. */)
|
|
3093 ()
|
18937
|
3094 {
|
25346
|
3095 return current_message ();
|
18937
|
3096 }
|
|
3097
|
25815
|
3098
|
41062
|
3099 DEFUN ("propertize", Fpropertize, Spropertize, 1, MANY, 0,
|
39988
|
3100 doc: /* Return a copy of STRING with text properties added.
|
39966
|
3101 First argument is the string to copy.
|
|
3102 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
|
40131
|
3103 properties to add to the result.
|
|
3104 usage: (propertize STRING &rest PROPERTIES) */)
|
39988
|
3105 (nargs, args)
|
25815
|
3106 int nargs;
|
|
3107 Lisp_Object *args;
|
|
3108 {
|
|
3109 Lisp_Object properties, string;
|
|
3110 struct gcpro gcpro1, gcpro2;
|
|
3111 int i;
|
|
3112
|
|
3113 /* Number of args must be odd. */
|
41062
|
3114 if ((nargs & 1) == 0 || nargs < 1)
|
25815
|
3115 error ("Wrong number of arguments");
|
|
3116
|
|
3117 properties = string = Qnil;
|
|
3118 GCPRO2 (properties, string);
|
30480
|
3119
|
25815
|
3120 /* First argument must be a string. */
|
40656
|
3121 CHECK_STRING (args[0]);
|
25815
|
3122 string = Fcopy_sequence (args[0]);
|
|
3123
|
|
3124 for (i = 1; i < nargs; i += 2)
|
|
3125 {
|
40656
|
3126 CHECK_SYMBOL (args[i]);
|
25815
|
3127 properties = Fcons (args[i], Fcons (args[i + 1], properties));
|
|
3128 }
|
|
3129
|
|
3130 Fadd_text_properties (make_number (0),
|
|
3131 make_number (XSTRING (string)->size),
|
|
3132 properties, string);
|
|
3133 RETURN_UNGCPRO (string);
|
|
3134 }
|
|
3135
|
|
3136
|
20606
|
3137 /* Number of bytes that STRING will occupy when put into the result.
|
|
3138 MULTIBYTE is nonzero if the result should be multibyte. */
|
|
3139
|
|
3140 #define CONVERTED_BYTE_SIZE(MULTIBYTE, STRING) \
|
|
3141 (((MULTIBYTE) && ! STRING_MULTIBYTE (STRING)) \
|
20804
|
3142 ? count_size_as_multibyte (XSTRING (STRING)->data, \
|
21245
|
3143 STRING_BYTES (XSTRING (STRING))) \
|
|
3144 : STRING_BYTES (XSTRING (STRING)))
|
20606
|
3145
|
305
|
3146 DEFUN ("format", Fformat, Sformat, 1, MANY, 0,
|
39988
|
3147 doc: /* Format a string out of a control-string and arguments.
|
39966
|
3148 The first argument is a control string.
|
|
3149 The other arguments are substituted into it to make the result, a string.
|
|
3150 It may contain %-sequences meaning to substitute the next argument.
|
|
3151 %s means print a string argument. Actually, prints any object, with `princ'.
|
|
3152 %d means print as number in decimal (%o octal, %x hex).
|
|
3153 %X is like %x, but uses upper case.
|
|
3154 %e means print a number in exponential notation.
|
|
3155 %f means print a number in decimal-point notation.
|
|
3156 %g means print a number in exponential notation
|
|
3157 or decimal-point notation, whichever uses fewer characters.
|
|
3158 %c means print a number as a single character.
|
|
3159 %S means print any object as an s-expression (using `prin1').
|
|
3160 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.
|
40131
|
3161 Use %% to put a single % into the output.
|
|
3162
|
|
3163 usage: (format STRING &rest OBJECTS) */)
|
39988
|
3164 (nargs, args)
|
305
|
3165 int nargs;
|
|
3166 register Lisp_Object *args;
|
|
3167 {
|
|
3168 register int n; /* The number of the next arg to substitute */
|
20826
|
3169 register int total; /* An estimate of the final length */
|
20606
|
3170 char *buf, *p;
|
305
|
3171 register unsigned char *format, *end;
|
25782
|
3172 int nchars;
|
20606
|
3173 /* Nonzero if the output should be a multibyte string,
|
|
3174 which is true if any of the inputs is one. */
|
|
3175 int multibyte = 0;
|
22698
|
3176 /* When we make a multibyte string, we must pay attention to the
|
|
3177 byte combining problem, i.e., a byte may be combined with a
|
|
3178 multibyte charcter of the previous string. This flag tells if we
|
|
3179 must consider such a situation or not. */
|
|
3180 int maybe_combine_byte;
|
20606
|
3181 unsigned char *this_format;
|
20826
|
3182 int longest_format;
|
20804
|
3183 Lisp_Object val;
|
25018
|
3184 struct info
|
|
3185 {
|
|
3186 int start, end;
|
|
3187 } *info = 0;
|
20606
|
3188
|
305
|
3189 /* It should not be necessary to GCPRO ARGS, because
|
|
3190 the caller in the interpreter should take care of that. */
|
|
3191
|
20826
|
3192 /* Try to determine whether the result should be multibyte.
|
|
3193 This is not always right; sometimes the result needs to be multibyte
|
|
3194 because of an object that we will pass through prin1,
|
|
3195 and in that case, we won't know it here. */
|
20606
|
3196 for (n = 0; n < nargs; n++)
|
|
3197 if (STRINGP (args[n]) && STRING_MULTIBYTE (args[n]))
|
|
3198 multibyte = 1;
|
|
3199
|
40656
|
3200 CHECK_STRING (args[0]);
|
20826
|
3201
|
|
3202 /* If we start out planning a unibyte result,
|
|
3203 and later find it has to be multibyte, we jump back to retry. */
|
|
3204 retry:
|
|
3205
|
305
|
3206 format = XSTRING (args[0])->data;
|
21245
|
3207 end = format + STRING_BYTES (XSTRING (args[0]));
|
20826
|
3208 longest_format = 0;
|
20606
|
3209
|
|
3210 /* Make room in result for all the non-%-codes in the control string. */
|
20826
|
3211 total = 5 + CONVERTED_BYTE_SIZE (multibyte, args[0]);
|
20606
|
3212
|
|
3213 /* Add to TOTAL enough space to hold the converted arguments. */
|
305
|
3214
|
|
3215 n = 0;
|
|
3216 while (format != end)
|
|
3217 if (*format++ == '%')
|
|
3218 {
|
34566
|
3219 int thissize = 0;
|
42484
|
3220 int actual_width = 0;
|
20606
|
3221 unsigned char *this_format_start = format - 1;
|
34566
|
3222 int field_width, precision;
|
|
3223
|
|
3224 /* General format specifications look like
|
|
3225
|
|
3226 '%' [flags] [field-width] [precision] format
|
|
3227
|
|
3228 where
|
|
3229
|
|
3230 flags ::= [#-* 0]+
|
|
3231 field-width ::= [0-9]+
|
|
3232 precision ::= '.' [0-9]*
|
|
3233
|
|
3234 If a field-width is specified, it specifies to which width
|
|
3235 the output should be padded with blanks, iff the output
|
|
3236 string is shorter than field-width.
|
|
3237
|
|
3238 if precision is specified, it specifies the number of
|
|
3239 digits to print after the '.' for floats, or the max.
|
|
3240 number of chars to print from a string. */
|
|
3241
|
|
3242 precision = field_width = 0;
|
|
3243
|
|
3244 while (index ("-*# 0", *format))
|
|
3245 ++format;
|
|
3246
|
|
3247 if (*format >= '0' && *format <= '9')
|
|
3248 {
|
|
3249 for (field_width = 0; *format >= '0' && *format <= '9'; ++format)
|
|
3250 field_width = 10 * field_width + *format - '0';
|
|
3251 }
|
|
3252
|
|
3253 if (*format == '.')
|
|
3254 {
|
|
3255 ++format;
|
|
3256 for (precision = 0; *format >= '0' && *format <= '9'; ++format)
|
|
3257 precision = 10 * precision + *format - '0';
|
|
3258 }
|
305
|
3259
|
20606
|
3260 if (format - this_format_start + 1 > longest_format)
|
|
3261 longest_format = format - this_format_start + 1;
|
|
3262
|
23197
|
3263 if (format == end)
|
|
3264 error ("Format string ends in middle of format specifier");
|
305
|
3265 if (*format == '%')
|
|
3266 format++;
|
|
3267 else if (++n >= nargs)
|
12831
|
3268 error ("Not enough arguments for format string");
|
305
|
3269 else if (*format == 'S')
|
|
3270 {
|
|
3271 /* For `S', prin1 the argument and then treat like a string. */
|
|
3272 register Lisp_Object tem;
|
|
3273 tem = Fprin1_to_string (args[n], Qnil);
|
20826
|
3274 if (STRING_MULTIBYTE (tem) && ! multibyte)
|
|
3275 {
|
|
3276 multibyte = 1;
|
|
3277 goto retry;
|
|
3278 }
|
305
|
3279 args[n] = tem;
|
|
3280 goto string;
|
|
3281 }
|
9163
41fe5f636879
(lisp_time_argument, Finsert, Finsert_and_inherit, Finsert_before_markers,
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
3282 else if (SYMBOLP (args[n]))
|
305
|
3283 {
|
28470
93996c44b23a
* editfns.c (text_property_stickiness, Fmessage_or_box): Use NILP to test
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
3284 /* Use a temp var to avoid problems when ENABLE_CHECKING
|
93996c44b23a
* editfns.c (text_property_stickiness, Fmessage_or_box): Use NILP to test
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
3285 is turned on. */
|
93996c44b23a
* editfns.c (text_property_stickiness, Fmessage_or_box): Use NILP to test
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
3286 struct Lisp_String *t = XSYMBOL (args[n])->name;
|
93996c44b23a
* editfns.c (text_property_stickiness, Fmessage_or_box): Use NILP to test
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
3287 XSETSTRING (args[n], t);
|
20861
|
3288 if (STRING_MULTIBYTE (args[n]) && ! multibyte)
|
|
3289 {
|
|
3290 multibyte = 1;
|
|
3291 goto retry;
|
|
3292 }
|
305
|
3293 goto string;
|
|
3294 }
|
9163
41fe5f636879
(lisp_time_argument, Finsert, Finsert_and_inherit, Finsert_before_markers,
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
3295 else if (STRINGP (args[n]))
|
305
|
3296 {
|
|
3297 string:
|
6528
|
3298 if (*format != 's' && *format != 'S')
|
23197
|
3299 error ("Format specifier doesn't match argument type");
|
20606
|
3300 thissize = CONVERTED_BYTE_SIZE (multibyte, args[n]);
|
42484
|
3301 actual_width = lisp_string_width (args[n], -1, NULL, NULL);
|
305
|
3302 }
|
|
3303 /* Would get MPV otherwise, since Lisp_Int's `point' to low memory. */
|
9163
41fe5f636879
(lisp_time_argument, Finsert, Finsert_and_inherit, Finsert_before_markers,
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
3304 else if (INTEGERP (args[n]) && *format != 's')
|
305
|
3305 {
|
3591
|
3306 /* The following loop assumes the Lisp type indicates
|
305
|
3307 the proper way to pass the argument.
|
|
3308 So make sure we have a flonum if the argument should
|
|
3309 be a double. */
|
|
3310 if (*format == 'e' || *format == 'f' || *format == 'g')
|
|
3311 args[n] = Ffloat (args[n]);
|
23326
|
3312 else
|
|
3313 if (*format != 'd' && *format != 'o' && *format != 'x'
|
24505
|
3314 && *format != 'i' && *format != 'X' && *format != 'c')
|
23326
|
3315 error ("Invalid format operation %%%c", *format);
|
|
3316
|
30480
|
3317 thissize = 30;
|
21225
|
3318 if (*format == 'c'
|
|
3319 && (! SINGLE_BYTE_CHAR_P (XINT (args[n]))
|
|
3320 || XINT (args[n]) == 0))
|
21064
|
3321 {
|
|
3322 if (! multibyte)
|
|
3323 {
|
|
3324 multibyte = 1;
|
|
3325 goto retry;
|
|
3326 }
|
|
3327 args[n] = Fchar_to_string (args[n]);
|
21245
|
3328 thissize = STRING_BYTES (XSTRING (args[n]));
|
21064
|
3329 }
|
305
|
3330 }
|
9163
41fe5f636879
(lisp_time_argument, Finsert, Finsert_and_inherit, Finsert_before_markers,
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
3331 else if (FLOATP (args[n]) && *format != 's')
|
305
|
3332 {
|
|
3333 if (! (*format == 'e' || *format == 'f' || *format == 'g'))
|
18605
|
3334 args[n] = Ftruncate (args[n], Qnil);
|
34566
|
3335
|
|
3336 /* Note that we're using sprintf to print floats,
|
|
3337 so we have to take into account what that function
|
|
3338 prints. */
|
38519
|
3339 thissize = MAX_10_EXP + 100 + precision;
|
305
|
3340 }
|
|
3341 else
|
|
3342 {
|
|
3343 /* Anything but a string, convert to a string using princ. */
|
|
3344 register Lisp_Object tem;
|
|
3345 tem = Fprin1_to_string (args[n], Qt);
|
21052
|
3346 if (STRING_MULTIBYTE (tem) & ! multibyte)
|
20826
|
3347 {
|
|
3348 multibyte = 1;
|
|
3349 goto retry;
|
|
3350 }
|
305
|
3351 args[n] = tem;
|
|
3352 goto string;
|
|
3353 }
|
30480
|
3354
|
42484
|
3355 thissize += max (0, field_width - actual_width);
|
20606
|
3356 total += thissize + 4;
|
305
|
3357 }
|
|
3358
|
20826
|
3359 /* Now we can no longer jump to retry.
|
|
3360 TOTAL and LONGEST_FORMAT are known for certain. */
|
|
3361
|
20606
|
3362 this_format = (unsigned char *) alloca (longest_format + 1);
|
|
3363
|
|
3364 /* Allocate the space for the result.
|
|
3365 Note that TOTAL is an overestimate. */
|
|
3366 if (total < 1000)
|
21914
|
3367 buf = (char *) alloca (total + 1);
|
20606
|
3368 else
|
21914
|
3369 buf = (char *) xmalloc (total + 1);
|
4019
|
3370
|
20606
|
3371 p = buf;
|
|
3372 nchars = 0;
|
|
3373 n = 0;
|
|
3374
|
|
3375 /* Scan the format and store result in BUF. */
|
|
3376 format = XSTRING (args[0])->data;
|
22698
|
3377 maybe_combine_byte = 0;
|
20606
|
3378 while (format != end)
|
|
3379 {
|
|
3380 if (*format == '%')
|
|
3381 {
|
|
3382 int minlen;
|
21225
|
3383 int negative = 0;
|
20606
|
3384 unsigned char *this_format_start = format;
|
305
|
3385
|
20606
|
3386 format++;
|
|
3387
|
|
3388 /* Process a numeric arg and skip it. */
|
|
3389 minlen = atoi (format);
|
|
3390 if (minlen < 0)
|
21225
|
3391 minlen = - minlen, negative = 1;
|
20606
|
3392
|
|
3393 while ((*format >= '0' && *format <= '9')
|
|
3394 || *format == '-' || *format == ' ' || *format == '.')
|
|
3395 format++;
|
|
3396
|
|
3397 if (*format++ == '%')
|
|
3398 {
|
|
3399 *p++ = '%';
|
|
3400 nchars++;
|
|
3401 continue;
|
|
3402 }
|
|
3403
|
|
3404 ++n;
|
|
3405
|
|
3406 if (STRINGP (args[n]))
|
|
3407 {
|
35461
|
3408 int padding, nbytes, start, end;
|
35440
|
3409 int width = lisp_string_width (args[n], -1, NULL, NULL);
|
21225
|
3410
|
|
3411 /* If spec requires it, pad on right with spaces. */
|
|
3412 padding = minlen - width;
|
|
3413 if (! negative)
|
|
3414 while (padding-- > 0)
|
|
3415 {
|
|
3416 *p++ = ' ';
|
35461
|
3417 ++nchars;
|
21225
|
3418 }
|
305
|
3419
|
35461
|
3420 start = nchars;
|
|
3421
|
22698
|
3422 if (p > buf
|
|
3423 && multibyte
|
22712
|
3424 && !ASCII_BYTE_P (*((unsigned char *) p - 1))
|
22698
|
3425 && STRING_MULTIBYTE (args[n])
|
22712
|
3426 && !CHAR_HEAD_P (XSTRING (args[n])->data[0]))
|
22698
|
3427 maybe_combine_byte = 1;
|
20606
|
3428 nbytes = copy_text (XSTRING (args[n])->data, p,
|
21245
|
3429 STRING_BYTES (XSTRING (args[n])),
|
20606
|
3430 STRING_MULTIBYTE (args[n]), multibyte);
|
|
3431 p += nbytes;
|
|
3432 nchars += XSTRING (args[n])->size;
|
35461
|
3433 end = nchars;
|
305
|
3434
|
21225
|
3435 if (negative)
|
|
3436 while (padding-- > 0)
|
|
3437 {
|
|
3438 *p++ = ' ';
|
|
3439 nchars++;
|
|
3440 }
|
25018
|
3441
|
|
3442 /* If this argument has text properties, record where
|
|
3443 in the result string it appears. */
|
|
3444 if (XSTRING (args[n])->intervals)
|
|
3445 {
|
|
3446 if (!info)
|
|
3447 {
|
|
3448 int nbytes = nargs * sizeof *info;
|
|
3449 info = (struct info *) alloca (nbytes);
|
|
3450 bzero (info, nbytes);
|
|
3451 }
|
30480
|
3452
|
25018
|
3453 info[n].start = start;
|
35461
|
3454 info[n].end = end;
|
25018
|
3455 }
|
20606
|
3456 }
|
|
3457 else if (INTEGERP (args[n]) || FLOATP (args[n]))
|
|
3458 {
|
|
3459 int this_nchars;
|
|
3460
|
|
3461 bcopy (this_format_start, this_format,
|
|
3462 format - this_format_start);
|
|
3463 this_format[format - this_format_start] = 0;
|
|
3464
|
21202
|
3465 if (INTEGERP (args[n]))
|
|
3466 sprintf (p, this_format, XINT (args[n]));
|
|
3467 else
|
25662
0a7261c1d487
Use XCAR, XCDR, and XFLOAT_DATA instead of explicit member access.
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
3468 sprintf (p, this_format, XFLOAT_DATA (args[n]));
|
12603
|
3469
|
22698
|
3470 if (p > buf
|
|
3471 && multibyte
|
22712
|
3472 && !ASCII_BYTE_P (*((unsigned char *) p - 1))
|
|
3473 && !CHAR_HEAD_P (*((unsigned char *) p)))
|
22698
|
3474 maybe_combine_byte = 1;
|
20606
|
3475 this_nchars = strlen (p);
|
29008
|
3476 if (multibyte)
|
|
3477 p += str_to_multibyte (p, buf + total - p, this_nchars);
|
|
3478 else
|
|
3479 p += this_nchars;
|
20606
|
3480 nchars += this_nchars;
|
|
3481 }
|
|
3482 }
|
20861
|
3483 else if (STRING_MULTIBYTE (args[0]))
|
|
3484 {
|
|
3485 /* Copy a whole multibyte character. */
|
22698
|
3486 if (p > buf
|
|
3487 && multibyte
|
22712
|
3488 && !ASCII_BYTE_P (*((unsigned char *) p - 1))
|
|
3489 && !CHAR_HEAD_P (*format))
|
22698
|
3490 maybe_combine_byte = 1;
|
20861
|
3491 *p++ = *format++;
|
|
3492 while (! CHAR_HEAD_P (*format)) *p++ = *format++;
|
|
3493 nchars++;
|
|
3494 }
|
|
3495 else if (multibyte)
|
20606
|
3496 {
|
|
3497 /* Convert a single-byte character to multibyte. */
|
|
3498 int len = copy_text (format, p, 1, 0, 1);
|
305
|
3499
|
20606
|
3500 p += len;
|
|
3501 format++;
|
|
3502 nchars++;
|
|
3503 }
|
|
3504 else
|
|
3505 *p++ = *format++, nchars++;
|
|
3506 }
|
305
|
3507
|
34566
|
3508 if (p > buf + total + 1)
|
|
3509 abort ();
|
|
3510
|
22698
|
3511 if (maybe_combine_byte)
|
|
3512 nchars = multibyte_chars_in_text (buf, p - buf);
|
21257
|
3513 val = make_specified_string (buf, nchars, p - buf, multibyte);
|
20804
|
3514
|
20606
|
3515 /* If we allocated BUF with malloc, free it too. */
|
|
3516 if (total >= 1000)
|
|
3517 xfree (buf);
|
305
|
3518
|
25018
|
3519 /* If the format string has text properties, or any of the string
|
|
3520 arguments has text properties, set up text properties of the
|
|
3521 result string. */
|
30480
|
3522
|
25018
|
3523 if (XSTRING (args[0])->intervals || info)
|
|
3524 {
|
|
3525 Lisp_Object len, new_len, props;
|
|
3526 struct gcpro gcpro1;
|
30480
|
3527
|
25018
|
3528 /* Add text properties from the format string. */
|
|
3529 len = make_number (XSTRING (args[0])->size);
|
|
3530 props = text_property_list (args[0], make_number (0), len, Qnil);
|
|
3531 GCPRO1 (props);
|
30480
|
3532
|
25018
|
3533 if (CONSP (props))
|
|
3534 {
|
|
3535 new_len = make_number (XSTRING (val)->size);
|
|
3536 extend_property_ranges (props, len, new_len);
|
|
3537 add_text_properties_from_list (val, props, make_number (0));
|
|
3538 }
|
|
3539
|
|
3540 /* Add text properties from arguments. */
|
|
3541 if (info)
|
|
3542 for (n = 1; n < nargs; ++n)
|
|
3543 if (info[n].end)
|
|
3544 {
|
|
3545 len = make_number (XSTRING (args[n])->size);
|
|
3546 new_len = make_number (info[n].end - info[n].start);
|
|
3547 props = text_property_list (args[n], make_number (0), len, Qnil);
|
|
3548 extend_property_ranges (props, len, new_len);
|
30023
|
3549 /* If successive arguments have properites, be sure that
|
|
3550 the value of `composition' property be the copy. */
|
|
3551 if (n > 1 && info[n - 1].end)
|
|
3552 make_composition_value_copy (props);
|
25018
|
3553 add_text_properties_from_list (val, props,
|
|
3554 make_number (info[n].start));
|
|
3555 }
|
|
3556
|
|
3557 UNGCPRO;
|
|
3558 }
|
|
3559
|
20804
|
3560 return val;
|
305
|
3561 }
|
|
3562
|
25815
|
3563
|
305
|
3564 /* VARARGS 1 */
|
|
3565 Lisp_Object
|
|
3566 #ifdef NO_ARG_ARRAY
|
|
3567 format1 (string1, arg0, arg1, arg2, arg3, arg4)
|
8824
|
3568 EMACS_INT arg0, arg1, arg2, arg3, arg4;
|
305
|
3569 #else
|
|
3570 format1 (string1)
|
|
3571 #endif
|
|
3572 char *string1;
|
|
3573 {
|
|
3574 char buf[100];
|
|
3575 #ifdef NO_ARG_ARRAY
|
8824
|
3576 EMACS_INT args[5];
|
305
|
3577 args[0] = arg0;
|
|
3578 args[1] = arg1;
|
|
3579 args[2] = arg2;
|
|
3580 args[3] = arg3;
|
|
3581 args[4] = arg4;
|
21035
|
3582 doprnt (buf, sizeof buf, string1, (char *)0, 5, (char **) args);
|
305
|
3583 #else
|
11912
|
3584 doprnt (buf, sizeof buf, string1, (char *)0, 5, &string1 + 1);
|
305
|
3585 #endif
|
|
3586 return build_string (buf);
|
|
3587 }
|
|
3588
|
|
3589 DEFUN ("char-equal", Fchar_equal, Schar_equal, 2, 2, 0,
|
39988
|
3590 doc: /* Return t if two characters match, optionally ignoring case.
|
39966
|
3591 Both arguments must be characters (i.e. integers).
|
39988
|
3592 Case is ignored if `case-fold-search' is non-nil in the current buffer. */)
|
|
3593 (c1, c2)
|
305
|
3594 register Lisp_Object c1, c2;
|
|
3595 {
|
20688
|
3596 int i1, i2;
|
40656
|
3597 CHECK_NUMBER (c1);
|
|
3598 CHECK_NUMBER (c2);
|
305
|
3599
|
20688
|
3600 if (XINT (c1) == XINT (c2))
|
305
|
3601 return Qt;
|
20688
|
3602 if (NILP (current_buffer->case_fold_search))
|
|
3603 return Qnil;
|
|
3604
|
|
3605 /* Do these in separate statements,
|
|
3606 then compare the variables.
|
|
3607 because of the way DOWNCASE uses temp variables. */
|
|
3608 i1 = DOWNCASE (XFASTINT (c1));
|
|
3609 i2 = DOWNCASE (XFASTINT (c2));
|
|
3610 return (i1 == i2 ? Qt : Qnil);
|
305
|
3611 }
|
7207
|
3612
|
|
3613 /* Transpose the markers in two regions of the current buffer, and
|
|
3614 adjust the ones between them if necessary (i.e.: if the regions
|
|
3615 differ in size).
|
|
3616
|
20558
|
3617 START1, END1 are the character positions of the first region.
|
|
3618 START1_BYTE, END1_BYTE are the byte positions.
|
|
3619 START2, END2 are the character positions of the second region.
|
|
3620 START2_BYTE, END2_BYTE are the byte positions.
|
|
3621
|
7207
|
3622 Traverses the entire marker list of the buffer to do so, adding an
|
|
3623 appropriate amount to some, subtracting from some, and leaving the
|
|
3624 rest untouched. Most of this is copied from adjust_markers in insdel.c.
|
30480
|
3625
|
20558
|
3626 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
|
7207
|
3627
|
31016
|
3628 static void
|
20558
|
3629 transpose_markers (start1, end1, start2, end2,
|
|
3630 start1_byte, end1_byte, start2_byte, end2_byte)
|
7207
|
3631 register int start1, end1, start2, end2;
|
20558
|
3632 register int start1_byte, end1_byte, start2_byte, end2_byte;
|
7207
|
3633 {
|
20558
|
3634 register int amt1, amt1_byte, amt2, amt2_byte, diff, diff_byte, mpos;
|
7207
|
3635 register Lisp_Object marker;
|
|
3636
|
7862
|
3637 /* Update point as if it were a marker. */
|
7519
|
3638 if (PT < start1)
|
|
3639 ;
|
|
3640 else if (PT < end1)
|
20558
|
3641 TEMP_SET_PT_BOTH (PT + (end2 - end1),
|
|
3642 PT_BYTE + (end2_byte - end1_byte));
|
7519
|
3643 else if (PT < start2)
|
20558
|
3644 TEMP_SET_PT_BOTH (PT + (end2 - start2) - (end1 - start1),
|
|
3645 (PT_BYTE + (end2_byte - start2_byte)
|
|
3646 - (end1_byte - start1_byte)));
|
7519
|
3647 else if (PT < end2)
|
20558
|
3648 TEMP_SET_PT_BOTH (PT - (start2 - start1),
|
|
3649 PT_BYTE - (start2_byte - start1_byte));
|
7519
|
3650
|
7862
|
3651 /* We used to adjust the endpoints here to account for the gap, but that
|
|
3652 isn't good enough. Even if we assume the caller has tried to move the
|
|
3653 gap out of our way, it might still be at start1 exactly, for example;
|
|
3654 and that places it `inside' the interval, for our purposes. The amount
|
|
3655 of adjustment is nontrivial if there's a `denormalized' marker whose
|
|
3656 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
|
|
3657 the dirty work to Fmarker_position, below. */
|
7207
|
3658
|
|
3659 /* The difference between the region's lengths */
|
|
3660 diff = (end2 - start2) - (end1 - start1);
|
20558
|
3661 diff_byte = (end2_byte - start2_byte) - (end1_byte - start1_byte);
|
30480
|
3662
|
7207
|
3663 /* For shifting each marker in a region by the length of the other
|
20558
|
3664 region plus the distance between the regions. */
|
7207
|
3665 amt1 = (end2 - start2) + (start2 - end1);
|
|
3666 amt2 = (end1 - start1) + (start2 - end1);
|
20558
|
3667 amt1_byte = (end2_byte - start2_byte) + (start2_byte - end1_byte);
|
|
3668 amt2_byte = (end1_byte - start1_byte) + (start2_byte - end1_byte);
|
7207
|
3669
|
10308
|
3670 for (marker = BUF_MARKERS (current_buffer); !NILP (marker);
|
7862
|
3671 marker = XMARKER (marker)->chain)
|
7207
|
3672 {
|
20558
|
3673 mpos = marker_byte_position (marker);
|
|
3674 if (mpos >= start1_byte && mpos < end2_byte)
|
|
3675 {
|
|
3676 if (mpos < end1_byte)
|
|
3677 mpos += amt1_byte;
|
|
3678 else if (mpos < start2_byte)
|
|
3679 mpos += diff_byte;
|
|
3680 else
|
|
3681 mpos -= amt2_byte;
|
20564
|
3682 XMARKER (marker)->bytepos = mpos;
|
20558
|
3683 }
|
|
3684 mpos = XMARKER (marker)->charpos;
|
7862
|
3685 if (mpos >= start1 && mpos < end2)
|
|
3686 {
|
|
3687 if (mpos < end1)
|
|
3688 mpos += amt1;
|
|
3689 else if (mpos < start2)
|
|
3690 mpos += diff;
|
|
3691 else
|
|
3692 mpos -= amt2;
|
|
3693 }
|
20558
|
3694 XMARKER (marker)->charpos = mpos;
|
7207
|
3695 }
|
|
3696 }
|
|
3697
|
|
3698 DEFUN ("transpose-regions", Ftranspose_regions, Stranspose_regions, 4, 5, 0,
|
39988
|
3699 doc: /* Transpose region START1 to END1 with START2 to END2.
|
39966
|
3700 The regions may not be overlapping, because the size of the buffer is
|
|
3701 never changed in a transposition.
|
|
3702
|
|
3703 Optional fifth arg LEAVE_MARKERS, if non-nil, means don't update
|
|
3704 any markers that happen to be located in the regions.
|
|
3705
|
39988
|
3706 Transposing beyond buffer boundaries is an error. */)
|
|
3707 (startr1, endr1, startr2, endr2, leave_markers)
|
7207
|
3708 Lisp_Object startr1, endr1, startr2, endr2, leave_markers;
|
|
3709 {
|
20558
|
3710 register int start1, end1, start2, end2;
|
|
3711 int start1_byte, start2_byte, len1_byte, len2_byte;
|
|
3712 int gap, len1, len_mid, len2;
|
7250
|
3713 unsigned char *start1_addr, *start2_addr, *temp;
|
7207
|
3714
|
|
3715 INTERVAL cur_intv, tmp_interval1, tmp_interval_mid, tmp_interval2;
|
10308
|
3716 cur_intv = BUF_INTERVALS (current_buffer);
|
7207
|
3717
|
|
3718 validate_region (&startr1, &endr1);
|
|
3719 validate_region (&startr2, &endr2);
|
|
3720
|
|
3721 start1 = XFASTINT (startr1);
|
|
3722 end1 = XFASTINT (endr1);
|
|
3723 start2 = XFASTINT (startr2);
|
|
3724 end2 = XFASTINT (endr2);
|
|
3725 gap = GPT;
|
|
3726
|
|
3727 /* Swap the regions if they're reversed. */
|
|
3728 if (start2 < end1)
|
|
3729 {
|
|
3730 register int glumph = start1;
|
|
3731 start1 = start2;
|
|
3732 start2 = glumph;
|
|
3733 glumph = end1;
|
|
3734 end1 = end2;
|
|
3735 end2 = glumph;
|
|
3736 }
|
|
3737
|
|
3738 len1 = end1 - start1;
|
|
3739 len2 = end2 - start2;
|
|
3740
|
|
3741 if (start2 < end1)
|
21245
|
3742 error ("Transposed regions overlap");
|
7207
|
3743 else if (start1 == end1 || start2 == end2)
|
21245
|
3744 error ("Transposed region has length 0");
|
7207
|
3745
|
|
3746 /* The possibilities are:
|
|
3747 1. Adjacent (contiguous) regions, or separate but equal regions
|
|
3748 (no, really equal, in this case!), or
|
|
3749 2. Separate regions of unequal size.
|
30480
|
3750
|
7207
|
3751 The worst case is usually No. 2. It means that (aside from
|
|
3752 potential need for getting the gap out of the way), there also
|
|
3753 needs to be a shifting of the text between the two regions. So
|
|
3754 if they are spread far apart, we are that much slower... sigh. */
|
|
3755
|
|
3756 /* It must be pointed out that the really studly thing to do would
|
|
3757 be not to move the gap at all, but to leave it in place and work
|
|
3758 around it if necessary. This would be extremely efficient,
|
|
3759 especially considering that people are likely to do
|
|
3760 transpositions near where they are working interactively, which
|
|
3761 is exactly where the gap would be found. However, such code
|
|
3762 would be much harder to write and to read. So, if you are
|
|
3763 reading this comment and are feeling squirrely, by all means have
|
|
3764 a go! I just didn't feel like doing it, so I will simply move
|
|
3765 the gap the minimum distance to get it out of the way, and then
|
|
3766 deal with an unbroken array. */
|
7250
|
3767
|
|
3768 /* Make sure the gap won't interfere, by moving it out of the text
|
|
3769 we will operate on. */
|
|
3770 if (start1 < gap && gap < end2)
|
|
3771 {
|
|
3772 if (gap - start1 < end2 - gap)
|
|
3773 move_gap (start1);
|
|
3774 else
|
|
3775 move_gap (end2);
|
|
3776 }
|
20558
|
3777
|
|
3778 start1_byte = CHAR_TO_BYTE (start1);
|
|
3779 start2_byte = CHAR_TO_BYTE (start2);
|
|
3780 len1_byte = CHAR_TO_BYTE (end1) - start1_byte;
|
|
3781 len2_byte = CHAR_TO_BYTE (end2) - start2_byte;
|
21245
|
3782
|
29008
|
3783 #ifdef BYTE_COMBINING_DEBUG
|
21245
|
3784 if (end1 == start2)
|
|
3785 {
|
29008
|
3786 if (count_combining_before (BYTE_POS_ADDR (start2_byte),
|
|
3787 len2_byte, start1, start1_byte)
|
|
3788 || count_combining_before (BYTE_POS_ADDR (start1_byte),
|
|
3789 len1_byte, end2, start2_byte + len2_byte)
|
|
3790 || count_combining_after (BYTE_POS_ADDR (start1_byte),
|
|
3791 len1_byte, end2, start2_byte + len2_byte))
|
|
3792 abort ();
|
21245
|
3793 }
|
|
3794 else
|
|
3795 {
|
29008
|
3796 if (count_combining_before (BYTE_POS_ADDR (start2_byte),
|
|
3797 len2_byte, start1, start1_byte)
|
|
3798 || count_combining_before (BYTE_POS_ADDR (start1_byte),
|
|
3799 len1_byte, start2, start2_byte)
|
|
3800 || count_combining_after (BYTE_POS_ADDR (start2_byte),
|
|
3801 len2_byte, end1, start1_byte + len1_byte)
|
|
3802 || count_combining_after (BYTE_POS_ADDR (start1_byte),
|
|
3803 len1_byte, end2, start2_byte + len2_byte))
|
|
3804 abort ();
|
21245
|
3805 }
|
29008
|
3806 #endif
|
|
3807
|
7207
|
3808 /* Hmmm... how about checking to see if the gap is large
|
|
3809 enough to use as the temporary storage? That would avoid an
|
|
3810 allocation... interesting. Later, don't fool with it now. */
|
|
3811
|
|
3812 /* Working without memmove, for portability (sigh), so must be
|
|
3813 careful of overlapping subsections of the array... */
|
|
3814
|
|
3815 if (end1 == start2) /* adjacent regions */
|
|
3816 {
|
|
3817 modify_region (current_buffer, start1, end2);
|
|
3818 record_change (start1, len1 + len2);
|
|
3819
|
|
3820 tmp_interval1 = copy_intervals (cur_intv, start1, len1);
|
|
3821 tmp_interval2 = copy_intervals (cur_intv, start2, len2);
|
18745
192b3ebd108e
(Fcurrent_time_zone): Convert Fmake_list argument to Lisp_Integer.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
3822 Fset_text_properties (make_number (start1), make_number (end2),
|
192b3ebd108e
(Fcurrent_time_zone): Convert Fmake_list argument to Lisp_Integer.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
3823 Qnil, Qnil);
|
7207
|
3824
|
|
3825 /* First region smaller than second. */
|
20558
|
3826 if (len1_byte < len2_byte)
|
7207
|
3827 {
|
7250
|
3828 /* We use alloca only if it is small,
|
|
3829 because we want to avoid stack overflow. */
|
20558
|
3830 if (len2_byte > 20000)
|
|
3831 temp = (unsigned char *) xmalloc (len2_byte);
|
7250
|
3832 else
|
20558
|
3833 temp = (unsigned char *) alloca (len2_byte);
|
7862
|
3834
|
|
3835 /* Don't precompute these addresses. We have to compute them
|
|
3836 at the last minute, because the relocating allocator might
|
|
3837 have moved the buffer around during the xmalloc. */
|
23166
|
3838 start1_addr = BYTE_POS_ADDR (start1_byte);
|
|
3839 start2_addr = BYTE_POS_ADDR (start2_byte);
|
7862
|
3840
|
20558
|
3841 bcopy (start2_addr, temp, len2_byte);
|
|
3842 bcopy (start1_addr, start1_addr + len2_byte, len1_byte);
|
|
3843 bcopy (temp, start1_addr, len2_byte);
|
|
3844 if (len2_byte > 20000)
|
30606
|
3845 xfree (temp);
|
7207
|
3846 }
|
|
3847 else
|
|
3848 /* First region not smaller than second. */
|
|
3849 {
|
20558
|
3850 if (len1_byte > 20000)
|
|
3851 temp = (unsigned char *) xmalloc (len1_byte);
|
7250
|
3852 else
|
20558
|
3853 temp = (unsigned char *) alloca (len1_byte);
|
23166
|
3854 start1_addr = BYTE_POS_ADDR (start1_byte);
|
|
3855 start2_addr = BYTE_POS_ADDR (start2_byte);
|
20558
|
3856 bcopy (start1_addr, temp, len1_byte);
|
|
3857 bcopy (start2_addr, start1_addr, len2_byte);
|
|
3858 bcopy (temp, start1_addr + len2_byte, len1_byte);
|
|
3859 if (len1_byte > 20000)
|
30606
|
3860 xfree (temp);
|
7207
|
3861 }
|
|
3862 graft_intervals_into_buffer (tmp_interval1, start1 + len2,
|
|
3863 len1, current_buffer, 0);
|
|
3864 graft_intervals_into_buffer (tmp_interval2, start1,
|
|
3865 len2, current_buffer, 0);
|
26853
|
3866 update_compositions (start1, start1 + len2, CHECK_BORDER);
|
|
3867 update_compositions (start1 + len2, end2, CHECK_TAIL);
|
7207
|
3868 }
|
|
3869 /* Non-adjacent regions, because end1 != start2, bleagh... */
|
|
3870 else
|
|
3871 {
|
20558
|
3872 len_mid = start2_byte - (start1_byte + len1_byte);
|
|
3873
|
|
3874 if (len1_byte == len2_byte)
|
7207
|
3875 /* Regions are same size, though, how nice. */
|
|
3876 {
|
|
3877 modify_region (current_buffer, start1, end1);
|
|
3878 modify_region (current_buffer, start2, end2);
|
|
3879 record_change (start1, len1);
|
|
3880 record_change (start2, len2);
|
|
3881 tmp_interval1 = copy_intervals (cur_intv, start1, len1);
|
|
3882 tmp_interval2 = copy_intervals (cur_intv, start2, len2);
|
18745
192b3ebd108e
(Fcurrent_time_zone): Convert Fmake_list argument to Lisp_Integer.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
3883 Fset_text_properties (make_number (start1), make_number (end1),
|
192b3ebd108e
(Fcurrent_time_zone): Convert Fmake_list argument to Lisp_Integer.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
3884 Qnil, Qnil);
|
192b3ebd108e
(Fcurrent_time_zone): Convert Fmake_list argument to Lisp_Integer.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
3885 Fset_text_properties (make_number (start2), make_number (end2),
|
192b3ebd108e
(Fcurrent_time_zone): Convert Fmake_list argument to Lisp_Integer.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
3886 Qnil, Qnil);
|
7207
|
3887
|
20558
|
3888 if (len1_byte > 20000)
|
|
3889 temp = (unsigned char *) xmalloc (len1_byte);
|
7250
|
3890 else
|
20558
|
3891 temp = (unsigned char *) alloca (len1_byte);
|
23166
|
3892 start1_addr = BYTE_POS_ADDR (start1_byte);
|
|
3893 start2_addr = BYTE_POS_ADDR (start2_byte);
|
20558
|
3894 bcopy (start1_addr, temp, len1_byte);
|
|
3895 bcopy (start2_addr, start1_addr, len2_byte);
|
|
3896 bcopy (temp, start2_addr, len1_byte);
|
|
3897 if (len1_byte > 20000)
|
30606
|
3898 xfree (temp);
|
7207
|
3899 graft_intervals_into_buffer (tmp_interval1, start2,
|
|
3900 len1, current_buffer, 0);
|
|
3901 graft_intervals_into_buffer (tmp_interval2, start1,
|
|
3902 len2, current_buffer, 0);
|
|
3903 }
|
|
3904
|
20558
|
3905 else if (len1_byte < len2_byte) /* Second region larger than first */
|
7207
|
3906 /* Non-adjacent & unequal size, area between must also be shifted. */
|
|
3907 {
|
|
3908 modify_region (current_buffer, start1, end2);
|
|
3909 record_change (start1, (end2 - start1));
|
|
3910 tmp_interval1 = copy_intervals (cur_intv, start1, len1);
|
|
3911 tmp_interval_mid = copy_intervals (cur_intv, end1, len_mid);
|
|
3912 tmp_interval2 = copy_intervals (cur_intv, start2, len2);
|
18745
192b3ebd108e
(Fcurrent_time_zone): Convert Fmake_list argument to Lisp_Integer.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
3913 Fset_text_properties (make_number (start1), make_number (end2),
|
192b3ebd108e
(Fcurrent_time_zone): Convert Fmake_list argument to Lisp_Integer.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
3914 Qnil, Qnil);
|
7207
|
3915
|
7250
|
3916 /* holds region 2 */
|
20558
|
3917 if (len2_byte > 20000)
|
|
3918 temp = (unsigned char *) xmalloc (len2_byte);
|
7250
|
3919 else
|
20558
|
3920 temp = (unsigned char *) alloca (len2_byte);
|
23166
|
3921 start1_addr = BYTE_POS_ADDR (start1_byte);
|
|
3922 start2_addr = BYTE_POS_ADDR (start2_byte);
|
20558
|
3923 bcopy (start2_addr, temp, len2_byte);
|
|
3924 bcopy (start1_addr, start1_addr + len_mid + len2_byte, len1_byte);
|
|
3925 safe_bcopy (start1_addr + len1_byte, start1_addr + len2_byte, len_mid);
|
|
3926 bcopy (temp, start1_addr, len2_byte);
|
|
3927 if (len2_byte > 20000)
|
30606
|
3928 xfree (temp);
|
7207
|
3929 graft_intervals_into_buffer (tmp_interval1, end2 - len1,
|
|
3930 len1, current_buffer, 0);
|
|
3931 graft_intervals_into_buffer (tmp_interval_mid, start1 + len2,
|
|
3932 len_mid, current_buffer, 0);
|
|
3933 graft_intervals_into_buffer (tmp_interval2, start1,
|
|
3934 len2, current_buffer, 0);
|
|
3935 }
|
|
3936 else
|
|
3937 /* Second region smaller than first. */
|
|
3938 {
|
|
3939 record_change (start1, (end2 - start1));
|
|
3940 modify_region (current_buffer, start1, end2);
|
|
3941
|
|
3942 tmp_interval1 = copy_intervals (cur_intv, start1, len1);
|
|
3943 tmp_interval_mid = copy_intervals (cur_intv, end1, len_mid);
|
|
3944 tmp_interval2 = copy_intervals (cur_intv, start2, len2);
|
18745
192b3ebd108e
(Fcurrent_time_zone): Convert Fmake_list argument to Lisp_Integer.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
3945 Fset_text_properties (make_number (start1), make_number (end2),
|
192b3ebd108e
(Fcurrent_time_zone): Convert Fmake_list argument to Lisp_Integer.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
3946 Qnil, Qnil);
|
7207
|
3947
|
7250
|
3948 /* holds region 1 */
|
20558
|
3949 if (len1_byte > 20000)
|
|
3950 temp = (unsigned char *) xmalloc (len1_byte);
|
7250
|
3951 else
|
20558
|
3952 temp = (unsigned char *) alloca (len1_byte);
|
23166
|
3953 start1_addr = BYTE_POS_ADDR (start1_byte);
|
|
3954 start2_addr = BYTE_POS_ADDR (start2_byte);
|
20558
|
3955 bcopy (start1_addr, temp, len1_byte);
|
|
3956 bcopy (start2_addr, start1_addr, len2_byte);
|
|
3957 bcopy (start1_addr + len1_byte, start1_addr + len2_byte, len_mid);
|
|
3958 bcopy (temp, start1_addr + len2_byte + len_mid, len1_byte);
|
|
3959 if (len1_byte > 20000)
|
30606
|
3960 xfree (temp);
|
7207
|
3961 graft_intervals_into_buffer (tmp_interval1, end2 - len1,
|
|
3962 len1, current_buffer, 0);
|
|
3963 graft_intervals_into_buffer (tmp_interval_mid, start1 + len2,
|
|
3964 len_mid, current_buffer, 0);
|
|
3965 graft_intervals_into_buffer (tmp_interval2, start1,
|
|
3966 len2, current_buffer, 0);
|
|
3967 }
|
26853
|
3968
|
|
3969 update_compositions (start1, start1 + len2, CHECK_BORDER);
|
|
3970 update_compositions (end2 - len1, end2, CHECK_BORDER);
|
7207
|
3971 }
|
|
3972
|
20558
|
3973 /* When doing multiple transpositions, it might be nice
|
|
3974 to optimize this. Perhaps the markers in any one buffer
|
|
3975 should be organized in some sorted data tree. */
|
7207
|
3976 if (NILP (leave_markers))
|
7519
|
3977 {
|
20558
|
3978 transpose_markers (start1, end1, start2, end2,
|
|
3979 start1_byte, start1_byte + len1_byte,
|
|
3980 start2_byte, start2_byte + len2_byte);
|
7519
|
3981 fix_overlays_in_range (start1, end2);
|
|
3982 }
|
7207
|
3983
|
|
3984 return Qnil;
|
|
3985 }
|
305
|
3986
|
|
3987
|
|
3988 void
|
|
3989 syms_of_editfns ()
|
|
3990 {
|
13767
|
3991 environbuf = 0;
|
|
3992
|
|
3993 Qbuffer_access_fontify_functions
|
|
3994 = intern ("buffer-access-fontify-functions");
|
|
3995 staticpro (&Qbuffer_access_fontify_functions);
|
|
3996
|
39988
|
3997 DEFVAR_LISP ("inhibit-field-text-motion", &Vinhibit_field_text_motion,
|
|
3998 doc: /* Non-nil means.text motion commands don't notice fields. */);
|
27077
|
3999 Vinhibit_field_text_motion = Qnil;
|
|
4000
|
13767
|
4001 DEFVAR_LISP ("buffer-access-fontify-functions",
|
39988
|
4002 &Vbuffer_access_fontify_functions,
|
|
4003 doc: /* List of functions called by `buffer-substring' to fontify if necessary.
|
39966
|
4004 Each function is called with two arguments which specify the range
|
|
4005 of the buffer being accessed. */);
|
13767
|
4006 Vbuffer_access_fontify_functions = Qnil;
|
|
4007
|
14440
|
4008 {
|
|
4009 Lisp_Object obuf;
|
|
4010 extern Lisp_Object Vprin1_to_string_buffer;
|
|
4011 obuf = Fcurrent_buffer ();
|
|
4012 /* Do this here, because init_buffer_once is too early--it won't work. */
|
|
4013 Fset_buffer (Vprin1_to_string_buffer);
|
|
4014 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
|
|
4015 Fset (Fmake_local_variable (intern ("buffer-access-fontify-functions")),
|
|
4016 Qnil);
|
|
4017 Fset_buffer (obuf);
|
|
4018 }
|
|
4019
|
14220
|
4020 DEFVAR_LISP ("buffer-access-fontified-property",
|
39988
|
4021 &Vbuffer_access_fontified_property,
|
|
4022 doc: /* Property which (if non-nil) indicates text has been fontified.
|
39966
|
4023 `buffer-substring' need not call the `buffer-access-fontify-functions'
|
|
4024 functions if all the text being accessed has this property. */);
|
13767
|
4025 Vbuffer_access_fontified_property = Qnil;
|
|
4026
|
39988
|
4027 DEFVAR_LISP ("system-name", &Vsystem_name,
|
|
4028 doc: /* The name of the machine Emacs is running on. */);
|
|
4029
|
|
4030 DEFVAR_LISP ("user-full-name", &Vuser_full_name,
|
|
4031 doc: /* The full name of the user logged in. */);
|
|
4032
|
|
4033 DEFVAR_LISP ("user-login-name", &Vuser_login_name,
|
|
4034 doc: /* The user's name, taken from environment variables if possible. */);
|
|
4035
|
|
4036 DEFVAR_LISP ("user-real-login-name", &Vuser_real_login_name,
|
|
4037 doc: /* The user's name, based upon the real uid only. */);
|
305
|
4038
|
25833
|
4039 defsubr (&Spropertize);
|
305
|
4040 defsubr (&Schar_equal);
|
|
4041 defsubr (&Sgoto_char);
|
|
4042 defsubr (&Sstring_to_char);
|
|
4043 defsubr (&Schar_to_string);
|
|
4044 defsubr (&Sbuffer_substring);
|
13767
|
4045 defsubr (&Sbuffer_substring_no_properties);
|
305
|
4046 defsubr (&Sbuffer_string);
|
|
4047
|
|
4048 defsubr (&Spoint_marker);
|
|
4049 defsubr (&Smark_marker);
|
|
4050 defsubr (&Spoint);
|
|
4051 defsubr (&Sregion_beginning);
|
|
4052 defsubr (&Sregion_end);
|
20861
|
4053
|
26058
|
4054 staticpro (&Qfield);
|
|
4055 Qfield = intern ("field");
|
30439
|
4056 staticpro (&Qboundary);
|
|
4057 Qboundary = intern ("boundary");
|
26058
|
4058 defsubr (&Sfield_beginning);
|
|
4059 defsubr (&Sfield_end);
|
|
4060 defsubr (&Sfield_string);
|
|
4061 defsubr (&Sfield_string_no_properties);
|
26347
|
4062 defsubr (&Sdelete_field);
|
26058
|
4063 defsubr (&Sconstrain_to_field);
|
|
4064
|
20861
|
4065 defsubr (&Sline_beginning_position);
|
|
4066 defsubr (&Sline_end_position);
|
|
4067
|
305
|
4068 /* defsubr (&Smark); */
|
|
4069 /* defsubr (&Sset_mark); */
|
|
4070 defsubr (&Ssave_excursion);
|
16298
|
4071 defsubr (&Ssave_current_buffer);
|
305
|
4072
|
|
4073 defsubr (&Sbufsize);
|
|
4074 defsubr (&Spoint_max);
|
|
4075 defsubr (&Spoint_min);
|
|
4076 defsubr (&Spoint_min_marker);
|
|
4077 defsubr (&Spoint_max_marker);
|
21821
|
4078 defsubr (&Sgap_position);
|
|
4079 defsubr (&Sgap_size);
|
20861
|
4080 defsubr (&Sposition_bytes);
|
22645
|
4081 defsubr (&Sbyte_to_position);
|
16639
|
4082
|
305
|
4083 defsubr (&Sbobp);
|
|
4084 defsubr (&Seobp);
|
|
4085 defsubr (&Sbolp);
|
|
4086 defsubr (&Seolp);
|
512
|
4087 defsubr (&Sfollowing_char);
|
|
4088 defsubr (&Sprevious_char);
|
305
|
4089 defsubr (&Schar_after);
|
17031
|
4090 defsubr (&Schar_before);
|
305
|
4091 defsubr (&Sinsert);
|
|
4092 defsubr (&Sinsert_before_markers);
|
4714
|
4093 defsubr (&Sinsert_and_inherit);
|
|
4094 defsubr (&Sinsert_and_inherit_before_markers);
|
305
|
4095 defsubr (&Sinsert_char);
|
|
4096
|
|
4097 defsubr (&Suser_login_name);
|
|
4098 defsubr (&Suser_real_login_name);
|
|
4099 defsubr (&Suser_uid);
|
|
4100 defsubr (&Suser_real_uid);
|
|
4101 defsubr (&Suser_full_name);
|
5373
|
4102 defsubr (&Semacs_pid);
|
448
|
4103 defsubr (&Scurrent_time);
|
9154
|
4104 defsubr (&Sformat_time_string);
|
30480
|
4105 defsubr (&Sfloat_time);
|
9801
|
4106 defsubr (&Sdecode_time);
|
11402
|
4107 defsubr (&Sencode_time);
|
305
|
4108 defsubr (&Scurrent_time_string);
|
962
|
4109 defsubr (&Scurrent_time_zone);
|
13019
|
4110 defsubr (&Sset_time_zone_rule);
|
305
|
4111 defsubr (&Ssystem_name);
|
|
4112 defsubr (&Smessage);
|
8975
|
4113 defsubr (&Smessage_box);
|
|
4114 defsubr (&Smessage_or_box);
|
18937
|
4115 defsubr (&Scurrent_message);
|
305
|
4116 defsubr (&Sformat);
|
|
4117
|
|
4118 defsubr (&Sinsert_buffer_substring);
|
1853
|
4119 defsubr (&Scompare_buffer_substrings);
|
305
|
4120 defsubr (&Ssubst_char_in_region);
|
|
4121 defsubr (&Stranslate_region);
|
|
4122 defsubr (&Sdelete_region);
|
26742
936b39bd05b4
* editfns.c (Fdelete_and_extract_region): New function.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
4123 defsubr (&Sdelete_and_extract_region);
|
305
|
4124 defsubr (&Swiden);
|
|
4125 defsubr (&Snarrow_to_region);
|
|
4126 defsubr (&Ssave_restriction);
|
7207
|
4127 defsubr (&Stranspose_regions);
|
305
|
4128 }
|