git.chise.org Git - chise/xemacs-chise.git.1/blob - 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 ALIST to be a hash table.  It is wrong
 293    for the use of obarrays to be better-rewarded than the use of
 294    hash tables.  By better-rewarded I mean that you can pass an obarray
 295    to all of the completion functions, whereas you can't do anything
 296    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 ALIST.
 305 Each car of each element of ALIST is tested to see if it begins with STRING.
 306 All that match are compared together; the longest initial sequence
 307 common to all matches is returned as a string.
 308 If there is no match at all, nil is returned.
 309 For an exact match, t is returned.
 310
 311 ALIST can be an obarray instead of an alist.
 312 Then the print names of all symbols in the obarray are the possible matches.
 313
 314 ALIST can also be a function to do the completion itself.
 315 It receives three arguments: the values STRING, PREDICATE and nil.
 316 Whatever it returns becomes the value of `try-completion'.
 317
 318 If optional third argument PREDICATE is non-nil,
 319 it is used to test each possible match.
 320 The match is a candidate only if PREDICATE returns non-nil.
 321 The argument given to PREDICATE is the alist element or the symbol from the obarray.
 322 */
 323        (string, alist, pred))
 324 {
 325   /* This function can GC */
 326   Lisp_Object bestmatch, tail;
 327   Charcount bestmatchsize = 0;
 328   int list;
 329   int indice = 0;
 330   int matchcount = 0;
 331   int obsize;
 332   Lisp_Object bucket;
 333   Charcount slength, blength;
 334
 335   CHECK_STRING (string);
 336
 337   if (CONSP (alist))
 338     {
 339       Lisp_Object tem = XCAR (alist);
 340       if (SYMBOLP (tem))        /* lambda, autoload, etc.  Emacs-lisp sucks */
 341         return call3 (alist, string, pred, Qnil);
 342       else
 343         list = 1;
 344     }
 345   else if (VECTORP (alist))
 346     list = 0;
 347   else if (NILP (alist))
 348     list = 1;
 349   else
 350     return call3 (alist, string, pred, Qnil);
 351
 352   bestmatch = Qnil;
 353   blength = 0;
 354   slength = XSTRING_CHAR_LENGTH (string);
 355
 356   /* If ALIST is not a list, set TAIL just for gc pro.  */
 357   tail = alist;
 358   if (!list)
 359     {
 360       obsize = XVECTOR_LENGTH (alist);
 361       bucket = XVECTOR_DATA (alist)[indice];
 362     }
 363   else /* warning suppression */
 364     {
 365       obsize = 0;
 366       bucket = Qnil;
 367     }
 368
 369   while (1)
 370     {
 371       /* Get the next element of the alist or obarray. */
 372       /* Exit the loop if the elements are all used up. */
 373       /* elt gets the alist element or symbol.
 374          eltstring gets the name to check as a completion. */
 375       Lisp_Object elt;
 376       Lisp_Object eltstring;
 377
 378       if (list)
 379         {
 380           if (NILP (tail))
 381             break;
 382           elt = Fcar (tail);
 383           eltstring = Fcar (elt);
 384           tail = Fcdr (tail);
 385         }
 386       else
 387         {
 388           if (!ZEROP (bucket))
 389             {
 390               Lisp_Symbol *next;
 391               if (!SYMBOLP (bucket))
 392                 {
 393                   signal_simple_error ("Bad obarray passed to try-completions",
 394                                        bucket);
 395                 }
 396               next = symbol_next (XSYMBOL (bucket));
 397               elt = bucket;
 398               eltstring = Fsymbol_name (elt);
 399               if (next)
 400                 XSETSYMBOL (bucket, next);
 401               else
 402                 bucket = Qzero;
 403             }
 404           else if (++indice >= obsize)
 405             break;
 406           else
 407             {
 408               bucket = XVECTOR_DATA (alist)[indice];
 409               continue;
 410             }
 411         }
 412
 413       /* Is this element a possible completion? */
 414
 415       if (STRINGP (eltstring))
 416         {
 417           Charcount eltlength = XSTRING_CHAR_LENGTH (eltstring);
 418           if (slength <= eltlength
 419               && (0 > scmp (XSTRING_DATA (eltstring),
 420                             XSTRING_DATA (string),
 421                             slength)))
 422             {
 423               {
 424                 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
 425                 int loser;
 426                 GCPRO4 (tail, string, eltstring, bestmatch);
 427                 loser = ignore_completion_p (eltstring, pred, elt);
 428                 UNGCPRO;
 429                 if (loser)      /* reject this one */
 430                   continue;
 431               }
 432
 433               /* Update computation of how much all possible
 434                  completions match */
 435
 436               matchcount++;
 437               if (NILP (bestmatch))
 438                 {
 439                   bestmatch = eltstring;
 440                   blength = eltlength;
 441                   bestmatchsize = eltlength;
 442                 }
 443               else
 444                 {
 445                   Charcount compare = min (bestmatchsize, eltlength);
 446                   Charcount matchsize =
 447                     scmp (XSTRING_DATA (bestmatch),
 448                           XSTRING_DATA (eltstring),
 449                           compare);
 450                   if (matchsize < 0)
 451                     matchsize = compare;
 452                   if (completion_ignore_case)
 453                     {
 454                       /* If this is an exact match except for case,
 455                          use it as the best match rather than one that is not
 456                          an exact match.  This way, we get the case pattern
 457                          of the actual match.  */
 458                       if ((matchsize == eltlength
 459                            && matchsize < blength)
 460                           ||
 461                           /* If there is more than one exact match ignoring
 462                              case, and one of them is exact including case,
 463                              prefer that one.  */
 464                           /* If there is no exact match ignoring case,
 465                              prefer a match that does not change the case
 466                              of the input.  */
 467                           ((matchsize == eltlength)
 468                            ==
 469                            (matchsize == blength)
 470                            && 0 > scmp_1 (XSTRING_DATA (eltstring),
 471                                           XSTRING_DATA (string),
 472                                           slength, 0)
 473                            && 0 <= scmp_1 (XSTRING_DATA (bestmatch),
 474                                            XSTRING_DATA (string),
 475                                            slength, 0)))
 476                       {
 477                         bestmatch = eltstring;
 478                         blength = eltlength;
 479                       }
 480                     }
 481                   bestmatchsize = matchsize;
 482                 }
 483             }
 484         }
 485     }
 486
 487   if (NILP (bestmatch))
 488     return Qnil;                /* No completions found */
 489   /* If we are ignoring case, and there is no exact match,
 490      and no additional text was supplied,
 491      don't change the case of what the user typed.  */
 492   if (completion_ignore_case
 493       && bestmatchsize == slength
 494       && blength > bestmatchsize)
 495     return string;
 496
 497   /* Return t if the supplied string is an exact match (counting case);
 498      it does not require any change to be made.  */
 499   if (matchcount == 1
 500       && bestmatchsize == slength
 501       && 0 > scmp_1 (XSTRING_DATA (bestmatch),
 502                      XSTRING_DATA (string),
 503                      bestmatchsize, 0))
 504     return Qt;
 505
 506   /* Else extract the part in which all completions agree */
 507   return Fsubstring (bestmatch, Qzero, make_int (bestmatchsize));
 508 }
 509
 510 \f
 511 DEFUN ("all-completions", Fall_completions, 2, 3, 0, /*
 512 Search for partial matches to STRING in ALIST.
 513 Each car of each element of ALIST is tested to see if it begins with STRING.
 514 The value is a list of all the strings from ALIST that match.
 515 ALIST can be an obarray instead of an alist.
 516 Then the print names of all symbols in the obarray are the possible matches.
 517
 518 ALIST can also be a function to do the completion itself.
 519 It receives three arguments: the values STRING, PREDICATE and t.
 520 Whatever it returns becomes the value of `all-completions'.
 521
 522 If optional third argument PREDICATE is non-nil,
 523 it is used to test each possible match.
 524 The match is a candidate only if PREDICATE returns non-nil.
 525 The argument given to PREDICATE is the alist element or
 526 the symbol from the obarray.
 527 */
 528        (string, alist, pred))
 529 {
 530   /* This function can GC */
 531   Lisp_Object tail;
 532   Lisp_Object allmatches;
 533   int list;
 534   int indice = 0;
 535   int obsize;
 536   Lisp_Object bucket;
 537   Charcount slength;
 538
 539   CHECK_STRING (string);
 540
 541   if (CONSP (alist))
 542     {
 543       Lisp_Object tem = XCAR (alist);
 544       if (SYMBOLP (tem))        /* lambda, autoload, etc.  Emacs-lisp sucks */
 545         return call3 (alist, string, pred, Qt);
 546       else
 547         list = 1;
 548     }
 549   else if (VECTORP (alist))
 550     list = 0;
 551   else if (NILP (alist))
 552     list = 1;
 553   else
 554     return call3 (alist, string, pred, Qt);
 555
 556   allmatches = Qnil;
 557   slength = XSTRING_CHAR_LENGTH (string);
 558
 559   /* If ALIST is not a list, set TAIL just for gc pro.  */
 560   tail = alist;
 561   if (!list)
 562     {
 563       obsize = XVECTOR_LENGTH (alist);
 564       bucket = XVECTOR_DATA (alist)[indice];
 565     }
 566   else /* warning suppression */
 567     {
 568       obsize = 0;
 569       bucket = Qnil;
 570     }
 571
 572   while (1)
 573     {
 574       /* Get the next element of the alist or obarray. */
 575       /* Exit the loop if the elements are all used up. */
 576       /* elt gets the alist element or symbol.
 577          eltstring gets the name to check as a completion. */
 578       Lisp_Object elt;
 579       Lisp_Object eltstring;
 580
 581       if (list)
 582         {
 583           if (NILP (tail))
 584             break;
 585           elt = Fcar (tail);
 586           eltstring = Fcar (elt);
 587           tail = Fcdr (tail);
 588         }
 589       else
 590         {
 591           if (!ZEROP (bucket))
 592             {
 593               Lisp_Symbol *next = symbol_next (XSYMBOL (bucket));
 594               elt = bucket;
 595               eltstring = Fsymbol_name (elt);
 596               if (next)
 597                 XSETSYMBOL (bucket, next);
 598               else
 599                 bucket = Qzero;
 600             }
 601           else if (++indice >= obsize)
 602             break;
 603           else
 604             {
 605               bucket = XVECTOR_DATA (alist)[indice];
 606               continue;
 607             }
 608         }
 609
 610       /* Is this element a possible completion? */
 611
 612       if (STRINGP (eltstring)
 613           && (slength <= XSTRING_CHAR_LENGTH (eltstring))
 614           /* Reject alternatives that start with space
 615              unless the input starts with space.  */
 616           && ((XSTRING_CHAR_LENGTH (string) > 0 &&
 617                string_char (XSTRING (string), 0) == ' ')
 618               || string_char (XSTRING (eltstring), 0) != ' ')
 619           && (0 > scmp (XSTRING_DATA (eltstring),
 620                         XSTRING_DATA (string),
 621                         slength)))
 622         {
 623           /* Yes.  Now check whether predicate likes it. */
 624           struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
 625           int loser;
 626           GCPRO4 (tail, eltstring, allmatches, string);
 627           loser = ignore_completion_p (eltstring, pred, elt);
 628           UNGCPRO;
 629           if (!loser)
 630             /* Ok => put it on the list. */
 631             allmatches = Fcons (eltstring, allmatches);
 632         }
 633     }
 634
 635   return Fnreverse (allmatches);
 636 }
 637 \f
 638 /* Useless FSFmacs functions */
 639 /* More than useless.  I've nuked minibuf_prompt_width so they won't
 640    function at all in XEmacs at the moment.  They are used to
 641    implement some braindamage in FSF which we aren't including. --cet */
 642
 643 #if 0
 644 xxDEFUN ("minibuffer-prompt", Fminibuffer_prompt, 0, 0, 0, /*
 645 Return the prompt string of the currently-active minibuffer.
 646 If no minibuffer is active, return nil.
 647 */
 648          ())
 649 {
 650   return Fcopy_sequence (Vminibuf_prompt);
 651 }
 652
 653 xxDEFUN ("minibuffer-prompt-width", Fminibuffer_prompt_width, 0, 0, 0, /*
 654 Return the display width of the minibuffer prompt.
 655 */
 656          ())
 657 {
 658   return make_int (minibuf_prompt_width);
 659 }
 660 #endif /* 0 */
 661
 662 \f
 663 /************************************************************************/
 664 /*                              echo area                               */
 665 /************************************************************************/
 666
 667 extern int stdout_needs_newline;
 668
 669 static Lisp_Object
 670 clear_echo_area_internal (struct frame *f, Lisp_Object label, int from_print,
 671                           int no_restore)
 672 {
 673   /* This function can call lisp */
 674   if (!NILP (Ffboundp (Qclear_message)))
 675     {
 676       Lisp_Object frame;
 677
 678       XSETFRAME (frame, f);
 679       return call4 (Qclear_message, label, frame, from_print ? Qt : Qnil,
 680                     no_restore ? Qt : Qnil);
 681     }
 682   else
 683     {
 684       write_string_to_stdio_stream (stderr, 0, (CONST Bufbyte *) "\n", 0, 1,
 685                                     Qterminal);
 686       return Qnil;
 687     }
 688 }
 689
 690 Lisp_Object
 691 clear_echo_area (struct frame *f, Lisp_Object label, int no_restore)
 692 {
 693   /* This function can call lisp */
 694   return clear_echo_area_internal (f, label, 0, no_restore);
 695 }
 696
 697 Lisp_Object
 698 clear_echo_area_from_print (struct frame *f, Lisp_Object label, int no_restore)
 699 {
 700   /* This function can call lisp */
 701   return clear_echo_area_internal (f, label, 1, no_restore);
 702 }
 703
 704 void
 705 echo_area_append (struct frame *f, CONST Bufbyte *nonreloc, Lisp_Object reloc,
 706                   Bytecount offset, Bytecount length,
 707                   Lisp_Object label)
 708 {
 709   /* This function can call lisp */
 710   Lisp_Object obj;
 711   struct gcpro gcpro1;
 712   Lisp_Object frame;
 713
 714   /* There is an inlining bug in egcs-20000131 c++ that can be worked
 715      around as follows:  */
 716 #if defined (__GNUC__) && defined (__cplusplus)
 717   alloca (4);
 718 #endif
 719
 720   /* some callers pass in a null string as a way of clearing the echo area.
 721      check for length == 0 now; if this case, neither nonreloc nor reloc
 722      may be valid.  */
 723   if (length == 0)
 724     return;
 725
 726   fixup_internal_substring (nonreloc, reloc, offset, &length);
 727
 728   /* also check it here, in case the string was really blank. */
 729   if (length == 0)
 730     return;
 731
 732   if (!NILP (Ffboundp (Qappend_message)))
 733     {
 734       if (STRINGP (reloc) && offset == 0 && length == XSTRING_LENGTH (reloc))
 735         obj = reloc;
 736       else
 737         {
 738           if (STRINGP (reloc))
 739             nonreloc = XSTRING_DATA (reloc);
 740           obj = make_string (nonreloc + offset, length);
 741         }
 742
 743       XSETFRAME (frame, f);
 744       GCPRO1 (obj);
 745       call4 (Qappend_message, label, obj, frame,
 746              EQ (label, Qprint) ? Qt : Qnil);
 747       UNGCPRO;
 748     }
 749   else
 750     {
 751       if (STRINGP (reloc))
 752         nonreloc = XSTRING_DATA (reloc);
 753       write_string_to_stdio_stream (stderr, 0, nonreloc, offset, length,
 754                                     Qterminal);
 755     }
 756 }
 757
 758 void
 759 echo_area_message (struct frame *f, CONST Bufbyte *nonreloc,
 760                    Lisp_Object reloc, Bytecount offset, Bytecount length,
 761                    Lisp_Object label)
 762 {
 763   /* This function can call lisp */
 764   clear_echo_area (f, label, 1);
 765   echo_area_append (f, nonreloc, reloc, offset, length, label);
 766 }
 767
 768 int
 769 echo_area_active (struct frame *f)
 770 {
 771   /* By definition, the echo area is active if the echo-area buffer
 772      is not empty.  No need to call Lisp code. (Anyway, this function
 773      is called from redisplay.) */
 774   struct buffer *echo_buffer = XBUFFER (Vecho_area_buffer);
 775   return BUF_BEGV (echo_buffer) != BUF_ZV (echo_buffer);
 776 }
 777
 778 Lisp_Object
 779 echo_area_status (struct frame *f)
 780 {
 781   /* This function can call lisp */
 782   if (!NILP (Ffboundp (Qcurrent_message_label)))
 783     {
 784       Lisp_Object frame;
 785
 786       XSETFRAME (frame, f);
 787       return call1 (Qcurrent_message_label, frame);
 788     }
 789   else
 790     return stdout_needs_newline ? Qmessage : Qnil;
 791 }
 792
 793 Lisp_Object
 794 echo_area_contents (struct frame *f)
 795 {
 796   /* See above.  By definition, the contents of the echo-area buffer
 797      are the contents of the echo area. */
 798   return Fbuffer_substring (Qnil, Qnil, Vecho_area_buffer);
 799 }
 800
 801 /* Dump an informative message to the echo area.  This function takes a
 802    string in internal format. */
 803 void
 804 message_internal (CONST Bufbyte *nonreloc, Lisp_Object reloc,
 805                   Bytecount offset, Bytecount length)
 806 {
 807   /* This function can call lisp  */
 808   if (NILP (Vexecuting_macro))
 809     echo_area_message (selected_frame (), nonreloc, reloc, offset, length,
 810                        Qmessage);
 811 }
 812
 813 void
 814 message_append_internal (CONST Bufbyte *nonreloc, Lisp_Object reloc,
 815                          Bytecount offset, Bytecount length)
 816 {
 817   /* This function can call lisp  */
 818   if (NILP (Vexecuting_macro))
 819     echo_area_append (selected_frame (), nonreloc, reloc, offset, length,
 820                       Qmessage);
 821 }
 822
 823 /* The next three functions are interfaces to message_internal() that
 824    take strings in external format.  message() does I18N3 translating
 825    on the format string; message_no_translate() does not. */
 826
 827 static void
 828 message_1 (CONST char *fmt, va_list args)
 829 {
 830   /* This function can call lisp */
 831   if (fmt)
 832     {
 833       struct gcpro gcpro1;
 834       /* message_internal() might GC, e.g. if there are after-change-hooks
 835          on the echo area buffer */
 836       Lisp_Object obj = emacs_doprnt_string_va ((CONST Bufbyte *) fmt, Qnil,
 837                                                 -1, args);
 838       GCPRO1 (obj);
 839       message_internal (0, obj, 0, -1);
 840       UNGCPRO;
 841     }
 842   else
 843     message_internal (0, Qnil, 0, 0);
 844 }
 845
 846 static void
 847 message_append_1 (CONST char *fmt, va_list args)
 848 {
 849   /* This function can call lisp */
 850   if (fmt)
 851     {
 852       struct gcpro gcpro1;
 853       /* message_internal() might GC, e.g. if there are after-change-hooks
 854          on the echo area buffer */
 855       Lisp_Object obj = emacs_doprnt_string_va ((CONST Bufbyte *) fmt, Qnil,
 856                                                 -1, args);
 857       GCPRO1 (obj);
 858       message_append_internal (0, obj, 0, -1);
 859       UNGCPRO;
 860     }
 861   else
 862     message_append_internal (0, Qnil, 0, 0);
 863 }
 864
 865 void
 866 clear_message (void)
 867 {
 868   /* This function can call lisp */
 869   message_internal (0, Qnil, 0, 0);
 870 }
 871
 872 void
 873 message (CONST char *fmt, ...)
 874 {
 875   /* This function can call lisp */
 876   /* I think it's OK to pass the data of Lisp strings as arguments to
 877      this function.  No GC'ing will occur until the data has already
 878      been copied. */
 879   va_list args;
 880
 881   va_start (args, fmt);
 882   if (fmt)
 883     fmt = GETTEXT (fmt);
 884   message_1 (fmt, args);
 885   va_end (args);
 886 }
 887
 888 void
 889 message_append (CONST char *fmt, ...)
 890 {
 891   /* This function can call lisp */
 892   va_list args;
 893
 894   va_start (args, fmt);
 895   if (fmt)
 896     fmt = GETTEXT (fmt);
 897   message_append_1 (fmt, args);
 898   va_end (args);
 899 }
 900
 901 void
 902 message_no_translate (CONST char *fmt, ...)
 903 {
 904   /* This function can call lisp */
 905   /* I think it's OK to pass the data of Lisp strings as arguments to
 906      this function.  No GC'ing will occur until the data has already
 907      been copied. */
 908   va_list args;
 909
 910   va_start (args, fmt);
 911   message_1 (fmt, args);
 912   va_end (args);
 913 }
 914
 915 \f
 916 /************************************************************************/
 917 /*                            initialization                            */
 918 /************************************************************************/
 919
 920 void
 921 syms_of_minibuf (void)
 922 {
 923   defsymbol (&Qminibuffer_setup_hook, "minibuffer-setup-hook");
 924
 925   defsymbol (&Qcompletion_ignore_case, "completion-ignore-case");
 926
 927   DEFSUBR (Fminibuffer_depth);
 928 #if 0
 929   DEFSUBR (Fminibuffer_prompt);
 930   DEFSUBR (Fminibuffer_prompt_width);
 931 #endif
 932   DEFSUBR (Fset_minibuffer_preprompt);
 933   DEFSUBR (Fread_minibuffer_internal);
 934
 935   DEFSUBR (Ftry_completion);
 936   DEFSUBR (Fall_completions);
 937
 938   defsymbol (&Qappend_message, "append-message");
 939   defsymbol (&Qclear_message, "clear-message");
 940   defsymbol (&Qdisplay_message, "display-message");
 941   defsymbol (&Qcurrent_message_label, "current-message-label");
 942 }
 943
 944 void
 945 reinit_vars_of_minibuf (void)
 946 {
 947   minibuf_level = 0;
 948 }
 949
 950 void
 951 vars_of_minibuf (void)
 952 {
 953   reinit_vars_of_minibuf ();
 954
 955   staticpro (&Vminibuf_prompt);
 956   Vminibuf_prompt = Qnil;
 957
 958   /* Added by Jareth Hein (jhod@po.iijnet.or.jp) for input system support */
 959   staticpro (&Vminibuf_preprompt);
 960   Vminibuf_preprompt = Qnil;
 961
 962   DEFVAR_LISP ("minibuffer-setup-hook", &Vminibuffer_setup_hook /*
 963 Normal hook run just after entry to minibuffer.
 964 */ );
 965   Vminibuffer_setup_hook = Qnil;
 966
 967   DEFVAR_BOOL ("completion-ignore-case", &completion_ignore_case /*
 968 Non-nil means don't consider case significant in completion.
 969 */ );
 970   completion_ignore_case = 0;
 971
 972   DEFVAR_LISP ("completion-regexp-list", &Vcompletion_regexp_list /*
 973 List of regexps that should restrict possible completions.
 974 Each completion has to match all regexps in this list.
 975 */ );
 976   Vcompletion_regexp_list = Qnil;
 977 }
 978
 979 void
 980 reinit_complex_vars_of_minibuf (void)
 981 {
 982   /* This function can GC */
 983 #ifdef I18N3
 984   /* #### This needs to be fixed up so that the gettext() gets called
 985      at runtime instead of at load time. */
 986 #endif
 987   Vminibuffer_zero
 988     = Fget_buffer_create
 989       (build_string (DEFER_GETTEXT (" *Minibuf-0*")));
 990   Vecho_area_buffer
 991     = Fget_buffer_create
 992       (build_string (DEFER_GETTEXT (" *Echo Area*")));
 993 }
 994
 995 void
 996 complex_vars_of_minibuf (void)
 997 {
 998   reinit_complex_vars_of_minibuf ();
 999 }