Mercurial > hg > xemacs-beta
annotate src/minibuf.c @ 4742:4cf435fcebbc
Make #'letf not error if handed a #'values form.
lisp/ChangeLog addition:
2009-11-14 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (letf):
Check whether arguments to #'values are bound, and make them
unbound after evaluating BODY; document the limitations of this
macro.
tests/ChangeLog addition:
2009-11-14 Aidan Kehoe <kehoea@parhasard.net>
* automated/lisp-tests.el:
Don't call Known-Bug-Expect-Failure now that the particular letf
bug it tickled is fixed.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Sat, 14 Nov 2009 11:43:09 +0000 |
| parents | 44c9d1005ce2 |
| children | 6ef8256a020a 19a72041c5ed |
| rev | line source |
|---|---|
| 428 | 1 /* Minibuffer input and completion. |
| 2 Copyright (C) 1985, 1986, 1992-1995 Free Software Foundation, Inc. | |
| 3 Copyright (C) 1995 Sun Microsystems, Inc. | |
| 793 | 4 Copyright (C) 2002 Ben Wing. |
| 428 | 5 |
| 6 This file is part of XEmacs. | |
| 7 | |
| 8 XEmacs is free software; you can redistribute it and/or modify it | |
| 9 under the terms of the GNU General Public License as published by the | |
| 10 Free Software Foundation; either version 2, or (at your option) any | |
| 11 later version. | |
| 12 | |
| 13 XEmacs is distributed in the hope that it will be useful, but WITHOUT | |
| 14 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
| 15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
| 16 for more details. | |
| 17 | |
| 18 You should have received a copy of the GNU General Public License | |
| 19 along with XEmacs; see the file COPYING. If not, write to | |
| 20 the Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
| 21 Boston, MA 02111-1307, USA. */ | |
| 22 | |
| 23 /* Synched up with: Mule 2.0, FSF 19.28. Mule-ized except as noted. | |
| 24 Substantially different from FSF. */ | |
| 25 | |
| 26 /* #### dmoore - All sorts of things in here can call lisp, like message. | |
| 27 Track all this stuff. */ | |
| 28 | |
| 29 #include <config.h> | |
| 30 #include "lisp.h" | |
| 31 | |
| 32 #include "buffer.h" | |
| 33 #include "commands.h" | |
| 34 #include "console-stream.h" | |
| 35 #include "events.h" | |
| 872 | 36 #include "frame-impl.h" |
| 428 | 37 #include "insdel.h" |
| 38 #include "redisplay.h" | |
| 872 | 39 #include "window-impl.h" |
| 428 | 40 |
| 41 /* Depth in minibuffer invocations. */ | |
| 42 int minibuf_level; | |
| 43 | |
| 44 Lisp_Object Qcompletion_ignore_case; | |
| 45 | |
| 46 /* Nonzero means completion ignores case. */ | |
| 47 int completion_ignore_case; | |
| 48 | |
| 49 /* List of regexps that should restrict possible completions. */ | |
| 50 Lisp_Object Vcompletion_regexp_list; | |
| 51 | |
| 52 /* The echo area buffer. */ | |
| 53 Lisp_Object Vecho_area_buffer; | |
| 54 | |
| 55 /* Prompt to display in front of the minibuffer contents */ | |
| 56 Lisp_Object Vminibuf_prompt; | |
| 57 | |
| 58 /* Added on 97/3/14 by Jareth Hein (jhod@po.iijnet.or.jp) for input system support */ | |
| 59 /* String to be displayed in front of prompt of the minibuffer contents */ | |
| 60 Lisp_Object Vminibuf_preprompt; | |
| 61 | |
| 62 /* Hook to run just after entry to minibuffer. */ | |
| 63 Lisp_Object Qminibuffer_setup_hook, Vminibuffer_setup_hook; | |
| 64 | |
| 65 Lisp_Object Qappend_message, Qcurrent_message_label, | |
| 66 Qclear_message, Qdisplay_message; | |
| 67 | |
| 68 | |
| 69 DEFUN ("minibuffer-depth", Fminibuffer_depth, 0, 0, 0, /* | |
| 70 Return current depth of activations of minibuffer, a nonnegative integer. | |
| 71 */ | |
| 72 ()) | |
| 73 { | |
| 74 return make_int (minibuf_level); | |
| 75 } | |
| 76 | |
| 77 /* The default buffer to use as the window-buffer of minibuffer windows */ | |
| 78 /* Note there is special code in kill-buffer to make this unkillable */ | |
| 79 Lisp_Object Vminibuffer_zero; | |
| 80 | |
| 81 | |
| 82 /* Actual minibuffer invocation. */ | |
| 83 | |
| 84 static Lisp_Object | |
| 85 read_minibuffer_internal_unwind (Lisp_Object unwind_data) | |
| 86 { | |
| 87 Lisp_Object frame; | |
| 88 XWINDOW (minibuf_window)->last_modified[CURRENT_DISP] = Qzero; | |
| 89 XWINDOW (minibuf_window)->last_modified[DESIRED_DISP] = Qzero; | |
| 90 XWINDOW (minibuf_window)->last_modified[CMOTION_DISP] = Qzero; | |
| 91 XWINDOW (minibuf_window)->last_facechange[CURRENT_DISP] = Qzero; | |
| 92 XWINDOW (minibuf_window)->last_facechange[DESIRED_DISP] = Qzero; | |
| 93 XWINDOW (minibuf_window)->last_facechange[CMOTION_DISP] = Qzero; | |
| 94 Vminibuf_prompt = Felt (unwind_data, Qzero); | |
| 95 minibuf_level = XINT (Felt (unwind_data, make_int (1))); | |
| 96 while (CONSP (unwind_data)) | |
| 97 { | |
| 98 Lisp_Object victim = unwind_data; | |
| 99 unwind_data = XCDR (unwind_data); | |
| 853 | 100 free_cons (victim); |
| 428 | 101 } |
| 102 | |
| 103 /* If cursor is on the minibuffer line, | |
| 104 show the user we have exited by putting it in column 0. */ | |
| 105 frame = Fselected_frame (Qnil); | |
| 106 if (!noninteractive | |
| 107 && !NILP (frame) | |
| 108 && !NILP (XFRAME (frame)->minibuffer_window)) | |
| 109 { | |
| 110 struct window *w = XWINDOW (XFRAME (frame)->minibuffer_window); | |
| 111 redisplay_move_cursor (w, 0, 0); | |
| 112 } | |
| 113 | |
| 114 return Qnil; | |
| 115 } | |
| 116 | |
| 117 /* 97/4/13 jhod: Added for input methods */ | |
| 118 DEFUN ("set-minibuffer-preprompt", Fset_minibuffer_preprompt, 1, 1, 0, /* | |
| 119 Set the minibuffer preprompt string to PREPROMPT. This is used by language | |
| 120 input methods to relay state information to the user. | |
| 121 */ | |
| 122 (preprompt)) | |
| 123 { | |
| 124 if (NILP (preprompt)) | |
| 125 { | |
| 126 Vminibuf_preprompt = Qnil; | |
| 127 } | |
| 128 else | |
| 129 { | |
| 130 CHECK_STRING (preprompt); | |
| 131 | |
| 132 Vminibuf_preprompt = LISP_GETTEXT (preprompt); | |
| 133 } | |
| 134 return Qnil; | |
| 135 } | |
| 136 | |
| 2268 | 137 DEFUN_NORETURN ("read-minibuffer-internal", Fread_minibuffer_internal, |
| 138 1, 1, 0, /* | |
| 428 | 139 Lowest-level interface to minibuffers. Don't call this. |
| 140 */ | |
| 141 (prompt)) | |
| 142 { | |
| 143 /* This function can GC */ | |
| 2268 | 144 |
| 145 /* We used to record the specpdl_depth here, but since call_command_loop | |
| 146 never returns, we can never call unbind_to_1. Since we exit via a throw, | |
| 147 we let whoever catches unbind for us. */ | |
| 148 | |
| 428 | 149 CHECK_STRING (prompt); |
| 150 | |
| 151 single_console_state (); | |
| 152 | |
| 153 record_unwind_protect (read_minibuffer_internal_unwind, | |
| 154 noseeum_cons | |
| 155 (Vminibuf_prompt, | |
| 156 noseeum_cons (make_int (minibuf_level), Qnil))); | |
| 157 Vminibuf_prompt = LISP_GETTEXT (prompt); | |
| 158 | |
| 159 /* NOTE: Here (or somewhere around here), in FSFmacs 19.30, | |
| 160 choose_minibuf_frame() is called. This is the only | |
| 161 place in FSFmacs that it's called any more -- there's | |
| 162 also a call in xterm.c, but commented out, and 19.28 | |
| 163 had the calls in different places. | |
| 164 | |
| 165 choose_minibuf_frame() does the following: | |
| 166 | |
| 167 if (!EQ (minibuf_window, selected_frame()->minibuffer_window)) | |
| 168 { | |
| 169 Fset_window_buffer (selected_frame()->minibuffer_window, | |
| 170 XWINDOW (minibuf_window)->buffer); | |
| 171 minibuf_window = selected_frame()->minibuffer_window; | |
| 172 } | |
| 173 | |
| 174 #### Note that we don't do the set-window-buffer. This call is | |
| 175 similar, but not identical, to a set-window-buffer call made | |
| 176 in `read-from-minibuffer' in minibuf.el. I hope it's close | |
| 177 enough, because minibuf_window isn't really exported to Lisp. | |
| 178 | |
| 179 The comment above choose_minibuf_frame() reads: | |
| 180 | |
| 181 Put minibuf on currently selected frame's minibuffer. | |
| 182 We do this whenever the user starts a new minibuffer | |
| 183 or when a minibuffer exits. */ | |
| 184 | |
| 185 minibuf_window = FRAME_MINIBUF_WINDOW (selected_frame ()); | |
| 186 | |
| 187 run_hook (Qminibuffer_setup_hook); | |
| 188 | |
| 189 minibuf_level++; | |
| 190 clear_echo_area (selected_frame (), Qnil, 0); | |
| 191 | |
| 2286 | 192 call_command_loop (Qt); |
| 428 | 193 |
| 2286 | 194 RETURN_NOT_REACHED (Qnil); |
| 428 | 195 } |
| 196 | |
| 197 | |
| 198 | |
| 199 /* Completion hair */ | |
| 200 | |
| 201 /* Compare exactly LEN chars of strings at S1 and S2, | |
| 202 ignoring case if appropriate. | |
| 203 Return -1 if strings match, | |
| 204 else number of chars that match at the beginning. */ | |
| 205 | |
| 206 /* Note that this function works in Charcounts, unlike most functions. | |
| 207 This is necessary for many reasons, one of which is that two | |
| 208 strings may match even if they have different numbers of bytes, | |
| 209 if IGNORE_CASE is true. */ | |
| 210 | |
| 211 Charcount | |
| 867 | 212 scmp_1 (const Ibyte *s1, const Ibyte *s2, Charcount len, |
| 428 | 213 int ignore_case) |
| 214 { | |
| 215 Charcount l = len; | |
| 216 | |
| 217 if (ignore_case) | |
| 218 { | |
| 219 while (l) | |
| 220 { | |
| 867 | 221 Ichar c1 = DOWNCASE (0, itext_ichar (s1)); |
| 222 Ichar c2 = DOWNCASE (0, itext_ichar (s2)); | |
| 428 | 223 |
| 224 if (c1 == c2) | |
| 225 { | |
| 226 l--; | |
| 867 | 227 INC_IBYTEPTR (s1); |
| 228 INC_IBYTEPTR (s2); | |
| 428 | 229 } |
| 230 else | |
| 231 break; | |
| 232 } | |
| 233 } | |
| 234 else | |
| 235 { | |
| 867 | 236 while (l && itext_ichar (s1) == itext_ichar (s2)) |
| 428 | 237 { |
| 238 l--; | |
| 867 | 239 INC_IBYTEPTR (s1); |
| 240 INC_IBYTEPTR (s2); | |
| 428 | 241 } |
| 242 } | |
| 243 | |
| 244 if (l == 0) | |
| 245 return -1; | |
| 246 else return len - l; | |
| 247 } | |
| 248 | |
| 249 | |
| 250 int | |
| 867 | 251 regexp_ignore_completion_p (const Ibyte *nonreloc, |
| 428 | 252 Lisp_Object reloc, Bytecount offset, |
| 253 Bytecount length) | |
| 254 { | |
| 255 /* Ignore this element if it fails to match all the regexps. */ | |
| 256 if (!NILP (Vcompletion_regexp_list)) | |
| 257 { | |
| 2367 | 258 EXTERNAL_LIST_LOOP_2 (re, Vcompletion_regexp_list) |
| 428 | 259 { |
| 260 CHECK_STRING (re); | |
| 261 if (fast_string_match (re, nonreloc, reloc, offset, | |
| 262 length, 0, ERROR_ME, 0) < 0) | |
| 263 return 1; | |
| 264 } | |
| 265 } | |
| 266 return 0; | |
| 267 } | |
| 268 | |
| 269 | |
| 270 /* Callers should GCPRO, since this may call eval */ | |
| 271 static int | |
| 272 ignore_completion_p (Lisp_Object completion_string, | |
| 273 Lisp_Object pred, Lisp_Object completion) | |
| 274 { | |
| 275 if (regexp_ignore_completion_p (0, completion_string, 0, -1)) | |
| 276 return 1; | |
| 277 | |
| 278 /* Ignore this element if there is a predicate | |
| 279 and the predicate doesn't like it. */ | |
| 280 if (!NILP (pred)) | |
| 281 { | |
| 282 Lisp_Object tem; | |
| 283 if (EQ (pred, Qcommandp)) | |
| 284 tem = Fcommandp (completion); | |
| 285 else | |
| 286 tem = call1 (pred, completion); | |
| 287 if (NILP (tem)) | |
| 288 return 1; | |
| 289 } | |
| 290 return 0; | |
| 291 } | |
| 292 | |
| 293 | |
| 444 | 294 /* #### Maybe we should allow COLLECTION to be a hash table. |
| 295 It is wrong for the use of obarrays to be better-rewarded than the | |
| 296 use of hash tables. By better-rewarded I mean that you can pass an | |
| 297 obarray to all of the completion functions, whereas you can't do | |
| 298 anything like that with a hash table. | |
| 428 | 299 |
| 300 To do so, there should probably be a | |
| 301 map_obarray_or_alist_or_hash_table function which would be used by | |
| 826 | 302 both Ftry_completion and Fall_completions. [[ But would the |
| 303 additional funcalls slow things down? ]] Seriously doubtful. --ben */ | |
| 428 | 304 |
| 305 DEFUN ("try-completion", Ftry_completion, 2, 3, 0, /* | |
| 444 | 306 Return common substring of all completions of STRING in COLLECTION. |
| 307 COLLECTION must be an alist, an obarray, or a function. | |
| 308 Each string in COLLECTION is tested to see if it begins with STRING. | |
| 428 | 309 All that match are compared together; the longest initial sequence |
| 444 | 310 common to all matches is returned as a string. If there is no match |
| 311 at all, nil is returned. For an exact match, t is returned. | |
| 428 | 312 |
|
4704
44c9d1005ce2
Bring `try-completion''s interface closer to GNU Emacs.
Mike Sperber <sperber@deinprogramm.de>
parents:
2367
diff
changeset
|
313 If COLLECTION is list, the elements of the list that are not cons |
|
44c9d1005ce2
Bring `try-completion''s interface closer to GNU Emacs.
Mike Sperber <sperber@deinprogramm.de>
parents:
2367
diff
changeset
|
314 cells and the cars of the elements of the list that are cons cells |
|
44c9d1005ce2
Bring `try-completion''s interface closer to GNU Emacs.
Mike Sperber <sperber@deinprogramm.de>
parents:
2367
diff
changeset
|
315 (which must be strings) form the set of possible completions. |
| 428 | 316 |
| 444 | 317 If COLLECTION is an obarray, the names of all symbols in the obarray |
| 318 are the possible completions. | |
| 319 | |
| 320 If COLLECTION is a function, it is called with three arguments: the | |
| 321 values STRING, PREDICATE and nil. Whatever it returns becomes the | |
| 322 value of `try-completion'. | |
| 428 | 323 |
| 444 | 324 If optional third argument PREDICATE is non-nil, it is used to test |
| 325 each possible match. The match is a candidate only if PREDICATE | |
| 326 returns non-nil. The argument given to PREDICATE is the alist element | |
| 327 or the symbol from the obarray. | |
| 428 | 328 */ |
| 444 | 329 (string, collection, predicate)) |
| 428 | 330 { |
| 331 /* This function can GC */ | |
| 332 Lisp_Object bestmatch, tail; | |
| 333 Charcount bestmatchsize = 0; | |
| 334 int list; | |
| 335 int indice = 0; | |
| 336 int matchcount = 0; | |
| 337 int obsize; | |
| 338 Lisp_Object bucket; | |
| 339 Charcount slength, blength; | |
| 340 | |
| 341 CHECK_STRING (string); | |
| 342 | |
| 444 | 343 if (CONSP (collection)) |
| 428 | 344 { |
| 444 | 345 Lisp_Object tem = XCAR (collection); |
| 428 | 346 if (SYMBOLP (tem)) /* lambda, autoload, etc. Emacs-lisp sucks */ |
| 444 | 347 return call3 (collection, string, predicate, Qnil); |
| 428 | 348 else |
| 349 list = 1; | |
| 350 } | |
| 444 | 351 else if (VECTORP (collection)) |
| 428 | 352 list = 0; |
| 444 | 353 else if (NILP (collection)) |
| 428 | 354 list = 1; |
| 355 else | |
| 444 | 356 return call3 (collection, string, predicate, Qnil); |
| 428 | 357 |
| 358 bestmatch = Qnil; | |
| 359 blength = 0; | |
| 826 | 360 slength = string_char_length (string); |
| 428 | 361 |
| 444 | 362 /* If COLLECTION is not a list, set TAIL just for gc pro. */ |
| 363 tail = collection; | |
| 428 | 364 if (!list) |
| 365 { | |
| 444 | 366 obsize = XVECTOR_LENGTH (collection); |
| 367 bucket = XVECTOR_DATA (collection)[indice]; | |
| 428 | 368 } |
| 369 else /* warning suppression */ | |
| 370 { | |
| 371 obsize = 0; | |
| 372 bucket = Qnil; | |
| 373 } | |
| 374 | |
| 375 while (1) | |
| 376 { | |
| 377 /* Get the next element of the alist or obarray. */ | |
| 378 /* Exit the loop if the elements are all used up. */ | |
| 379 /* elt gets the alist element or symbol. | |
| 380 eltstring gets the name to check as a completion. */ | |
| 381 Lisp_Object elt; | |
| 382 Lisp_Object eltstring; | |
| 383 | |
| 384 if (list) | |
| 385 { | |
| 386 if (NILP (tail)) | |
| 387 break; | |
| 388 elt = Fcar (tail); | |
|
4704
44c9d1005ce2
Bring `try-completion''s interface closer to GNU Emacs.
Mike Sperber <sperber@deinprogramm.de>
parents:
2367
diff
changeset
|
389 if (CONSP (elt)) |
|
44c9d1005ce2
Bring `try-completion''s interface closer to GNU Emacs.
Mike Sperber <sperber@deinprogramm.de>
parents:
2367
diff
changeset
|
390 eltstring = Fcar (elt); |
|
44c9d1005ce2
Bring `try-completion''s interface closer to GNU Emacs.
Mike Sperber <sperber@deinprogramm.de>
parents:
2367
diff
changeset
|
391 else |
|
44c9d1005ce2
Bring `try-completion''s interface closer to GNU Emacs.
Mike Sperber <sperber@deinprogramm.de>
parents:
2367
diff
changeset
|
392 eltstring = elt; |
| 428 | 393 tail = Fcdr (tail); |
| 394 } | |
| 395 else | |
| 396 { | |
| 397 if (!ZEROP (bucket)) | |
| 398 { | |
| 440 | 399 Lisp_Symbol *next; |
| 428 | 400 if (!SYMBOLP (bucket)) |
| 401 { | |
| 563 | 402 invalid_argument ("Bad obarray passed to try-completions", |
| 403 bucket); | |
| 428 | 404 } |
| 405 next = symbol_next (XSYMBOL (bucket)); | |
| 406 elt = bucket; | |
| 407 eltstring = Fsymbol_name (elt); | |
| 408 if (next) | |
| 793 | 409 bucket = wrap_symbol (next); |
| 428 | 410 else |
| 411 bucket = Qzero; | |
| 412 } | |
| 413 else if (++indice >= obsize) | |
| 414 break; | |
| 415 else | |
| 416 { | |
| 444 | 417 bucket = XVECTOR_DATA (collection)[indice]; |
| 428 | 418 continue; |
| 419 } | |
| 420 } | |
| 421 | |
| 422 /* Is this element a possible completion? */ | |
| 423 | |
| 424 if (STRINGP (eltstring)) | |
| 425 { | |
| 826 | 426 Charcount eltlength = string_char_length (eltstring); |
| 428 | 427 if (slength <= eltlength |
| 428 && (0 > scmp (XSTRING_DATA (eltstring), | |
| 429 XSTRING_DATA (string), | |
| 430 slength))) | |
| 431 { | |
| 432 { | |
| 433 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; | |
| 434 int loser; | |
| 435 GCPRO4 (tail, string, eltstring, bestmatch); | |
| 444 | 436 loser = ignore_completion_p (eltstring, predicate, elt); |
| 428 | 437 UNGCPRO; |
| 438 if (loser) /* reject this one */ | |
| 439 continue; | |
| 440 } | |
| 441 | |
| 442 /* Update computation of how much all possible | |
| 443 completions match */ | |
| 444 | |
| 445 matchcount++; | |
| 446 if (NILP (bestmatch)) | |
| 447 { | |
| 448 bestmatch = eltstring; | |
| 449 blength = eltlength; | |
| 450 bestmatchsize = eltlength; | |
| 451 } | |
| 452 else | |
| 453 { | |
| 454 Charcount compare = min (bestmatchsize, eltlength); | |
| 455 Charcount matchsize = | |
| 456 scmp (XSTRING_DATA (bestmatch), | |
| 457 XSTRING_DATA (eltstring), | |
| 458 compare); | |
| 459 if (matchsize < 0) | |
| 460 matchsize = compare; | |
| 461 if (completion_ignore_case) | |
| 462 { | |
| 463 /* If this is an exact match except for case, | |
| 464 use it as the best match rather than one that is not | |
| 465 an exact match. This way, we get the case pattern | |
| 466 of the actual match. */ | |
| 467 if ((matchsize == eltlength | |
| 468 && matchsize < blength) | |
| 469 || | |
| 470 /* If there is more than one exact match ignoring | |
| 471 case, and one of them is exact including case, | |
| 472 prefer that one. */ | |
| 473 /* If there is no exact match ignoring case, | |
| 474 prefer a match that does not change the case | |
| 475 of the input. */ | |
| 476 ((matchsize == eltlength) | |
| 477 == | |
| 478 (matchsize == blength) | |
| 479 && 0 > scmp_1 (XSTRING_DATA (eltstring), | |
| 480 XSTRING_DATA (string), | |
| 481 slength, 0) | |
| 482 && 0 <= scmp_1 (XSTRING_DATA (bestmatch), | |
| 483 XSTRING_DATA (string), | |
| 484 slength, 0))) | |
| 485 { | |
| 486 bestmatch = eltstring; | |
| 487 blength = eltlength; | |
| 488 } | |
| 489 } | |
| 490 bestmatchsize = matchsize; | |
| 491 } | |
| 492 } | |
| 493 } | |
| 494 } | |
| 495 | |
| 496 if (NILP (bestmatch)) | |
| 497 return Qnil; /* No completions found */ | |
| 498 /* If we are ignoring case, and there is no exact match, | |
| 499 and no additional text was supplied, | |
| 500 don't change the case of what the user typed. */ | |
| 501 if (completion_ignore_case | |
| 502 && bestmatchsize == slength | |
| 503 && blength > bestmatchsize) | |
| 504 return string; | |
| 505 | |
| 506 /* Return t if the supplied string is an exact match (counting case); | |
| 507 it does not require any change to be made. */ | |
| 508 if (matchcount == 1 | |
| 509 && bestmatchsize == slength | |
| 510 && 0 > scmp_1 (XSTRING_DATA (bestmatch), | |
| 511 XSTRING_DATA (string), | |
| 512 bestmatchsize, 0)) | |
| 513 return Qt; | |
| 514 | |
| 515 /* Else extract the part in which all completions agree */ | |
| 516 return Fsubstring (bestmatch, Qzero, make_int (bestmatchsize)); | |
| 517 } | |
| 518 | |
| 519 | |
| 520 DEFUN ("all-completions", Fall_completions, 2, 3, 0, /* | |
| 444 | 521 Search for partial matches to STRING in COLLECTION. |
| 522 COLLECTION must be an alist, an obarray, or a function. | |
| 523 Each string in COLLECTION is tested to see if it begins with STRING. | |
| 524 The value is a list of all the strings from COLLECTION that match. | |
| 525 | |
| 526 If COLLECTION is an alist, the cars of the elements of the alist | |
| 527 \(which must be strings) form the set of possible completions. | |
| 528 | |
| 529 If COLLECTION is an obarray, the names of all symbols in the obarray | |
| 530 are the possible completions. | |
| 428 | 531 |
| 444 | 532 If COLLECTION is a function, it is called with three arguments: the |
| 533 values STRING, PREDICATE and t. Whatever it returns becomes the | |
| 534 value of `all-completions'. | |
| 428 | 535 |
| 444 | 536 If optional third argument PREDICATE is non-nil, it is used to test |
| 537 each possible match. The match is a candidate only if PREDICATE | |
| 538 returns non-nil. The argument given to PREDICATE is the alist element | |
| 539 or the symbol from the obarray. | |
| 428 | 540 */ |
| 444 | 541 (string, collection, predicate)) |
| 428 | 542 { |
| 543 /* This function can GC */ | |
| 544 Lisp_Object tail; | |
| 545 Lisp_Object allmatches; | |
| 546 int list; | |
| 547 int indice = 0; | |
| 548 int obsize; | |
| 549 Lisp_Object bucket; | |
| 550 Charcount slength; | |
| 551 | |
| 552 CHECK_STRING (string); | |
| 553 | |
| 444 | 554 if (CONSP (collection)) |
| 428 | 555 { |
| 444 | 556 Lisp_Object tem = XCAR (collection); |
| 428 | 557 if (SYMBOLP (tem)) /* lambda, autoload, etc. Emacs-lisp sucks */ |
| 444 | 558 return call3 (collection, string, predicate, Qt); |
| 428 | 559 else |
| 560 list = 1; | |
| 561 } | |
| 444 | 562 else if (VECTORP (collection)) |
| 428 | 563 list = 0; |
| 444 | 564 else if (NILP (collection)) |
| 428 | 565 list = 1; |
| 566 else | |
| 444 | 567 return call3 (collection, string, predicate, Qt); |
| 428 | 568 |
| 569 allmatches = Qnil; | |
| 826 | 570 slength = string_char_length (string); |
| 428 | 571 |
| 444 | 572 /* If COLLECTION is not a list, set TAIL just for gc pro. */ |
| 573 tail = collection; | |
| 428 | 574 if (!list) |
| 575 { | |
| 444 | 576 obsize = XVECTOR_LENGTH (collection); |
| 577 bucket = XVECTOR_DATA (collection)[indice]; | |
| 428 | 578 } |
| 579 else /* warning suppression */ | |
| 580 { | |
| 581 obsize = 0; | |
| 582 bucket = Qnil; | |
| 583 } | |
| 584 | |
| 585 while (1) | |
| 586 { | |
| 587 /* Get the next element of the alist or obarray. */ | |
| 588 /* Exit the loop if the elements are all used up. */ | |
| 589 /* elt gets the alist element or symbol. | |
| 590 eltstring gets the name to check as a completion. */ | |
| 591 Lisp_Object elt; | |
| 592 Lisp_Object eltstring; | |
| 593 | |
| 594 if (list) | |
| 595 { | |
| 596 if (NILP (tail)) | |
| 597 break; | |
| 598 elt = Fcar (tail); | |
| 599 eltstring = Fcar (elt); | |
| 600 tail = Fcdr (tail); | |
| 601 } | |
| 602 else | |
| 603 { | |
| 604 if (!ZEROP (bucket)) | |
| 605 { | |
| 440 | 606 Lisp_Symbol *next = symbol_next (XSYMBOL (bucket)); |
| 428 | 607 elt = bucket; |
| 608 eltstring = Fsymbol_name (elt); | |
| 609 if (next) | |
| 793 | 610 bucket = wrap_symbol (next); |
| 428 | 611 else |
| 612 bucket = Qzero; | |
| 613 } | |
| 614 else if (++indice >= obsize) | |
| 615 break; | |
| 616 else | |
| 617 { | |
| 444 | 618 bucket = XVECTOR_DATA (collection)[indice]; |
| 428 | 619 continue; |
| 620 } | |
| 621 } | |
| 622 | |
| 623 /* Is this element a possible completion? */ | |
| 624 | |
| 625 if (STRINGP (eltstring) | |
| 826 | 626 && (slength <= string_char_length (eltstring)) |
| 448 | 627 /* Reject alternatives that start with space |
| 628 unless the input starts with space. */ | |
| 826 | 629 && ((string_char_length (string) > 0 && |
| 867 | 630 string_ichar (string, 0) == ' ') |
| 631 || string_ichar (eltstring, 0) != ' ') | |
| 448 | 632 && (0 > scmp (XSTRING_DATA (eltstring), |
| 428 | 633 XSTRING_DATA (string), |
| 634 slength))) | |
| 635 { | |
| 636 /* Yes. Now check whether predicate likes it. */ | |
| 637 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; | |
| 638 int loser; | |
| 639 GCPRO4 (tail, eltstring, allmatches, string); | |
| 444 | 640 loser = ignore_completion_p (eltstring, predicate, elt); |
| 428 | 641 UNGCPRO; |
| 642 if (!loser) | |
| 643 /* Ok => put it on the list. */ | |
| 644 allmatches = Fcons (eltstring, allmatches); | |
| 645 } | |
| 646 } | |
| 647 | |
| 648 return Fnreverse (allmatches); | |
| 649 } | |
| 650 | |
| 651 /* Useless FSFmacs functions */ | |
| 652 /* More than useless. I've nuked minibuf_prompt_width so they won't | |
| 653 function at all in XEmacs at the moment. They are used to | |
| 654 implement some braindamage in FSF which we aren't including. --cet */ | |
| 655 | |
| 656 #if 0 | |
| 826 | 657 DEFUN ("minibuffer-prompt", Fminibuffer_prompt, 0, 0, 0, /* |
| 428 | 658 Return the prompt string of the currently-active minibuffer. |
| 659 If no minibuffer is active, return nil. | |
| 660 */ | |
| 661 ()) | |
| 662 { | |
| 663 return Fcopy_sequence (Vminibuf_prompt); | |
| 664 } | |
| 665 | |
| 826 | 666 DEFUN ("minibuffer-prompt-width", Fminibuffer_prompt_width, 0, 0, 0, /* |
| 428 | 667 Return the display width of the minibuffer prompt. |
| 668 */ | |
| 669 ()) | |
| 670 { | |
| 671 return make_int (minibuf_prompt_width); | |
| 672 } | |
| 673 #endif /* 0 */ | |
| 674 | |
| 675 | |
| 676 /************************************************************************/ | |
| 677 /* echo area */ | |
| 678 /************************************************************************/ | |
| 679 | |
| 680 extern int stdout_needs_newline; | |
| 681 | |
| 682 static Lisp_Object | |
| 683 clear_echo_area_internal (struct frame *f, Lisp_Object label, int from_print, | |
| 684 int no_restore) | |
| 685 { | |
| 686 /* This function can call lisp */ | |
| 687 if (!NILP (Ffboundp (Qclear_message))) | |
| 688 { | |
| 793 | 689 Lisp_Object frame = wrap_frame (f); |
| 428 | 690 |
| 691 return call4 (Qclear_message, label, frame, from_print ? Qt : Qnil, | |
| 692 no_restore ? Qt : Qnil); | |
| 693 } | |
| 694 else | |
| 695 { | |
| 771 | 696 stderr_out ("\n"); |
| 428 | 697 return Qnil; |
| 698 } | |
| 699 } | |
| 700 | |
| 701 Lisp_Object | |
| 702 clear_echo_area (struct frame *f, Lisp_Object label, int no_restore) | |
| 703 { | |
| 704 /* This function can call lisp */ | |
| 705 return clear_echo_area_internal (f, label, 0, no_restore); | |
| 706 } | |
| 707 | |
| 708 Lisp_Object | |
| 709 clear_echo_area_from_print (struct frame *f, Lisp_Object label, int no_restore) | |
| 710 { | |
| 711 /* This function can call lisp */ | |
| 712 return clear_echo_area_internal (f, label, 1, no_restore); | |
| 713 } | |
| 714 | |
| 715 void | |
| 867 | 716 echo_area_append (struct frame *f, const Ibyte *nonreloc, Lisp_Object reloc, |
| 428 | 717 Bytecount offset, Bytecount length, |
| 718 Lisp_Object label) | |
| 719 { | |
| 720 /* This function can call lisp */ | |
| 721 Lisp_Object obj; | |
| 722 struct gcpro gcpro1; | |
| 723 Lisp_Object frame; | |
| 724 | |
| 440 | 725 /* There is an inlining bug in egcs-20000131 c++ that can be worked |
| 726 around as follows: */ | |
| 727 #if defined (__GNUC__) && defined (__cplusplus) | |
| 728 alloca (4); | |
| 729 #endif | |
| 730 | |
| 428 | 731 /* some callers pass in a null string as a way of clearing the echo area. |
| 732 check for length == 0 now; if this case, neither nonreloc nor reloc | |
| 733 may be valid. */ | |
| 734 if (length == 0) | |
| 735 return; | |
| 736 | |
| 737 fixup_internal_substring (nonreloc, reloc, offset, &length); | |
| 738 | |
| 739 /* also check it here, in case the string was really blank. */ | |
| 740 if (length == 0) | |
| 741 return; | |
| 742 | |
| 743 if (!NILP (Ffboundp (Qappend_message))) | |
| 744 { | |
| 745 if (STRINGP (reloc) && offset == 0 && length == XSTRING_LENGTH (reloc)) | |
| 746 obj = reloc; | |
| 747 else | |
| 748 { | |
| 749 if (STRINGP (reloc)) | |
| 750 nonreloc = XSTRING_DATA (reloc); | |
| 751 obj = make_string (nonreloc + offset, length); | |
| 752 } | |
| 753 | |
| 793 | 754 frame = wrap_frame (f); |
| 428 | 755 GCPRO1 (obj); |
| 756 call4 (Qappend_message, label, obj, frame, | |
| 757 EQ (label, Qprint) ? Qt : Qnil); | |
| 758 UNGCPRO; | |
| 759 } | |
| 760 else | |
| 761 { | |
| 762 if (STRINGP (reloc)) | |
| 763 nonreloc = XSTRING_DATA (reloc); | |
| 826 | 764 write_string_1 (Qexternal_debugging_output, nonreloc + offset, length); |
| 428 | 765 } |
| 766 } | |
| 767 | |
| 768 void | |
| 867 | 769 echo_area_message (struct frame *f, const Ibyte *nonreloc, |
| 428 | 770 Lisp_Object reloc, Bytecount offset, Bytecount length, |
| 771 Lisp_Object label) | |
| 772 { | |
| 773 /* This function can call lisp */ | |
| 774 clear_echo_area (f, label, 1); | |
| 775 echo_area_append (f, nonreloc, reloc, offset, length, label); | |
| 776 } | |
| 777 | |
| 778 int | |
| 2286 | 779 echo_area_active (struct frame *UNUSED (f)) |
| 428 | 780 { |
| 781 /* By definition, the echo area is active if the echo-area buffer | |
| 782 is not empty. No need to call Lisp code. (Anyway, this function | |
| 783 is called from redisplay.) */ | |
| 784 struct buffer *echo_buffer = XBUFFER (Vecho_area_buffer); | |
| 785 return BUF_BEGV (echo_buffer) != BUF_ZV (echo_buffer); | |
| 786 } | |
| 787 | |
| 788 Lisp_Object | |
| 789 echo_area_status (struct frame *f) | |
| 790 { | |
| 791 /* This function can call lisp */ | |
| 792 if (!NILP (Ffboundp (Qcurrent_message_label))) | |
| 793 { | |
| 793 | 794 Lisp_Object frame = wrap_frame (f); |
| 428 | 795 |
| 796 return call1 (Qcurrent_message_label, frame); | |
| 797 } | |
| 798 else | |
| 799 return stdout_needs_newline ? Qmessage : Qnil; | |
| 800 } | |
| 801 | |
| 802 Lisp_Object | |
| 2286 | 803 echo_area_contents (struct frame *UNUSED (f)) |
| 428 | 804 { |
| 805 /* See above. By definition, the contents of the echo-area buffer | |
| 806 are the contents of the echo area. */ | |
| 807 return Fbuffer_substring (Qnil, Qnil, Vecho_area_buffer); | |
| 808 } | |
| 809 | |
| 810 /* Dump an informative message to the echo area. This function takes a | |
| 811 string in internal format. */ | |
| 812 void | |
| 867 | 813 message_internal (const Ibyte *nonreloc, Lisp_Object reloc, |
| 428 | 814 Bytecount offset, Bytecount length) |
| 815 { | |
| 816 /* This function can call lisp */ | |
| 817 if (NILP (Vexecuting_macro)) | |
| 818 echo_area_message (selected_frame (), nonreloc, reloc, offset, length, | |
| 819 Qmessage); | |
| 820 } | |
| 821 | |
| 822 void | |
| 867 | 823 message_append_internal (const Ibyte *nonreloc, Lisp_Object reloc, |
| 428 | 824 Bytecount offset, Bytecount length) |
| 825 { | |
| 826 /* This function can call lisp */ | |
| 827 if (NILP (Vexecuting_macro)) | |
| 828 echo_area_append (selected_frame (), nonreloc, reloc, offset, length, | |
| 829 Qmessage); | |
| 830 } | |
| 831 | |
| 832 /* The next three functions are interfaces to message_internal() that | |
| 833 take strings in external format. message() does I18N3 translating | |
| 834 on the format string; message_no_translate() does not. */ | |
| 835 | |
| 836 static void | |
| 867 | 837 message_1 (const CIbyte *fmt, va_list args) |
| 428 | 838 { |
| 839 /* This function can call lisp */ | |
| 840 if (fmt) | |
| 841 { | |
| 842 struct gcpro gcpro1; | |
| 843 /* message_internal() might GC, e.g. if there are after-change-hooks | |
| 844 on the echo area buffer */ | |
| 771 | 845 Lisp_Object obj = emacs_vsprintf_string (fmt, args); |
| 428 | 846 GCPRO1 (obj); |
| 847 message_internal (0, obj, 0, -1); | |
| 848 UNGCPRO; | |
| 849 } | |
| 850 else | |
| 851 message_internal (0, Qnil, 0, 0); | |
| 852 } | |
| 853 | |
| 854 static void | |
| 867 | 855 message_append_1 (const CIbyte *fmt, va_list args) |
| 428 | 856 { |
| 857 /* This function can call lisp */ | |
| 858 if (fmt) | |
| 859 { | |
| 860 struct gcpro gcpro1; | |
| 861 /* message_internal() might GC, e.g. if there are after-change-hooks | |
| 862 on the echo area buffer */ | |
| 771 | 863 Lisp_Object obj = emacs_vsprintf_string (fmt, args); |
| 428 | 864 GCPRO1 (obj); |
| 865 message_append_internal (0, obj, 0, -1); | |
| 866 UNGCPRO; | |
| 867 } | |
| 868 else | |
| 869 message_append_internal (0, Qnil, 0, 0); | |
| 870 } | |
| 871 | |
| 872 void | |
| 873 clear_message (void) | |
| 874 { | |
| 875 /* This function can call lisp */ | |
| 876 message_internal (0, Qnil, 0, 0); | |
| 877 } | |
| 878 | |
| 879 void | |
| 442 | 880 message (const char *fmt, ...) |
| 428 | 881 { |
| 882 /* This function can call lisp */ | |
| 883 /* I think it's OK to pass the data of Lisp strings as arguments to | |
| 884 this function. No GC'ing will occur until the data has already | |
| 885 been copied. */ | |
| 886 va_list args; | |
| 887 | |
| 888 va_start (args, fmt); | |
| 889 if (fmt) | |
| 890 fmt = GETTEXT (fmt); | |
| 891 message_1 (fmt, args); | |
| 892 va_end (args); | |
| 893 } | |
| 894 | |
| 895 void | |
| 442 | 896 message_append (const char *fmt, ...) |
| 428 | 897 { |
| 898 /* This function can call lisp */ | |
| 899 va_list args; | |
| 900 | |
| 901 va_start (args, fmt); | |
| 902 if (fmt) | |
| 903 fmt = GETTEXT (fmt); | |
| 904 message_append_1 (fmt, args); | |
| 905 va_end (args); | |
| 906 } | |
| 907 | |
| 908 void | |
| 442 | 909 message_no_translate (const char *fmt, ...) |
| 428 | 910 { |
| 911 /* This function can call lisp */ | |
| 912 /* I think it's OK to pass the data of Lisp strings as arguments to | |
| 913 this function. No GC'ing will occur until the data has already | |
| 914 been copied. */ | |
| 915 va_list args; | |
| 916 | |
| 917 va_start (args, fmt); | |
| 918 message_1 (fmt, args); | |
| 919 va_end (args); | |
| 920 } | |
| 921 | |
| 922 | |
| 923 /************************************************************************/ | |
| 924 /* initialization */ | |
| 925 /************************************************************************/ | |
| 926 | |
| 927 void | |
| 928 syms_of_minibuf (void) | |
| 929 { | |
| 563 | 930 DEFSYMBOL (Qminibuffer_setup_hook); |
| 428 | 931 |
| 563 | 932 DEFSYMBOL (Qcompletion_ignore_case); |
| 428 | 933 |
| 934 DEFSUBR (Fminibuffer_depth); | |
| 935 #if 0 | |
| 936 DEFSUBR (Fminibuffer_prompt); | |
| 937 DEFSUBR (Fminibuffer_prompt_width); | |
| 938 #endif | |
| 939 DEFSUBR (Fset_minibuffer_preprompt); | |
| 940 DEFSUBR (Fread_minibuffer_internal); | |
| 941 | |
| 942 DEFSUBR (Ftry_completion); | |
| 943 DEFSUBR (Fall_completions); | |
| 944 | |
| 563 | 945 DEFSYMBOL (Qappend_message); |
| 946 DEFSYMBOL (Qclear_message); | |
| 947 DEFSYMBOL (Qdisplay_message); | |
| 948 DEFSYMBOL (Qcurrent_message_label); | |
| 428 | 949 } |
| 950 | |
| 951 void | |
| 952 reinit_vars_of_minibuf (void) | |
| 953 { | |
| 954 minibuf_level = 0; | |
| 955 } | |
| 956 | |
| 957 void | |
| 958 vars_of_minibuf (void) | |
| 959 { | |
| 960 staticpro (&Vminibuf_prompt); | |
| 961 Vminibuf_prompt = Qnil; | |
| 962 | |
| 963 /* Added by Jareth Hein (jhod@po.iijnet.or.jp) for input system support */ | |
| 964 staticpro (&Vminibuf_preprompt); | |
| 965 Vminibuf_preprompt = Qnil; | |
| 966 | |
| 967 DEFVAR_LISP ("minibuffer-setup-hook", &Vminibuffer_setup_hook /* | |
| 968 Normal hook run just after entry to minibuffer. | |
| 969 */ ); | |
| 970 Vminibuffer_setup_hook = Qnil; | |
| 971 | |
| 972 DEFVAR_BOOL ("completion-ignore-case", &completion_ignore_case /* | |
| 973 Non-nil means don't consider case significant in completion. | |
| 974 */ ); | |
| 975 completion_ignore_case = 0; | |
| 976 | |
| 977 DEFVAR_LISP ("completion-regexp-list", &Vcompletion_regexp_list /* | |
| 978 List of regexps that should restrict possible completions. | |
| 979 Each completion has to match all regexps in this list. | |
| 980 */ ); | |
| 981 Vcompletion_regexp_list = Qnil; | |
| 982 } | |
| 983 | |
| 984 void | |
| 985 reinit_complex_vars_of_minibuf (void) | |
| 986 { | |
| 987 /* This function can GC */ | |
| 988 #ifdef I18N3 | |
| 989 /* #### This needs to be fixed up so that the gettext() gets called | |
| 990 at runtime instead of at load time. */ | |
| 991 #endif | |
| 992 Vminibuffer_zero | |
| 993 = Fget_buffer_create | |
| 994 (build_string (DEFER_GETTEXT (" *Minibuf-0*"))); | |
| 995 Vecho_area_buffer | |
| 996 = Fget_buffer_create | |
| 997 (build_string (DEFER_GETTEXT (" *Echo Area*"))); | |
| 998 } | |
| 999 | |
| 1000 void | |
| 1001 complex_vars_of_minibuf (void) | |
| 1002 { | |
| 1003 reinit_complex_vars_of_minibuf (); | |
| 1004 } |