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 && (0 > scmp (XSTRING_DATA (eltstring),
622 XSTRING_DATA (string),
625 /* Yes. Now check whether predicate likes it. */
626 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
628 GCPRO4 (tail, eltstring, allmatches, string);
629 loser = ignore_completion_p (eltstring, predicate, elt);
632 /* Ok => put it on the list. */
633 allmatches = Fcons (eltstring, allmatches);
637 return Fnreverse (allmatches);
640 /* Useless FSFmacs functions */
641 /* More than useless. I've nuked minibuf_prompt_width so they won't
642 function at all in XEmacs at the moment. They are used to
643 implement some braindamage in FSF which we aren't including. --cet */
646 xxDEFUN ("minibuffer-prompt", Fminibuffer_prompt, 0, 0, 0, /*
647 Return the prompt string of the currently-active minibuffer.
648 If no minibuffer is active, return nil.
652 return Fcopy_sequence (Vminibuf_prompt);
655 xxDEFUN ("minibuffer-prompt-width", Fminibuffer_prompt_width, 0, 0, 0, /*
656 Return the display width of the minibuffer prompt.
660 return make_int (minibuf_prompt_width);
665 /************************************************************************/
667 /************************************************************************/
669 extern int stdout_needs_newline;
672 clear_echo_area_internal (struct frame *f, Lisp_Object label, int from_print,
675 /* This function can call lisp */
676 if (!NILP (Ffboundp (Qclear_message)))
680 XSETFRAME (frame, f);
681 return call4 (Qclear_message, label, frame, from_print ? Qt : Qnil,
682 no_restore ? Qt : Qnil);
686 write_string_to_stdio_stream (stderr, 0, (const Bufbyte *) "\n", 0, 1,
693 clear_echo_area (struct frame *f, Lisp_Object label, int no_restore)
695 /* This function can call lisp */
696 return clear_echo_area_internal (f, label, 0, no_restore);
700 clear_echo_area_from_print (struct frame *f, Lisp_Object label, int no_restore)
702 /* This function can call lisp */
703 return clear_echo_area_internal (f, label, 1, no_restore);
707 echo_area_append (struct frame *f, const Bufbyte *nonreloc, Lisp_Object reloc,
708 Bytecount offset, Bytecount length,
711 /* This function can call lisp */
716 /* There is an inlining bug in egcs-20000131 c++ that can be worked
717 around as follows: */
718 #if defined (__GNUC__) && defined (__cplusplus)
722 /* some callers pass in a null string as a way of clearing the echo area.
723 check for length == 0 now; if this case, neither nonreloc nor reloc
728 fixup_internal_substring (nonreloc, reloc, offset, &length);
730 /* also check it here, in case the string was really blank. */
734 if (!NILP (Ffboundp (Qappend_message)))
736 if (STRINGP (reloc) && offset == 0 && length == XSTRING_LENGTH (reloc))
741 nonreloc = XSTRING_DATA (reloc);
742 obj = make_string (nonreloc + offset, length);
745 XSETFRAME (frame, f);
747 call4 (Qappend_message, label, obj, frame,
748 EQ (label, Qprint) ? Qt : Qnil);
754 nonreloc = XSTRING_DATA (reloc);
755 write_string_to_stdio_stream (stderr, 0, nonreloc, offset, length,
761 echo_area_message (struct frame *f, const Bufbyte *nonreloc,
762 Lisp_Object reloc, Bytecount offset, Bytecount length,
765 /* This function can call lisp */
766 clear_echo_area (f, label, 1);
767 echo_area_append (f, nonreloc, reloc, offset, length, label);
771 echo_area_active (struct frame *f)
773 /* By definition, the echo area is active if the echo-area buffer
774 is not empty. No need to call Lisp code. (Anyway, this function
775 is called from redisplay.) */
776 struct buffer *echo_buffer = XBUFFER (Vecho_area_buffer);
777 return BUF_BEGV (echo_buffer) != BUF_ZV (echo_buffer);
781 echo_area_status (struct frame *f)
783 /* This function can call lisp */
784 if (!NILP (Ffboundp (Qcurrent_message_label)))
788 XSETFRAME (frame, f);
789 return call1 (Qcurrent_message_label, frame);
792 return stdout_needs_newline ? Qmessage : Qnil;
796 echo_area_contents (struct frame *f)
798 /* See above. By definition, the contents of the echo-area buffer
799 are the contents of the echo area. */
800 return Fbuffer_substring (Qnil, Qnil, Vecho_area_buffer);
803 /* Dump an informative message to the echo area. This function takes a
804 string in internal format. */
806 message_internal (const Bufbyte *nonreloc, Lisp_Object reloc,
807 Bytecount offset, Bytecount length)
809 /* This function can call lisp */
810 if (NILP (Vexecuting_macro))
811 echo_area_message (selected_frame (), nonreloc, reloc, offset, length,
816 message_append_internal (const Bufbyte *nonreloc, Lisp_Object reloc,
817 Bytecount offset, Bytecount length)
819 /* This function can call lisp */
820 if (NILP (Vexecuting_macro))
821 echo_area_append (selected_frame (), nonreloc, reloc, offset, length,
825 /* The next three functions are interfaces to message_internal() that
826 take strings in external format. message() does I18N3 translating
827 on the format string; message_no_translate() does not. */
830 message_1 (const char *fmt, va_list args)
832 /* This function can call lisp */
836 /* message_internal() might GC, e.g. if there are after-change-hooks
837 on the echo area buffer */
838 Lisp_Object obj = emacs_doprnt_string_va ((const Bufbyte *) fmt, Qnil,
841 message_internal (0, obj, 0, -1);
845 message_internal (0, Qnil, 0, 0);
849 message_append_1 (const char *fmt, va_list args)
851 /* This function can call lisp */
855 /* message_internal() might GC, e.g. if there are after-change-hooks
856 on the echo area buffer */
857 Lisp_Object obj = emacs_doprnt_string_va ((const Bufbyte *) fmt, Qnil,
860 message_append_internal (0, obj, 0, -1);
864 message_append_internal (0, Qnil, 0, 0);
870 /* This function can call lisp */
871 message_internal (0, Qnil, 0, 0);
875 message (const char *fmt, ...)
877 /* This function can call lisp */
878 /* I think it's OK to pass the data of Lisp strings as arguments to
879 this function. No GC'ing will occur until the data has already
883 va_start (args, fmt);
886 message_1 (fmt, args);
891 message_append (const char *fmt, ...)
893 /* This function can call lisp */
896 va_start (args, fmt);
899 message_append_1 (fmt, args);
904 message_no_translate (const char *fmt, ...)
906 /* This function can call lisp */
907 /* I think it's OK to pass the data of Lisp strings as arguments to
908 this function. No GC'ing will occur until the data has already
912 va_start (args, fmt);
913 message_1 (fmt, args);
918 /************************************************************************/
920 /************************************************************************/
923 syms_of_minibuf (void)
925 defsymbol (&Qminibuffer_setup_hook, "minibuffer-setup-hook");
927 defsymbol (&Qcompletion_ignore_case, "completion-ignore-case");
929 DEFSUBR (Fminibuffer_depth);
931 DEFSUBR (Fminibuffer_prompt);
932 DEFSUBR (Fminibuffer_prompt_width);
934 DEFSUBR (Fset_minibuffer_preprompt);
935 DEFSUBR (Fread_minibuffer_internal);
937 DEFSUBR (Ftry_completion);
938 DEFSUBR (Fall_completions);
940 defsymbol (&Qappend_message, "append-message");
941 defsymbol (&Qclear_message, "clear-message");
942 defsymbol (&Qdisplay_message, "display-message");
943 defsymbol (&Qcurrent_message_label, "current-message-label");
947 reinit_vars_of_minibuf (void)
953 vars_of_minibuf (void)
955 reinit_vars_of_minibuf ();
957 staticpro (&Vminibuf_prompt);
958 Vminibuf_prompt = Qnil;
960 /* Added by Jareth Hein (jhod@po.iijnet.or.jp) for input system support */
961 staticpro (&Vminibuf_preprompt);
962 Vminibuf_preprompt = Qnil;
964 DEFVAR_LISP ("minibuffer-setup-hook", &Vminibuffer_setup_hook /*
965 Normal hook run just after entry to minibuffer.
967 Vminibuffer_setup_hook = Qnil;
969 DEFVAR_BOOL ("completion-ignore-case", &completion_ignore_case /*
970 Non-nil means don't consider case significant in completion.
972 completion_ignore_case = 0;
974 DEFVAR_LISP ("completion-regexp-list", &Vcompletion_regexp_list /*
975 List of regexps that should restrict possible completions.
976 Each completion has to match all regexps in this list.
978 Vcompletion_regexp_list = Qnil;
982 reinit_complex_vars_of_minibuf (void)
984 /* This function can GC */
986 /* #### This needs to be fixed up so that the gettext() gets called
987 at runtime instead of at load time. */
991 (build_string (DEFER_GETTEXT (" *Minibuf-0*")));
994 (build_string (DEFER_GETTEXT (" *Echo Area*")));
998 complex_vars_of_minibuf (void)
1000 reinit_complex_vars_of_minibuf ();