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