1 /* Minibuffer input and completion.
2 Copyright (C) 1985, 1986, 1992-1995 Free Software Foundation, Inc.
3 Copyright (C) 1995 Sun Microsystems, Inc.
5 This file is part of XEmacs.
7 XEmacs is free software; you can redistribute it and/or modify it
8 under the terms of the GNU General Public License as published by the
9 Free Software Foundation; either version 2, or (at your option) any
12 XEmacs is distributed in the hope that it will be useful, but WITHOUT
13 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with XEmacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
22 /* Synched up with: Mule 2.0, FSF 19.28. Mule-ized except as noted.
23 Substantially different from FSF. */
25 /* #### dmoore - All sorts of things in here can call lisp, like message.
26 Track all this stuff. */
33 #include "console-stream.h"
37 #include "redisplay.h"
40 /* Depth in minibuffer invocations. */
43 Lisp_Object Qcompletion_ignore_case;
45 /* Nonzero means completion ignores case. */
46 int completion_ignore_case;
48 /* List of regexps that should restrict possible completions. */
49 Lisp_Object Vcompletion_regexp_list;
51 /* The echo area buffer. */
52 Lisp_Object Vecho_area_buffer;
54 /* Prompt to display in front of the minibuffer contents */
55 Lisp_Object Vminibuf_prompt;
57 /* Added on 97/3/14 by Jareth Hein (jhod@po.iijnet.or.jp) for input system support */
58 /* String to be displayed in front of prompt of the minibuffer contents */
59 Lisp_Object Vminibuf_preprompt;
61 /* Hook to run just after entry to minibuffer. */
62 Lisp_Object Qminibuffer_setup_hook, Vminibuffer_setup_hook;
64 Lisp_Object Qappend_message, Qcurrent_message_label,
65 Qclear_message, Qdisplay_message;
68 DEFUN ("minibuffer-depth", Fminibuffer_depth, 0, 0, 0, /*
69 Return current depth of activations of minibuffer, a nonnegative integer.
73 return make_int (minibuf_level);
76 /* The default buffer to use as the window-buffer of minibuffer windows */
77 /* Note there is special code in kill-buffer to make this unkillable */
78 Lisp_Object Vminibuffer_zero;
81 /* Actual minibuffer invocation. */
84 read_minibuffer_internal_unwind (Lisp_Object unwind_data)
87 XWINDOW (minibuf_window)->last_modified[CURRENT_DISP] = Qzero;
88 XWINDOW (minibuf_window)->last_modified[DESIRED_DISP] = Qzero;
89 XWINDOW (minibuf_window)->last_modified[CMOTION_DISP] = Qzero;
90 XWINDOW (minibuf_window)->last_facechange[CURRENT_DISP] = Qzero;
91 XWINDOW (minibuf_window)->last_facechange[DESIRED_DISP] = Qzero;
92 XWINDOW (minibuf_window)->last_facechange[CMOTION_DISP] = Qzero;
93 Vminibuf_prompt = Felt (unwind_data, Qzero);
94 minibuf_level = XINT (Felt (unwind_data, make_int (1)));
95 while (CONSP (unwind_data))
97 Lisp_Object victim = unwind_data;
98 unwind_data = XCDR (unwind_data);
99 free_cons (XCONS (victim));
102 /* If cursor is on the minibuffer line,
103 show the user we have exited by putting it in column 0. */
104 frame = Fselected_frame (Qnil);
107 && !NILP (XFRAME (frame)->minibuffer_window))
109 struct window *w = XWINDOW (XFRAME (frame)->minibuffer_window);
110 redisplay_move_cursor (w, 0, 0);
116 /* 97/4/13 jhod: Added for input methods */
117 DEFUN ("set-minibuffer-preprompt", Fset_minibuffer_preprompt, 1, 1, 0, /*
118 Set the minibuffer preprompt string to PREPROMPT. This is used by language
119 input methods to relay state information to the user.
123 if (NILP (preprompt))
125 Vminibuf_preprompt = Qnil;
129 CHECK_STRING (preprompt);
131 Vminibuf_preprompt = LISP_GETTEXT (preprompt);
136 DEFUN ("read-minibuffer-internal", Fread_minibuffer_internal, 1, 1, 0, /*
137 Lowest-level interface to minibuffers. Don't call this.
141 /* This function can GC */
142 int speccount = specpdl_depth ();
145 CHECK_STRING (prompt);
147 single_console_state ();
149 record_unwind_protect (read_minibuffer_internal_unwind,
152 noseeum_cons (make_int (minibuf_level), Qnil)));
153 Vminibuf_prompt = LISP_GETTEXT (prompt);
155 /* NOTE: Here (or somewhere around here), in FSFmacs 19.30,
156 choose_minibuf_frame() is called. This is the only
157 place in FSFmacs that it's called any more -- there's
158 also a call in xterm.c, but commented out, and 19.28
159 had the calls in different places.
161 choose_minibuf_frame() does the following:
163 if (!EQ (minibuf_window, selected_frame()->minibuffer_window))
165 Fset_window_buffer (selected_frame()->minibuffer_window,
166 XWINDOW (minibuf_window)->buffer);
167 minibuf_window = selected_frame()->minibuffer_window;
170 #### Note that we don't do the set-window-buffer. This call is
171 similar, but not identical, to a set-window-buffer call made
172 in `read-from-minibuffer' in minibuf.el. I hope it's close
173 enough, because minibuf_window isn't really exported to Lisp.
175 The comment above choose_minibuf_frame() reads:
177 Put minibuf on currently selected frame's minibuffer.
178 We do this whenever the user starts a new minibuffer
179 or when a minibuffer exits. */
181 minibuf_window = FRAME_MINIBUF_WINDOW (selected_frame ());
183 run_hook (Qminibuffer_setup_hook);
186 clear_echo_area (selected_frame (), Qnil, 0);
188 val = call_command_loop (Qt);
190 return unbind_to (speccount, val);
195 /* Completion hair */
197 /* Compare exactly LEN chars of strings at S1 and S2,
198 ignoring case if appropriate.
199 Return -1 if strings match,
200 else number of chars that match at the beginning. */
202 /* Note that this function works in Charcounts, unlike most functions.
203 This is necessary for many reasons, one of which is that two
204 strings may match even if they have different numbers of bytes,
205 if IGNORE_CASE is true. */
208 scmp_1 (const Bufbyte *s1, const Bufbyte *s2, Charcount len,
217 Emchar c1 = DOWNCASE (current_buffer, charptr_emchar (s1));
218 Emchar c2 = DOWNCASE (current_buffer, charptr_emchar (s2));
232 while (l && charptr_emchar (s1) == charptr_emchar (s2))
247 regexp_ignore_completion_p (const Bufbyte *nonreloc,
248 Lisp_Object reloc, Bytecount offset,
251 /* Ignore this element if it fails to match all the regexps. */
252 if (!NILP (Vcompletion_regexp_list))
255 EXTERNAL_LIST_LOOP (regexps, Vcompletion_regexp_list)
257 Lisp_Object re = XCAR (regexps);
259 if (fast_string_match (re, nonreloc, reloc, offset,
260 length, 0, ERROR_ME, 0) < 0)
268 /* Callers should GCPRO, since this may call eval */
270 ignore_completion_p (Lisp_Object completion_string,
271 Lisp_Object pred, Lisp_Object completion)
273 if (regexp_ignore_completion_p (0, completion_string, 0, -1))
276 /* Ignore this element if there is a predicate
277 and the predicate doesn't like it. */
281 if (EQ (pred, Qcommandp))
282 tem = Fcommandp (completion);
284 tem = call1 (pred, completion);
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.
298 To do so, there should probably be a
299 map_obarray_or_alist_or_hash_table function which would be used by
300 both Ftry_completion and Fall_completions. But would the
301 additional funcalls slow things down? */
303 DEFUN ("try-completion", Ftry_completion, 2, 3, 0, /*
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.
307 All that match are compared together; the longest initial sequence
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.
311 If COLLECTION is an alist, the cars of the elements of the alist
312 \(which must be strings) form the set of possible completions.
314 If COLLECTION is an obarray, the names of all symbols in the obarray
315 are the possible completions.
317 If COLLECTION is a function, it is called with three arguments: the
318 values STRING, PREDICATE and nil. Whatever it returns becomes the
319 value of `try-completion'.
321 If optional third argument PREDICATE is non-nil, it is used to test
322 each possible match. The match is a candidate only if PREDICATE
323 returns non-nil. The argument given to PREDICATE is the alist element
324 or the symbol from the obarray.
326 (string, collection, predicate))
328 /* This function can GC */
329 Lisp_Object bestmatch, tail;
330 Charcount bestmatchsize = 0;
336 Charcount slength, blength;
338 CHECK_STRING (string);
340 if (CONSP (collection))
342 Lisp_Object tem = XCAR (collection);
343 if (SYMBOLP (tem)) /* lambda, autoload, etc. Emacs-lisp sucks */
344 return call3 (collection, string, predicate, Qnil);
348 else if (VECTORP (collection))
350 else if (NILP (collection))
353 return call3 (collection, string, predicate, Qnil);
357 slength = XSTRING_CHAR_LENGTH (string);
359 /* If COLLECTION is not a list, set TAIL just for gc pro. */
363 obsize = XVECTOR_LENGTH (collection);
364 bucket = XVECTOR_DATA (collection)[indice];
366 else /* warning suppression */
374 /* Get the next element of the alist or obarray. */
375 /* Exit the loop if the elements are all used up. */
376 /* elt gets the alist element or symbol.
377 eltstring gets the name to check as a completion. */
379 Lisp_Object eltstring;
386 eltstring = Fcar (elt);
394 if (!SYMBOLP (bucket))
396 signal_simple_error ("Bad obarray passed to try-completions",
399 next = symbol_next (XSYMBOL (bucket));
401 eltstring = Fsymbol_name (elt);
403 XSETSYMBOL (bucket, next);
407 else if (++indice >= obsize)
411 bucket = XVECTOR_DATA (collection)[indice];
416 /* Is this element a possible completion? */
418 if (STRINGP (eltstring))
420 Charcount eltlength = XSTRING_CHAR_LENGTH (eltstring);
421 if (slength <= eltlength
422 && (0 > scmp (XSTRING_DATA (eltstring),
423 XSTRING_DATA (string),
427 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
429 GCPRO4 (tail, string, eltstring, bestmatch);
430 loser = ignore_completion_p (eltstring, predicate, elt);
432 if (loser) /* reject this one */
436 /* Update computation of how much all possible
440 if (NILP (bestmatch))
442 bestmatch = eltstring;
444 bestmatchsize = eltlength;
448 Charcount compare = min (bestmatchsize, eltlength);
449 Charcount matchsize =
450 scmp (XSTRING_DATA (bestmatch),
451 XSTRING_DATA (eltstring),
455 if (completion_ignore_case)
457 /* If this is an exact match except for case,
458 use it as the best match rather than one that is not
459 an exact match. This way, we get the case pattern
460 of the actual match. */
461 if ((matchsize == eltlength
462 && matchsize < blength)
464 /* If there is more than one exact match ignoring
465 case, and one of them is exact including case,
467 /* If there is no exact match ignoring case,
468 prefer a match that does not change the case
470 ((matchsize == eltlength)
472 (matchsize == blength)
473 && 0 > scmp_1 (XSTRING_DATA (eltstring),
474 XSTRING_DATA (string),
476 && 0 <= scmp_1 (XSTRING_DATA (bestmatch),
477 XSTRING_DATA (string),
480 bestmatch = eltstring;
484 bestmatchsize = matchsize;
490 if (NILP (bestmatch))
491 return Qnil; /* No completions found */
492 /* If we are ignoring case, and there is no exact match,
493 and no additional text was supplied,
494 don't change the case of what the user typed. */
495 if (completion_ignore_case
496 && bestmatchsize == slength
497 && blength > bestmatchsize)
500 /* Return t if the supplied string is an exact match (counting case);
501 it does not require any change to be made. */
503 && bestmatchsize == slength
504 && 0 > scmp_1 (XSTRING_DATA (bestmatch),
505 XSTRING_DATA (string),
509 /* Else extract the part in which all completions agree */
510 return Fsubstring (bestmatch, Qzero, make_int (bestmatchsize));
514 DEFUN ("all-completions", Fall_completions, 2, 3, 0, /*
515 Search for partial matches to STRING in COLLECTION.
516 COLLECTION must be an alist, an obarray, or a function.
517 Each string in COLLECTION is tested to see if it begins with STRING.
518 The value is a list of all the strings from COLLECTION that match.
520 If COLLECTION is an alist, the cars of the elements of the alist
521 \(which must be strings) form the set of possible completions.
523 If COLLECTION is an obarray, the names of all symbols in the obarray
524 are the possible completions.
526 If COLLECTION is a function, it is called with three arguments: the
527 values STRING, PREDICATE and t. Whatever it returns becomes the
528 value of `all-completions'.
530 If optional third argument PREDICATE is non-nil, it is used to test
531 each possible match. The match is a candidate only if PREDICATE
532 returns non-nil. The argument given to PREDICATE is the alist element
533 or the symbol from the obarray.
535 (string, collection, predicate))
537 /* This function can GC */
539 Lisp_Object allmatches;
546 CHECK_STRING (string);
548 if (CONSP (collection))
550 Lisp_Object tem = XCAR (collection);
551 if (SYMBOLP (tem)) /* lambda, autoload, etc. Emacs-lisp sucks */
552 return call3 (collection, string, predicate, Qt);
556 else if (VECTORP (collection))
558 else if (NILP (collection))
561 return call3 (collection, string, predicate, Qt);
564 slength = XSTRING_CHAR_LENGTH (string);
566 /* If COLLECTION is not a list, set TAIL just for gc pro. */
570 obsize = XVECTOR_LENGTH (collection);
571 bucket = XVECTOR_DATA (collection)[indice];
573 else /* warning suppression */
581 /* Get the next element of the alist or obarray. */
582 /* Exit the loop if the elements are all used up. */
583 /* elt gets the alist element or symbol.
584 eltstring gets the name to check as a completion. */
586 Lisp_Object eltstring;
593 eltstring = Fcar (elt);
600 Lisp_Symbol *next = symbol_next (XSYMBOL (bucket));
602 eltstring = Fsymbol_name (elt);
604 XSETSYMBOL (bucket, next);
608 else if (++indice >= obsize)
612 bucket = XVECTOR_DATA (collection)[indice];
617 /* Is this element a possible completion? */
619 if (STRINGP (eltstring)
620 && (slength <= XSTRING_CHAR_LENGTH (eltstring))
621 /* Reject alternatives that start with space
622 unless the input starts with space. */
623 && ((XSTRING_CHAR_LENGTH (string) > 0 &&
624 string_char (XSTRING (string), 0) == ' ')
625 || string_char (XSTRING (eltstring), 0) != ' ')
626 && (0 > scmp (XSTRING_DATA (eltstring),
627 XSTRING_DATA (string),
630 /* Yes. Now check whether predicate likes it. */
631 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
633 GCPRO4 (tail, eltstring, allmatches, string);
634 loser = ignore_completion_p (eltstring, predicate, elt);
637 /* Ok => put it on the list. */
638 allmatches = Fcons (eltstring, allmatches);
642 return Fnreverse (allmatches);
645 /* Useless FSFmacs functions */
646 /* More than useless. I've nuked minibuf_prompt_width so they won't
647 function at all in XEmacs at the moment. They are used to
648 implement some braindamage in FSF which we aren't including. --cet */
651 xxDEFUN ("minibuffer-prompt", Fminibuffer_prompt, 0, 0, 0, /*
652 Return the prompt string of the currently-active minibuffer.
653 If no minibuffer is active, return nil.
657 return Fcopy_sequence (Vminibuf_prompt);
660 xxDEFUN ("minibuffer-prompt-width", Fminibuffer_prompt_width, 0, 0, 0, /*
661 Return the display width of the minibuffer prompt.
665 return make_int (minibuf_prompt_width);
670 /************************************************************************/
672 /************************************************************************/
674 extern int stdout_needs_newline;
677 clear_echo_area_internal (struct frame *f, Lisp_Object label, int from_print,
680 /* This function can call lisp */
681 if (!NILP (Ffboundp (Qclear_message)))
685 XSETFRAME (frame, f);
686 return call4 (Qclear_message, label, frame, from_print ? Qt : Qnil,
687 no_restore ? Qt : Qnil);
691 write_string_to_stdio_stream (stderr, 0, (const Bufbyte *) "\n", 0, 1,
698 clear_echo_area (struct frame *f, Lisp_Object label, int no_restore)
700 /* This function can call lisp */
701 return clear_echo_area_internal (f, label, 0, no_restore);
705 clear_echo_area_from_print (struct frame *f, Lisp_Object label, int no_restore)
707 /* This function can call lisp */
708 return clear_echo_area_internal (f, label, 1, no_restore);
712 echo_area_append (struct frame *f, const Bufbyte *nonreloc, Lisp_Object reloc,
713 Bytecount offset, Bytecount length,
716 /* This function can call lisp */
721 /* There is an inlining bug in egcs-20000131 c++ that can be worked
722 around as follows: */
723 #if defined (__GNUC__) && defined (__cplusplus)
727 /* some callers pass in a null string as a way of clearing the echo area.
728 check for length == 0 now; if this case, neither nonreloc nor reloc
733 fixup_internal_substring (nonreloc, reloc, offset, &length);
735 /* also check it here, in case the string was really blank. */
739 if (!NILP (Ffboundp (Qappend_message)))
741 if (STRINGP (reloc) && offset == 0 && length == XSTRING_LENGTH (reloc))
746 nonreloc = XSTRING_DATA (reloc);
747 obj = make_string (nonreloc + offset, length);
750 XSETFRAME (frame, f);
752 call4 (Qappend_message, label, obj, frame,
753 EQ (label, Qprint) ? Qt : Qnil);
759 nonreloc = XSTRING_DATA (reloc);
760 write_string_to_stdio_stream (stderr, 0, nonreloc, offset, length,
766 echo_area_message (struct frame *f, const Bufbyte *nonreloc,
767 Lisp_Object reloc, Bytecount offset, Bytecount length,
770 /* This function can call lisp */
771 clear_echo_area (f, label, 1);
772 echo_area_append (f, nonreloc, reloc, offset, length, label);
776 echo_area_active (struct frame *f)
778 /* By definition, the echo area is active if the echo-area buffer
779 is not empty. No need to call Lisp code. (Anyway, this function
780 is called from redisplay.) */
781 struct buffer *echo_buffer = XBUFFER (Vecho_area_buffer);
782 return BUF_BEGV (echo_buffer) != BUF_ZV (echo_buffer);
786 echo_area_status (struct frame *f)
788 /* This function can call lisp */
789 if (!NILP (Ffboundp (Qcurrent_message_label)))
793 XSETFRAME (frame, f);
794 return call1 (Qcurrent_message_label, frame);
797 return stdout_needs_newline ? Qmessage : Qnil;
801 echo_area_contents (struct frame *f)
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);
808 /* Dump an informative message to the echo area. This function takes a
809 string in internal format. */
811 message_internal (const Bufbyte *nonreloc, Lisp_Object reloc,
812 Bytecount offset, Bytecount length)
814 /* This function can call lisp */
815 if (NILP (Vexecuting_macro))
816 echo_area_message (selected_frame (), nonreloc, reloc, offset, length,
821 message_append_internal (const Bufbyte *nonreloc, Lisp_Object reloc,
822 Bytecount offset, Bytecount length)
824 /* This function can call lisp */
825 if (NILP (Vexecuting_macro))
826 echo_area_append (selected_frame (), nonreloc, reloc, offset, length,
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. */
835 message_1 (const char *fmt, va_list args)
837 /* This function can call lisp */
841 /* message_internal() might GC, e.g. if there are after-change-hooks
842 on the echo area buffer */
843 Lisp_Object obj = emacs_doprnt_string_va ((const Bufbyte *) fmt, Qnil,
846 message_internal (0, obj, 0, -1);
850 message_internal (0, Qnil, 0, 0);
854 message_append_1 (const char *fmt, va_list args)
856 /* This function can call lisp */
860 /* message_internal() might GC, e.g. if there are after-change-hooks
861 on the echo area buffer */
862 Lisp_Object obj = emacs_doprnt_string_va ((const Bufbyte *) fmt, Qnil,
865 message_append_internal (0, obj, 0, -1);
869 message_append_internal (0, Qnil, 0, 0);
875 /* This function can call lisp */
876 message_internal (0, Qnil, 0, 0);
880 message (const char *fmt, ...)
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
888 va_start (args, fmt);
891 message_1 (fmt, args);
896 message_append (const char *fmt, ...)
898 /* This function can call lisp */
901 va_start (args, fmt);
904 message_append_1 (fmt, args);
909 message_no_translate (const char *fmt, ...)
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
917 va_start (args, fmt);
918 message_1 (fmt, args);
923 /************************************************************************/
925 /************************************************************************/
928 syms_of_minibuf (void)
930 defsymbol (&Qminibuffer_setup_hook, "minibuffer-setup-hook");
932 defsymbol (&Qcompletion_ignore_case, "completion-ignore-case");
934 DEFSUBR (Fminibuffer_depth);
936 DEFSUBR (Fminibuffer_prompt);
937 DEFSUBR (Fminibuffer_prompt_width);
939 DEFSUBR (Fset_minibuffer_preprompt);
940 DEFSUBR (Fread_minibuffer_internal);
942 DEFSUBR (Ftry_completion);
943 DEFSUBR (Fall_completions);
945 defsymbol (&Qappend_message, "append-message");
946 defsymbol (&Qclear_message, "clear-message");
947 defsymbol (&Qdisplay_message, "display-message");
948 defsymbol (&Qcurrent_message_label, "current-message-label");
952 reinit_vars_of_minibuf (void)
958 vars_of_minibuf (void)
960 reinit_vars_of_minibuf ();
962 staticpro (&Vminibuf_prompt);
963 Vminibuf_prompt = Qnil;
965 /* Added by Jareth Hein (jhod@po.iijnet.or.jp) for input system support */
966 staticpro (&Vminibuf_preprompt);
967 Vminibuf_preprompt = Qnil;
969 DEFVAR_LISP ("minibuffer-setup-hook", &Vminibuffer_setup_hook /*
970 Normal hook run just after entry to minibuffer.
972 Vminibuffer_setup_hook = Qnil;
974 DEFVAR_BOOL ("completion-ignore-case", &completion_ignore_case /*
975 Non-nil means don't consider case significant in completion.
977 completion_ignore_case = 0;
979 DEFVAR_LISP ("completion-regexp-list", &Vcompletion_regexp_list /*
980 List of regexps that should restrict possible completions.
981 Each completion has to match all regexps in this list.
983 Vcompletion_regexp_list = Qnil;
987 reinit_complex_vars_of_minibuf (void)
989 /* This function can GC */
991 /* #### This needs to be fixed up so that the gettext() gets called
992 at runtime instead of at load time. */
996 (build_string (DEFER_GETTEXT (" *Minibuf-0*")));
999 (build_string (DEFER_GETTEXT (" *Echo Area*")));
1003 complex_vars_of_minibuf (void)
1005 reinit_complex_vars_of_minibuf ();