update.
[chise/xemacs-chise.git-] / src / minibuf.c
1 /* Minibuffer input and completion.
2    Copyright (C) 1985, 1986, 1992-1995 Free Software Foundation, Inc.
3    Copyright (C) 1995 Sun Microsystems, Inc.
4
5 This file is part of XEmacs.
6
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
10 later version.
11
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
15 for more details.
16
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.  */
21
22 /* Synched up with: Mule 2.0, FSF 19.28.  Mule-ized except as noted.
23    Substantially different from FSF. */
24
25 /* #### dmoore - All sorts of things in here can call lisp, like message.
26    Track all this stuff. */
27
28 #include <config.h>
29 #include "lisp.h"
30
31 #include "buffer.h"
32 #include "commands.h"
33 #include "console-stream.h"
34 #include "events.h"
35 #include "frame.h"
36 #include "insdel.h"
37 #include "redisplay.h"
38 #include "window.h"
39
40 /* Depth in minibuffer invocations.  */
41 int minibuf_level;
42
43 Lisp_Object Qcompletion_ignore_case;
44
45 /* Nonzero means completion ignores case.  */
46 int completion_ignore_case;
47
48 /* List of regexps that should restrict possible completions.  */
49 Lisp_Object Vcompletion_regexp_list;
50
51 /* The echo area buffer. */
52 Lisp_Object Vecho_area_buffer;
53
54 /* Prompt to display in front of the minibuffer contents */
55 Lisp_Object Vminibuf_prompt;
56
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;
60
61 /* Hook to run just after entry to minibuffer. */
62 Lisp_Object Qminibuffer_setup_hook, Vminibuffer_setup_hook;
63
64 Lisp_Object Qappend_message, Qcurrent_message_label,
65             Qclear_message, Qdisplay_message;
66
67 \f
68 DEFUN ("minibuffer-depth", Fminibuffer_depth, 0, 0, 0, /*
69 Return current depth of activations of minibuffer, a nonnegative integer.
70 */
71        ())
72 {
73   return make_int (minibuf_level);
74 }
75
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;
79
80 \f
81 /* Actual minibuffer invocation. */
82
83 static Lisp_Object
84 read_minibuffer_internal_unwind (Lisp_Object unwind_data)
85 {
86   Lisp_Object frame;
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))
96     {
97       Lisp_Object victim = unwind_data;
98       unwind_data = XCDR (unwind_data);
99       free_cons (XCONS (victim));
100     }
101
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);
105   if (!noninteractive
106       && !NILP (frame)
107       && !NILP (XFRAME (frame)->minibuffer_window))
108     {
109       struct window *w = XWINDOW (XFRAME (frame)->minibuffer_window);
110       redisplay_move_cursor (w, 0, 0);
111     }
112
113   return Qnil;
114 }
115
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.
120 */
121        (preprompt))
122 {
123   if (NILP (preprompt))
124     {
125       Vminibuf_preprompt = Qnil;
126     }
127   else
128     {
129       CHECK_STRING (preprompt);
130
131       Vminibuf_preprompt = LISP_GETTEXT (preprompt);
132     }
133   return Qnil;
134 }
135
136 DEFUN ("read-minibuffer-internal", Fread_minibuffer_internal, 1, 1, 0, /*
137 Lowest-level interface to minibuffers.  Don't call this.
138 */
139        (prompt))
140 {
141   /* This function can GC */
142   int speccount = specpdl_depth ();
143   Lisp_Object val;
144
145   CHECK_STRING (prompt);
146
147   single_console_state ();
148
149   record_unwind_protect (read_minibuffer_internal_unwind,
150                          noseeum_cons
151                          (Vminibuf_prompt,
152                           noseeum_cons (make_int (minibuf_level), Qnil)));
153   Vminibuf_prompt = LISP_GETTEXT (prompt);
154
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.
160
161      choose_minibuf_frame() does the following:
162
163   if (!EQ (minibuf_window, selected_frame()->minibuffer_window))
164     {
165       Fset_window_buffer (selected_frame()->minibuffer_window,
166                           XWINDOW (minibuf_window)->buffer);
167       minibuf_window = selected_frame()->minibuffer_window;
168     }
169
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.
174
175   The comment above choose_minibuf_frame() reads:
176
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.  */
180
181   minibuf_window = FRAME_MINIBUF_WINDOW (selected_frame ());
182
183   run_hook (Qminibuffer_setup_hook);
184
185   minibuf_level++;
186   clear_echo_area (selected_frame (), Qnil, 0);
187
188   val = call_command_loop (Qt);
189
190   return unbind_to (speccount, val);
191 }
192
193
194 \f
195 /* Completion hair */
196
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.  */
201
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. */
206
207 Charcount
208 scmp_1 (const Bufbyte *s1, const Bufbyte *s2, Charcount len,
209         int ignore_case)
210 {
211   Charcount l = len;
212
213   if (ignore_case)
214     {
215       while (l)
216         {
217           Emchar c1 = DOWNCASE (current_buffer, charptr_emchar (s1));
218           Emchar c2 = DOWNCASE (current_buffer, charptr_emchar (s2));
219
220           if (c1 == c2)
221             {
222               l--;
223               INC_CHARPTR (s1);
224               INC_CHARPTR (s2);
225             }
226           else
227             break;
228         }
229     }
230   else
231     {
232       while (l && charptr_emchar (s1) == charptr_emchar (s2))
233         {
234           l--;
235           INC_CHARPTR (s1);
236           INC_CHARPTR (s2);
237         }
238     }
239
240   if (l == 0)
241     return -1;
242   else return len - l;
243 }
244
245
246 int
247 regexp_ignore_completion_p (const Bufbyte *nonreloc,
248                             Lisp_Object reloc, Bytecount offset,
249                             Bytecount length)
250 {
251   /* Ignore this element if it fails to match all the regexps.  */
252   if (!NILP (Vcompletion_regexp_list))
253     {
254       Lisp_Object regexps;
255       EXTERNAL_LIST_LOOP (regexps, Vcompletion_regexp_list)
256         {
257           Lisp_Object re = XCAR (regexps);
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
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.
297
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?  */
302
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.
310
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.
313
314 If COLLECTION is an obarray, the names of all symbols in the obarray
315 are the possible completions.
316
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'.
320
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.
325 */
326        (string, collection, predicate))
327 {
328   /* This function can GC */
329   Lisp_Object bestmatch, tail;
330   Charcount bestmatchsize = 0;
331   int list;
332   int indice = 0;
333   int matchcount = 0;
334   int obsize;
335   Lisp_Object bucket;
336   Charcount slength, blength;
337
338   CHECK_STRING (string);
339
340   if (CONSP (collection))
341     {
342       Lisp_Object tem = XCAR (collection);
343       if (SYMBOLP (tem))        /* lambda, autoload, etc.  Emacs-lisp sucks */
344         return call3 (collection, string, predicate, Qnil);
345       else
346         list = 1;
347     }
348   else if (VECTORP (collection))
349     list = 0;
350   else if (NILP (collection))
351     list = 1;
352   else
353     return call3 (collection, string, predicate, Qnil);
354
355   bestmatch = Qnil;
356   blength = 0;
357   slength = XSTRING_CHAR_LENGTH (string);
358
359   /* If COLLECTION is not a list, set TAIL just for gc pro.  */
360   tail = collection;
361   if (!list)
362     {
363       obsize = XVECTOR_LENGTH (collection);
364       bucket = XVECTOR_DATA (collection)[indice];
365     }
366   else /* warning suppression */
367     {
368       obsize = 0;
369       bucket = Qnil;
370     }
371
372   while (1)
373     {
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. */
378       Lisp_Object elt;
379       Lisp_Object eltstring;
380
381       if (list)
382         {
383           if (NILP (tail))
384             break;
385           elt = Fcar (tail);
386           eltstring = Fcar (elt);
387           tail = Fcdr (tail);
388         }
389       else
390         {
391           if (!ZEROP (bucket))
392             {
393               Lisp_Symbol *next;
394               if (!SYMBOLP (bucket))
395                 {
396                   signal_simple_error ("Bad obarray passed to try-completions",
397                                        bucket);
398                 }
399               next = symbol_next (XSYMBOL (bucket));
400               elt = bucket;
401               eltstring = Fsymbol_name (elt);
402               if (next)
403                 XSETSYMBOL (bucket, next);
404               else
405                 bucket = Qzero;
406             }
407           else if (++indice >= obsize)
408             break;
409           else
410             {
411               bucket = XVECTOR_DATA (collection)[indice];
412               continue;
413             }
414         }
415
416       /* Is this element a possible completion? */
417
418       if (STRINGP (eltstring))
419         {
420           Charcount eltlength = XSTRING_CHAR_LENGTH (eltstring);
421           if (slength <= eltlength
422               && (0 > scmp (XSTRING_DATA (eltstring),
423                             XSTRING_DATA (string),
424                             slength)))
425             {
426               {
427                 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
428                 int loser;
429                 GCPRO4 (tail, string, eltstring, bestmatch);
430                 loser = ignore_completion_p (eltstring, predicate, elt);
431                 UNGCPRO;
432                 if (loser)      /* reject this one */
433                   continue;
434               }
435
436               /* Update computation of how much all possible
437                  completions match */
438
439               matchcount++;
440               if (NILP (bestmatch))
441                 {
442                   bestmatch = eltstring;
443                   blength = eltlength;
444                   bestmatchsize = eltlength;
445                 }
446               else
447                 {
448                   Charcount compare = min (bestmatchsize, eltlength);
449                   Charcount matchsize =
450                     scmp (XSTRING_DATA (bestmatch),
451                           XSTRING_DATA (eltstring),
452                           compare);
453                   if (matchsize < 0)
454                     matchsize = compare;
455                   if (completion_ignore_case)
456                     {
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)
463                           ||
464                           /* If there is more than one exact match ignoring
465                              case, and one of them is exact including case,
466                              prefer that one.  */
467                           /* If there is no exact match ignoring case,
468                              prefer a match that does not change the case
469                              of the input.  */
470                           ((matchsize == eltlength)
471                            ==
472                            (matchsize == blength)
473                            && 0 > scmp_1 (XSTRING_DATA (eltstring),
474                                           XSTRING_DATA (string),
475                                           slength, 0)
476                            && 0 <= scmp_1 (XSTRING_DATA (bestmatch),
477                                            XSTRING_DATA (string),
478                                            slength, 0)))
479                       {
480                         bestmatch = eltstring;
481                         blength = eltlength;
482                       }
483                     }
484                   bestmatchsize = matchsize;
485                 }
486             }
487         }
488     }
489
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)
498     return string;
499
500   /* Return t if the supplied string is an exact match (counting case);
501      it does not require any change to be made.  */
502   if (matchcount == 1
503       && bestmatchsize == slength
504       && 0 > scmp_1 (XSTRING_DATA (bestmatch),
505                      XSTRING_DATA (string),
506                      bestmatchsize, 0))
507     return Qt;
508
509   /* Else extract the part in which all completions agree */
510   return Fsubstring (bestmatch, Qzero, make_int (bestmatchsize));
511 }
512
513 \f
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.
519
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.
522
523 If COLLECTION is an obarray, the names of all symbols in the obarray
524 are the possible completions.
525
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'.
529
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.
534 */
535        (string, collection, predicate))
536 {
537   /* This function can GC */
538   Lisp_Object tail;
539   Lisp_Object allmatches;
540   int list;
541   int indice = 0;
542   int obsize;
543   Lisp_Object bucket;
544   Charcount slength;
545
546   CHECK_STRING (string);
547
548   if (CONSP (collection))
549     {
550       Lisp_Object tem = XCAR (collection);
551       if (SYMBOLP (tem))        /* lambda, autoload, etc.  Emacs-lisp sucks */
552         return call3 (collection, string, predicate, Qt);
553       else
554         list = 1;
555     }
556   else if (VECTORP (collection))
557     list = 0;
558   else if (NILP (collection))
559     list = 1;
560   else
561     return call3 (collection, string, predicate, Qt);
562
563   allmatches = Qnil;
564   slength = XSTRING_CHAR_LENGTH (string);
565
566   /* If COLLECTION is not a list, set TAIL just for gc pro.  */
567   tail = collection;
568   if (!list)
569     {
570       obsize = XVECTOR_LENGTH (collection);
571       bucket = XVECTOR_DATA (collection)[indice];
572     }
573   else /* warning suppression */
574     {
575       obsize = 0;
576       bucket = Qnil;
577     }
578
579   while (1)
580     {
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. */
585       Lisp_Object elt;
586       Lisp_Object eltstring;
587
588       if (list)
589         {
590           if (NILP (tail))
591             break;
592           elt = Fcar (tail);
593           eltstring = Fcar (elt);
594           tail = Fcdr (tail);
595         }
596       else
597         {
598           if (!ZEROP (bucket))
599             {
600               Lisp_Symbol *next = symbol_next (XSYMBOL (bucket));
601               elt = bucket;
602               eltstring = Fsymbol_name (elt);
603               if (next)
604                 XSETSYMBOL (bucket, next);
605               else
606                 bucket = Qzero;
607             }
608           else if (++indice >= obsize)
609             break;
610           else
611             {
612               bucket = XVECTOR_DATA (collection)[indice];
613               continue;
614             }
615         }
616
617       /* Is this element a possible completion? */
618
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),
628                         slength)))
629         {
630           /* Yes.  Now check whether predicate likes it. */
631           struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
632           int loser;
633           GCPRO4 (tail, eltstring, allmatches, string);
634           loser = ignore_completion_p (eltstring, predicate, elt);
635           UNGCPRO;
636           if (!loser)
637             /* Ok => put it on the list. */
638             allmatches = Fcons (eltstring, allmatches);
639         }
640     }
641
642   return Fnreverse (allmatches);
643 }
644 \f
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 */
649
650 #if 0
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.
654 */
655          ())
656 {
657   return Fcopy_sequence (Vminibuf_prompt);
658 }
659
660 xxDEFUN ("minibuffer-prompt-width", Fminibuffer_prompt_width, 0, 0, 0, /*
661 Return the display width of the minibuffer prompt.
662 */
663          ())
664 {
665   return make_int (minibuf_prompt_width);
666 }
667 #endif /* 0 */
668
669 \f
670 /************************************************************************/
671 /*                              echo area                               */
672 /************************************************************************/
673
674 extern int stdout_needs_newline;
675
676 static Lisp_Object
677 clear_echo_area_internal (struct frame *f, Lisp_Object label, int from_print,
678                           int no_restore)
679 {
680   /* This function can call lisp */
681   if (!NILP (Ffboundp (Qclear_message)))
682     {
683       Lisp_Object frame;
684
685       XSETFRAME (frame, f);
686       return call4 (Qclear_message, label, frame, from_print ? Qt : Qnil,
687                     no_restore ? Qt : Qnil);
688     }
689   else
690     {
691       write_string_to_stdio_stream (stderr, 0, (const Bufbyte *) "\n", 0, 1,
692                                     Qterminal, 0);
693       return Qnil;
694     }
695 }
696
697 Lisp_Object
698 clear_echo_area (struct frame *f, Lisp_Object label, int no_restore)
699 {
700   /* This function can call lisp */
701   return clear_echo_area_internal (f, label, 0, no_restore);
702 }
703
704 Lisp_Object
705 clear_echo_area_from_print (struct frame *f, Lisp_Object label, int no_restore)
706 {
707   /* This function can call lisp */
708   return clear_echo_area_internal (f, label, 1, no_restore);
709 }
710
711 void
712 echo_area_append (struct frame *f, const Bufbyte *nonreloc, Lisp_Object reloc,
713                   Bytecount offset, Bytecount length,
714                   Lisp_Object label)
715 {
716   /* This function can call lisp */
717   Lisp_Object obj;
718   struct gcpro gcpro1;
719   Lisp_Object frame;
720
721   /* There is an inlining bug in egcs-20000131 c++ that can be worked
722      around as follows:  */
723 #if defined (__GNUC__) && defined (__cplusplus)
724   alloca (4);
725 #endif
726
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
729      may be valid.  */
730   if (length == 0)
731     return;
732
733   fixup_internal_substring (nonreloc, reloc, offset, &length);
734
735   /* also check it here, in case the string was really blank. */
736   if (length == 0)
737     return;
738
739   if (!NILP (Ffboundp (Qappend_message)))
740     {
741       if (STRINGP (reloc) && offset == 0 && length == XSTRING_LENGTH (reloc))
742         obj = reloc;
743       else
744         {
745           if (STRINGP (reloc))
746             nonreloc = XSTRING_DATA (reloc);
747           obj = make_string (nonreloc + offset, length);
748         }
749
750       XSETFRAME (frame, f);
751       GCPRO1 (obj);
752       call4 (Qappend_message, label, obj, frame,
753              EQ (label, Qprint) ? Qt : Qnil);
754       UNGCPRO;
755     }
756   else
757     {
758       if (STRINGP (reloc))
759         nonreloc = XSTRING_DATA (reloc);
760       write_string_to_stdio_stream (stderr, 0, nonreloc, offset, length,
761                                     Qterminal, 0);
762     }
763 }
764
765 void
766 echo_area_message (struct frame *f, const Bufbyte *nonreloc,
767                    Lisp_Object reloc, Bytecount offset, Bytecount length,
768                    Lisp_Object label)
769 {
770   /* This function can call lisp */
771   clear_echo_area (f, label, 1);
772   echo_area_append (f, nonreloc, reloc, offset, length, label);
773 }
774
775 int
776 echo_area_active (struct frame *f)
777 {
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);
783 }
784
785 Lisp_Object
786 echo_area_status (struct frame *f)
787 {
788   /* This function can call lisp */
789   if (!NILP (Ffboundp (Qcurrent_message_label)))
790     {
791       Lisp_Object frame;
792
793       XSETFRAME (frame, f);
794       return call1 (Qcurrent_message_label, frame);
795     }
796   else
797     return stdout_needs_newline ? Qmessage : Qnil;
798 }
799
800 Lisp_Object
801 echo_area_contents (struct frame *f)
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
811 message_internal (const Bufbyte *nonreloc, Lisp_Object reloc,
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
821 message_append_internal (const Bufbyte *nonreloc, Lisp_Object reloc,
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
835 message_1 (const char *fmt, va_list args)
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 */
843       Lisp_Object obj = emacs_doprnt_string_va ((const Bufbyte *) fmt, Qnil,
844                                                 -1, args);
845       GCPRO1 (obj);
846       message_internal (0, obj, 0, -1);
847       UNGCPRO;
848     }
849   else
850     message_internal (0, Qnil, 0, 0);
851 }
852
853 static void
854 message_append_1 (const char *fmt, va_list args)
855 {
856   /* This function can call lisp */
857   if (fmt)
858     {
859       struct gcpro gcpro1;
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,
863                                                 -1, args);
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
880 message (const char *fmt, ...)
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
896 message_append (const char *fmt, ...)
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
909 message_no_translate (const char *fmt, ...)
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 \f
923 /************************************************************************/
924 /*                            initialization                            */
925 /************************************************************************/
926
927 void
928 syms_of_minibuf (void)
929 {
930   defsymbol (&Qminibuffer_setup_hook, "minibuffer-setup-hook");
931
932   defsymbol (&Qcompletion_ignore_case, "completion-ignore-case");
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
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");
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   reinit_vars_of_minibuf ();
961
962   staticpro (&Vminibuf_prompt);
963   Vminibuf_prompt = Qnil;
964
965   /* Added by Jareth Hein (jhod@po.iijnet.or.jp) for input system support */
966   staticpro (&Vminibuf_preprompt);
967   Vminibuf_preprompt = Qnil;
968
969   DEFVAR_LISP ("minibuffer-setup-hook", &Vminibuffer_setup_hook /*
970 Normal hook run just after entry to minibuffer.
971 */ );
972   Vminibuffer_setup_hook = Qnil;
973
974   DEFVAR_BOOL ("completion-ignore-case", &completion_ignore_case /*
975 Non-nil means don't consider case significant in completion.
976 */ );
977   completion_ignore_case = 0;
978
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.
982 */ );
983   Vcompletion_regexp_list = Qnil;
984 }
985
986 void
987 reinit_complex_vars_of_minibuf (void)
988 {
989   /* This function can GC */
990 #ifdef I18N3
991   /* #### This needs to be fixed up so that the gettext() gets called
992      at runtime instead of at load time. */
993 #endif
994   Vminibuffer_zero
995     = Fget_buffer_create
996       (build_string (DEFER_GETTEXT (" *Minibuf-0*")));
997   Vecho_area_buffer
998     = Fget_buffer_create
999       (build_string (DEFER_GETTEXT (" *Echo Area*")));
1000 }
1001
1002 void
1003 complex_vars_of_minibuf (void)
1004 {
1005   reinit_complex_vars_of_minibuf ();
1006 }