1: /* Call a Lisp function interactively.
    2:    Copyright (C) 1985, 1986, 1993, 1994, 1995, 1997, 2000, 2001, 2002,
    3:                  2003, 2004, 2005, 2006, 2007  Free Software Foundation, Inc.
    4: 
    5: This file is part of GNU Emacs.
    6: 
    7: GNU Emacs is free software; you can redistribute it and/or modify
    8: it under the terms of the GNU General Public License as published by
    9: the Free Software Foundation; either version 2, or (at your option)
   10: any later version.
   11: 
   12: GNU Emacs is distributed in the hope that it will be useful,
   13: but WITHOUT ANY WARRANTY; without even the implied warranty of
   14: MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   15: GNU General Public License for more details.
   16: 
   17: You should have received a copy of the GNU General Public License
   18: along with GNU Emacs; see the file COPYING.  If not, write to
   19: the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
   20: Boston, MA 02110-1301, USA.  */
   21: 
   22: 
   23: #include <config.h>
   24: 
   25: #include "lisp.h"
   26: #include "buffer.h"
   27: #include "commands.h"
   28: #include "keyboard.h"
   29: #include "window.h"
   30: #include "keymap.h"
   31: 
   32: #ifdef HAVE_INDEX
   33: extern char *index P_ ((const char *, int));
   34: #endif
   35: 
   36: extern Lisp_Object Qcursor_in_echo_area;
   37: extern Lisp_Object Qfile_directory_p;
   38: 
   39: Lisp_Object Vcurrent_prefix_arg, Qminus, Qplus;
   40: Lisp_Object Qcall_interactively;
   41: Lisp_Object Vcommand_history;
   42: 
   43: extern Lisp_Object Vhistory_length;
   44: extern Lisp_Object Vthis_original_command, real_this_command;
   45: 
   46: Lisp_Object Vcommand_debug_status, Qcommand_debug_status;
   47: Lisp_Object Qenable_recursive_minibuffers;
   48: 
   49: /* Non-nil means treat the mark as active
   50:    even if mark_active is 0.  */
   51: Lisp_Object Vmark_even_if_inactive;
   52: 
   53: Lisp_Object Vmouse_leave_buffer_hook, Qmouse_leave_buffer_hook;
   54: 
   55: Lisp_Object Qlist, Qlet, Qletx, Qsave_excursion, Qprogn, Qif, Qwhen;
   56: static Lisp_Object preserved_fns;
   57: 
   58: /* Marker used within call-interactively to refer to point.  */
   59: static Lisp_Object point_marker;
   60: 
   61: /* String for the prompt text used in Fcall_interactively.  */
   62: static Lisp_Object callint_message;
   63: ^L
   64: /* ARGSUSED */
   65: DEFUN ("interactive", Finteractive, Sinteractive, 0, UNEVALLED, 0,
   66:        doc: /* Specify a way of parsing arguments for interactive use of a function.
   67: For example, write
   68:   (defun foo (arg) "Doc string" (interactive "p") ...use arg...)
   69: to make ARG be the prefix argument when `foo' is called as a command.
   70: The "call" to `interactive' is actually a declaration rather than a function;
   71:  it tells `call-interactively' how to read arguments
   72:  to pass to the function.
   73: When actually called, `interactive' just returns nil.
   74: 
   75: The argument of `interactive' is usually a string containing a code letter
   76:  followed by a prompt.  (Some code letters do not use I/O to get
   77:  the argument and do not need prompts.)  To prompt for multiple arguments,
   78:  give a code letter, its prompt, a newline, and another code letter, etc.
   79:  Prompts are passed to format, and may use % escapes to print the
   80:  arguments that have already been read.
   81: If the argument is not a string, it is evaluated to get a list of
   82:  arguments to pass to the function.
   83: Just `(interactive)' means pass no args when calling interactively.
   84: 
   85: Code letters available are:
   86: a -- Function name: symbol with a function definition.
   87: b -- Name of existing buffer.
   88: B -- Name of buffer, possibly nonexistent.
   89: c -- Character (no input method is used).
   90: C -- Command name: symbol with interactive function definition.
   91: d -- Value of point as number.  Does not do I/O.
   92: D -- Directory name.
   93: e -- Parametrized event (i.e., one that's a list) that invoked this command.
   94:      If used more than once, the Nth `e' returns the Nth parameterized event.
   95:      This skips events that are integers or symbols.
   96: f -- Existing file name.
   97: F -- Possibly nonexistent file name.
   98: G -- Possibly nonexistent file name, defaulting to just directory name.
   99: i -- Ignored, i.e. always nil.  Does not do I/O.
  100: k -- Key sequence (downcase the last event if needed to get a definition).
  101: K -- Key sequence to be redefined (do not downcase the last event).
  102: m -- Value of mark as number.  Does not do I/O.
  103: M -- Any string.  Inherits the current input method.
  104: n -- Number read using minibuffer.
  105: N -- Numeric prefix arg, or if none, do like code `n'.
  106: p -- Prefix arg converted to number.  Does not do I/O.
  107: P -- Prefix arg in raw form.  Does not do I/O.
  108: r -- Region: point and mark as 2 numeric args, smallest first.  Does no I/O.
  109: s -- Any string.  Does not inherit the current input method.
  110: S -- Any symbol.
  111: U -- Mouse up event discarded by a previous k or K argument.
  112: v -- Variable name: symbol that is user-variable-p.
  113: x -- Lisp expression read but not evaluated.
  114: X -- Lisp expression read and evaluated.
  115: z -- Coding system.
  116: Z -- Coding system, nil if no prefix arg.
  117: In addition, if the string begins with `*'
  118:  then an error is signaled if the buffer is read-only.
  119:  This happens before reading any arguments.
  120: If the string begins with `@', then Emacs searches the key sequence
  121:  which invoked the command for its first mouse click (or any other
  122:  event which specifies a window), and selects that window before
  123:  reading any arguments.  You may use both `@' and `*'; they are
  124:  processed in the order that they appear.
  125: usage: (interactive ARGS)  */)
  126:      (args)
  127:      Lisp_Object args;
  128: {
  129:   return Qnil;
  130: }
  131: 
  132: /* Quotify EXP: if EXP is constant, return it.
  133:    If EXP is not constant, return (quote EXP).  */
  134: Lisp_Object
  135: quotify_arg (exp)
  136:      register Lisp_Object exp;
  137: {
  138:   if (!INTEGERP (exp) && !STRINGP (exp)
  139:       && !NILP (exp) && !EQ (exp, Qt))
  140:     return Fcons (Qquote, Fcons (exp, Qnil));
  141: 
  142:   return exp;
  143: }
  144: 
  145: /* Modify EXP by quotifying each element (except the first).  */
  146: Lisp_Object
  147: quotify_args (exp)
  148:      Lisp_Object exp;
  149: {
  150:   register Lisp_Object tail;
  151:   Lisp_Object next;
  152:   for (tail = exp; CONSP (tail); tail = next)
  153:     {
  154:       next = XCDR (tail);
  155:       XSETCAR (tail, quotify_arg (XCAR (tail)));
  156:     }
  157:   return exp;
  158: }
  159: 
  160: char *callint_argfuns[]
  161:     = {"", "point", "mark", "region-beginning", "region-end"};
  162: 
  163: static void
  164: check_mark (for_region)
  165:      int for_region;
  166: {
  167:   Lisp_Object tem;
  168:   tem = Fmarker_buffer (current_buffer->mark);
  169:   if (NILP (tem) || (XBUFFER (tem) != current_buffer))
  170:     error (for_region ? "The mark is not set now, so there is no region"
  171:            : "The mark is not set now");
  172:   if (!NILP (Vtransient_mark_mode) && NILP (Vmark_even_if_inactive)
  173:       && NILP (current_buffer->mark_active))
  174:     xsignal0 (Qmark_inactive);
  175: }
  176: 
  177: /* If the list of args INPUT was produced with an explicit call to
  178:    `list', look for elements that were computed with
  179:    (region-beginning) or (region-end), and put those expressions into
  180:    VALUES instead of the present values.
  181: 
  182:    This function doesn't return a value because it modifies elements
  183:    of VALUES to do its job.  */
  184: 
  185: static void
  186: fix_command (input, values)
  187:      Lisp_Object input, values;
  188: {
  189:   if (CONSP (input))
  190:     {
  191:       Lisp_Object car;
  192: 
  193:       car = XCAR (input);
  194:       /* Skip through certain special forms.  */
  195:       while (EQ (car, Qlet) || EQ (car, Qletx)
  196:              || EQ (car, Qsave_excursion)
  197:              || EQ (car, Qprogn))
  198:         {
  199:           while (CONSP (XCDR (input)))
  200:             input = XCDR (input);
  201:           input = XCAR (input);
  202:           if (!CONSP (input))
  203:             break;
  204:           car = XCAR (input);
  205:         }
  206:       if (EQ (car, Qlist))
  207:         {
  208:           Lisp_Object intail, valtail;
  209:           for (intail = Fcdr (input), valtail = values;
  210:                CONSP (valtail);
  211:                intail = Fcdr (intail), valtail = XCDR (valtail))
  212:             {
  213:               Lisp_Object elt;
  214:               elt = Fcar (intail);
  215:               if (CONSP (elt))
  216:                 {
  217:                   Lisp_Object presflag, carelt;
  218:                   carelt = Fcar (elt);
  219:                   /* If it is (if X Y), look at Y.  */
  220:                   if (EQ (carelt, Qif)
  221:                       && EQ (Fnthcdr (make_number (3), elt), Qnil))
  222:                     elt = Fnth (make_number (2), elt);
  223:                   /* If it is (when ... Y), look at Y.  */
  224:                   else if (EQ (carelt, Qwhen))
  225:                     {
  226:                       while (CONSP (XCDR (elt)))
  227:                         elt = XCDR (elt);
  228:                       elt = Fcar (elt);
  229:                     }
  230: 
  231:                   /* If the function call we're looking at
  232:                      is a special preserved one, copy the
  233:                      whole expression for this argument.  */
  234:                   if (CONSP (elt))
  235:                     {
  236:                       presflag = Fmemq (Fcar (elt), preserved_fns);
  237:                       if (!NILP (presflag))
  238:                         Fsetcar (valtail, Fcar (intail));
  239:                     }
  240:                 }
  241:             }
  242:         }
  243:     }
  244: }
  245: 
  246: DEFUN ("call-interactively", Fcall_interactively, Scall_interactively, 1, 3, 0,
  247:        doc: /* Call FUNCTION, reading args according to its interactive calling specs.
  248: Return the value FUNCTION returns.
  249: The function contains a specification of how to do the argument reading.
  250: In the case of user-defined functions, this is specified by placing a call
  251: to the function `interactive' at the top level of the function body.
  252: See `interactive'.
  253: 
  254: Optional second arg RECORD-FLAG non-nil
  255: means unconditionally put this command in the command-history.
  256: Otherwise, this is done only if an arg is read using the minibuffer.
  257: 
  258: Optional third arg KEYS, if given, specifies the sequence of events to
  259: supply, as a vector, if the command inquires which events were used to
  260: invoke it.  If KEYS is omitted or nil, the return value of
  261: `this-command-keys-vector' is used.  */)
  262:      (function, record_flag, keys)
  263:      Lisp_Object function, record_flag, keys;
  264: {
  265:   Lisp_Object *args, *visargs;
  266:   Lisp_Object fun;
  267:   Lisp_Object specs;
  268:   Lisp_Object filter_specs;
  269:   Lisp_Object teml;
  270:   Lisp_Object up_event;
  271:   Lisp_Object enable;
  272:   int speccount = SPECPDL_INDEX ();
  273: 
  274:   /* The index of the next element of this_command_keys to examine for
  275:      the 'e' interactive code.  */
  276:   int next_event;
  277: 
  278:   Lisp_Object prefix_arg;
  279:   unsigned char *string;
  280:   unsigned char *tem;
  281: 
  282:   /* If varies[i] > 0, the i'th argument shouldn't just have its value
  283:      in this call quoted in the command history.  It should be
  284:      recorded as a call to the function named callint_argfuns[varies[i]].  */
  285:   int *varies;
  286: 
  287:   register int i, j;
  288:   int count, foo;
  289:   char prompt1[100];
  290:   char *tem1;
  291:   int arg_from_tty = 0;
  292:   struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
  293:   int key_count;
  294:   int record_then_fail = 0;
  295: 
  296:   Lisp_Object save_this_command, save_last_command;
  297:   Lisp_Object save_this_original_command, save_real_this_command;
  298: 
  299:   save_this_command = Vthis_command;
  300:   save_this_original_command = Vthis_original_command;
  301:   save_real_this_command = real_this_command;
  302:   save_last_command = current_kboard->Vlast_command;
  303: 
  304:   if (NILP (keys))
  305:     keys = this_command_keys, key_count = this_command_key_count;
  306:   else
  307:     {
  308:       CHECK_VECTOR (keys);
  309:       key_count = XVECTOR (keys)->size;
  310:     }
  311: 
  312:   /* Save this now, since use of minibuffer will clobber it. */
  313:   prefix_arg = Vcurrent_prefix_arg;
  314: 
  315:   if (SYMBOLP (function))
  316:     enable = Fget (function, Qenable_recursive_minibuffers);
  317:   else
  318:     enable = Qnil;
  319: 
  320:   fun = indirect_function (function);
  321: 
  322:   specs = Qnil;
  323:   string = 0;
  324:   /* The idea of FILTER_SPECS is to provide away to
  325:      specify how to represent the arguments in command history.
  326:      The feature is not fully implemented.  */
  327:   filter_specs = Qnil;
  328: 
  329:   /* If k or K discard an up-event, save it here so it can be retrieved with U */
  330:   up_event = Qnil;
  331: 
  332:   /* Decode the kind of function.  Either handle it and return,
  333:      or go to `lose' if not interactive, or set either STRING or SPECS.  */
  334: 
  335:   if (SUBRP (fun))
  336:     {
  337:       string = (unsigned char *) XSUBR (fun)->prompt;
  338:       if (!string)
  339:         {
  340:         lose:
  341:           wrong_type_argument (Qcommandp, function);
  342:         }
  343:     }
  344:   else if (COMPILEDP (fun))
  345:     {
  346:       if ((XVECTOR (fun)->size & PSEUDOVECTOR_SIZE_MASK) <= COMPILED_INTERACTIVE)
  347:         goto lose;
  348:       specs = XVECTOR (fun)->contents[COMPILED_INTERACTIVE];
  349:     }
  350:   else
  351:     {
  352:       Lisp_Object form;
  353:       GCPRO2 (function, prefix_arg);
  354:       form = Finteractive_form (function);
  355:       UNGCPRO;
  356:       if (CONSP (form))
  357:         specs = filter_specs = Fcar (XCDR (form));
  358:       else
  359:         goto lose;
  360:     }
  361: 
  362:   /* If either SPECS or STRING is set to a string, use it.  */
  363:   if (STRINGP (specs))
  364:     {
  365:       /* Make a copy of string so that if a GC relocates specs,
  366:          `string' will still be valid.  */
  367:       string = (unsigned char *) alloca (SBYTES (specs) + 1);
  368:       bcopy (SDATA (specs), string,
  369:              SBYTES (specs) + 1);
  370:     }
  371:   else if (string == 0)
  372:     {
  373:       Lisp_Object input;
  374:       i = num_input_events;
  375:       input = specs;
  376:       /* Compute the arg values using the user's expression.  */
  377:       GCPRO2 (input, filter_specs);
  378:       specs = Feval (specs);
  379:       UNGCPRO;
  380:       if (i != num_input_events || !NILP (record_flag))
  381:         {
  382:           /* We should record this command on the command history.  */
  383:           Lisp_Object values;
  384:           /* Make a copy of the list of values, for the command history,
  385:              and turn them into things we can eval.  */
  386:           values = quotify_args (Fcopy_sequence (specs));
  387:           fix_command (input, values);
  388:           Vcommand_history
  389:             = Fcons (Fcons (function, values), Vcommand_history);
  390: 
  391:           /* Don't keep command history around forever.  */
  392:           if (INTEGERP (Vhistory_length) && XINT (Vhistory_length) > 0)
  393:             {
  394:               teml = Fnthcdr (Vhistory_length, Vcommand_history);
  395:               if (CONSP (teml))
  396:                 XSETCDR (teml, Qnil);
  397:             }
  398:         }
  399: 
  400:       Vthis_command = save_this_command;
  401:       Vthis_original_command = save_this_original_command;
  402:       real_this_command= save_real_this_command;
  403:       current_kboard->Vlast_command = save_last_command;
  404: 
  405:       single_kboard_state ();
  406:       return apply1 (function, specs);
  407:     }
  408: 
  409:   /* Here if function specifies a string to control parsing the defaults */
  410: 
  411:   /* Set next_event to point to the first event with parameters.  */
  412:   for (next_event = 0; next_event < key_count; next_event++)
  413:     if (EVENT_HAS_PARAMETERS (XVECTOR (keys)->contents[next_event]))
  414:       break;
  415: 
  416:   /* Handle special starting chars `*' and `@'.  Also `-'.  */
  417:   /* Note that `+' is reserved for user extensions.  */
  418:   while (1)
  419:     {
  420:       if (*string == '+')
  421:         error ("`+' is not used in `interactive' for ordinary commands");
  422:       else if (*string == '*')
  423:         {
  424:           string++;
  425:           if (!NILP (current_buffer->read_only))
  426:             {
  427:               if (!NILP (record_flag))
  428:                 {
  429:                   unsigned char *p = string;
  430:                   while (*p)
  431:                     {
  432:                       if (! (*p == 'r' || *p == 'p' || *p == 'P'
  433:                              || *p == '\n'))
  434:                         Fbarf_if_buffer_read_only ();
  435:                       p++;
  436:                     }
  437:                   record_then_fail = 1;
  438:                 }
  439:               else
  440:                 Fbarf_if_buffer_read_only ();
  441:             }
  442:         }
  443:       /* Ignore this for semi-compatibility with Lucid.  */
  444:       else if (*string == '-')
  445:         string++;
  446:       else if (*string == '@')
  447:         {
  448:           Lisp_Object event, tem;
  449: 
  450:           event = (next_event < key_count
  451:                    ? XVECTOR (keys)->contents[next_event]
  452:                    : Qnil);
  453:           if (EVENT_HAS_PARAMETERS (event)
  454:               && (tem = XCDR (event), CONSP (tem))
  455:               && (tem = XCAR (tem), CONSP (tem))
  456:               && (tem = XCAR (tem), WINDOWP (tem)))
  457:             {
  458:               if (MINI_WINDOW_P (XWINDOW (tem))
  459:                   && ! (minibuf_level > 0 && EQ (tem, minibuf_window)))
  460:                 error ("Attempt to select inactive minibuffer window");
  461: 
  462:               /* If the current buffer wants to clean up, let it.  */
  463:               if (!NILP (Vmouse_leave_buffer_hook))
  464:                 call1 (Vrun_hooks, Qmouse_leave_buffer_hook);
  465: 
  466:               Fselect_window (tem, Qnil);
  467:             }
  468:           string++;
  469:         }
  470:       else break;
  471:     }
  472: 
  473:   /* Count the number of arguments the interactive spec would have
  474:      us give to the function.  */
  475:   tem = string;
  476:   for (j = 0; *tem; j++)
  477:     {
  478:       /* 'r' specifications ("point and mark as 2 numeric args")
  479:          produce *two* arguments.  */
  480:       if (*tem == 'r') j++;
  481:       tem = (unsigned char *) index (tem, '\n');
  482:       if (tem)
  483:         tem++;
  484:       else
  485:         tem = (unsigned char *) "";
  486:     }
  487:   count = j;
  488: 
  489:   args = (Lisp_Object *) alloca ((count + 1) * sizeof (Lisp_Object));
  490:   visargs = (Lisp_Object *) alloca ((count + 1) * sizeof (Lisp_Object));
  491:   varies = (int *) alloca ((count + 1) * sizeof (int));
  492: 
  493:   for (i = 0; i < (count + 1); i++)
  494:     {
  495:       args[i] = Qnil;
  496:       visargs[i] = Qnil;
  497:       varies[i] = 0;
  498:     }
  499: 
  500:   GCPRO5 (prefix_arg, function, *args, *visargs, up_event);
  501:   gcpro3.nvars = (count + 1);
  502:   gcpro4.nvars = (count + 1);
  503: 
  504:   if (!NILP (enable))
  505:     specbind (Qenable_recursive_minibuffers, Qt);
  506: 
  507:   tem = string;
  508:   for (i = 1; *tem; i++)
  509:     {
  510:       strncpy (prompt1, tem + 1, sizeof prompt1 - 1);
  511:       prompt1[sizeof prompt1 - 1] = 0;
  512:       tem1 = (char *) index (prompt1, '\n');
  513:       if (tem1) *tem1 = 0;
  514: 
  515:       visargs[0] = build_string (prompt1);
  516:       if (index (prompt1, '%'))
  517:         callint_message = Fformat (i, visargs);
  518:       else
  519:         callint_message = visargs[0];
  520: 
  521:       switch (*tem)
  522:         {
  523:         case 'a':              /* Symbol defined as a function */
  524:           visargs[i] = Fcompleting_read (callint_message,
  525:                                          Vobarray, Qfboundp, Qt,
  526:                                          Qnil, Qnil, Qnil, Qnil);
  527:           /* Passing args[i] directly stimulates compiler bug */
  528:           teml = visargs[i];
  529:           args[i] = Fintern (teml, Qnil);
  530:           break;
  531: 
  532:         case 'b':              /* Name of existing buffer */
  533:           args[i] = Fcurrent_buffer ();
  534:           if (EQ (selected_window, minibuf_window))
  535:             args[i] = Fother_buffer (args[i], Qnil, Qnil);
  536:           args[i] = Fread_buffer (callint_message, args[i], Qt);
  537:           break;
  538: 
  539:         case 'B':              /* Name of buffer, possibly nonexistent */
  540:           args[i] = Fread_buffer (callint_message,
  541:                                   Fother_buffer (Fcurrent_buffer (), Qnil, Qnil),
  542:                                   Qnil);
  543:           break;
  544: 
  545:         case 'c':               /* Character */
  546:           args[i] = Fread_char (callint_message, Qnil, Qnil);
  547:           message1_nolog ((char *) 0);
  548:           /* Passing args[i] directly stimulates compiler bug */
  549:           teml = args[i];
  550:           visargs[i] = Fchar_to_string (teml);
  551:           break;
  552: 
  553:         case 'C':              /* Command: symbol with interactive function */
  554:           visargs[i] = Fcompleting_read (callint_message,
  555:                                          Vobarray, Qcommandp,
  556:                                          Qt, Qnil, Qnil, Qnil, Qnil);
  557:           /* Passing args[i] directly stimulates compiler bug */
  558:           teml = visargs[i];
  559:           args[i] = Fintern (teml, Qnil);
  560:           break;
  561: 
  562:         case 'd':              /* Value of point.  Does not do I/O.  */
  563:           set_marker_both (point_marker, Qnil, PT, PT_BYTE);
  564:           args[i] = point_marker;
  565:           /* visargs[i] = Qnil; */
  566:           varies[i] = 1;
  567:           break;
  568: 
  569:         case 'D':              /* Directory name. */
  570:           args[i] = Fread_file_name (callint_message, Qnil,
  571:                                      current_buffer->directory, Qlambda, Qnil,
  572:                                      Qfile_directory_p);
  573:           break;
  574: 
  575:         case 'f':              /* Existing file name. */
  576:           args[i] = Fread_file_name (callint_message,
  577:                                      Qnil, Qnil, Qlambda, Qnil, Qnil);
  578:           break;
  579: 
  580:         case 'F':              /* Possibly nonexistent file name. */
  581:           args[i] = Fread_file_name (callint_message,
  582:                                      Qnil, Qnil, Qnil, Qnil, Qnil);
  583:           break;
  584: 
  585:         case 'G':              /* Possibly nonexistent file name,
  586:                                    default to directory alone. */
  587:           args[i] = Fread_file_name (callint_message,
  588:                                      Qnil, Qnil, Qnil, build_string (""), Qnil);
  589:           break;
  590: 
  591:         case 'i':              /* Ignore an argument -- Does not do I/O */
  592:           varies[i] = -1;