src/callint.c

   1 /* Call a Lisp function interactively.
   2    Copyright (C) 1985, 1986, 1992 Free Software Foundation, Inc.
   3
   4 This file is part of GNU Emacs.
   5
   6 GNU Emacs is free software; you can redistribute it and/or modify
   7 it under the terms of the GNU General Public License as published by
   8 the Free Software Foundation; either version 1, or (at your option)
   9 any later version.
  10
  11 GNU Emacs is distributed in the hope that it will be useful,
  12 but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 GNU General Public License for more details.
  15
  16 You should have received a copy of the GNU General Public License
  17 along with GNU Emacs; see the file COPYING.  If not, write to
  18 the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */
  19
  20
  21 #include "config.h"
  22 #include "lisp.h"
  23 #include "buffer.h"
  24 #include "commands.h"
  25 #include "keyboard.h"
  26 #include "window.h"
  27 #include "mocklisp.h"
  28
  29 extern char *index ();
  30
  31 Lisp_Object Vprefix_arg, Vcurrent_prefix_arg, Qminus;
  32 Lisp_Object Qcall_interactively;
  33 Lisp_Object Vcommand_history;
  34
  35 Lisp_Object Vcommand_debug_status, Qcommand_debug_status;
  36 Lisp_Object Qenable_recursive_minibuffers;
  37
  38 /* This comment supplies the doc string for interactive,
  39    for make-docfile to see.  We cannot put this in the real DEFUN
  40    due to limits in the Unix cpp.
  41
  42 DEFUN ("interactive", Ffoo, Sfoo, 0, 0, 0,
  43  "Specify a way of parsing arguments for interactive use of a function.\n\
  44 For example, write\n\
  45   (defun foo (arg) \"Doc string\" (interactive \"p\") ...use arg...)\n\
  46 to make ARG be the prefix argument when `foo' is called as a command.\n\
  47 The \"call\" to `interactive' is actually a declaration rather than a function;\n\
  48  it tells `call-interactively' how to read arguments\n\
  49  to pass to the function.\n\
  50 When actually called, `interactive' just returns nil.\n\
  51 \n\
  52 The argument of `interactive' is usually a string containing a code letter\n\
  53  followed by a prompt.  (Some code letters do not use I/O to get\n\
  54  the argument and do not need prompts.)  To prompt for multiple arguments,\n\
  55  give a code letter, its prompt, a newline, and another code letter, etc.\n\
  56  Prompts are passed to format, and may use % escapes to print the\n\
  57  arguments that have already been read.\n\
  58 If the argument is not a string, it is evaluated to get a list of\n\
  59  arguments to pass to the function.\n\
  60 Just `(interactive)' means pass no args when calling interactively.\n\
  61 \nCode letters available are:\n\
  62 a -- Function name: symbol with a function definition.\n\
  63 b -- Name of existing buffer.\n\
  64 B -- Name of buffer, possibly nonexistent.\n\
  65 c -- Character.\n\
  66 C -- Command name: symbol with interactive function definition.\n\
  67 d -- Value of point as number.  Does not do I/O.\n\
  68 D -- Directory name.\n\
  69 e -- Mouse click that invoked this command (value of `last-nonmenu-event').\n\
  70 f -- Existing file name.\n\
  71 F -- Possibly nonexistent file name.\n\
  72 k -- Key sequence (string).\n\
  73 m -- Value of mark as number.  Does not do I/O.\n\
  74 n -- Number read using minibuffer.\n\
  75 N -- Prefix arg converted to number, or if none, do like code `n'.\n\
  76 p -- Prefix arg converted to number.  Does not do I/O.\n\
  77 P -- Prefix arg in raw form.  Does not do I/O.\n\
  78 r -- Region: point and mark as 2 numeric args, smallest first.  Does no I/O.\n\
  79 s -- Any string.\n\
  80 S -- Any symbol.\n\
  81 v -- Variable name: symbol that is user-variable-p.\n\
  82 x -- Lisp expression read but not evaluated.\n\
  83 X -- Lisp expression read and evaluated.\n\
  84 In addition, if the string begins with `*'\n\
  85  then an error is signaled if the buffer is read-only.\n\
  86  This happens before reading any arguments.\n\
  87 If the string begins with `@', then the window the mouse is over is selected\n\
  88  before anything else is done.  You may use both `@' and `*';\n\
  89 they are processed in the order that they appear."
  90 */
  91
  92 /* ARGSUSED */
  93 DEFUN ("interactive", Finteractive, Sinteractive, 0, UNEVALLED, 0,
  94   0 /* See immediately above */)
  95   (args)
  96      Lisp_Object args;
  97 {
  98   return Qnil;
  99 }
 100
 101 /* Quotify EXP: if EXP is constant, return it.
 102    If EXP is not constant, return (quote EXP).  */
 103 Lisp_Object
 104 quotify_arg (exp)
 105      register Lisp_Object exp;
 106 {
 107   if (XTYPE (exp) != Lisp_Int && XTYPE (exp) != Lisp_String
 108       && !NILP (exp) && !EQ (exp, Qt))
 109     return Fcons (Qquote, Fcons (exp, Qnil));
 110
 111   return exp;
 112 }
 113
 114 /* Modify EXP by quotifying each element (except the first).  */
 115 Lisp_Object
 116 quotify_args (exp)
 117      Lisp_Object exp;
 118 {
 119   register Lisp_Object tail;
 120   register struct Lisp_Cons *ptr;
 121   for (tail = exp; CONSP (tail); tail = ptr->cdr)
 122     {
 123       ptr = XCONS (tail);
 124       ptr->car = quotify_arg (ptr->car);
 125     }
 126   return exp;
 127 }
 128
 129 char *callint_argfuns[]
 130     = {"", "point", "mark", "region-beginning", "region-end"};
 131
 132 static void
 133 check_mark ()
 134 {
 135   Lisp_Object tem = Fmarker_buffer (current_buffer->mark);
 136   if (NILP (tem) || (XBUFFER (tem) != current_buffer))
 137     error ("The mark is not set now");
 138 }
 139
 140
 141 DEFUN ("call-interactively", Fcall_interactively, Scall_interactively, 1, 2, 0,
 142   "Call FUNCTION, reading args according to its interactive calling specs.\n\
 143 The function contains a specification of how to do the argument reading.\n\
 144 In the case of user-defined functions, this is specified by placing a call\n\
 145 to the function `interactive' at the top level of the function body.\n\
 146 See `interactive'.\n\
 147 \n\
 148 Optional second arg RECORD-FLAG non-nil\n\
 149 means unconditionally put this command in the command-history.\n\
 150 Otherwise, this is done only if an arg is read using the minibuffer.")
 151   (function, record)
 152      Lisp_Object function, record;
 153 {
 154   Lisp_Object *args, *visargs;
 155   unsigned char **argstrings;
 156   Lisp_Object fun;
 157   Lisp_Object funcar;
 158   Lisp_Object specs;
 159   Lisp_Object teml;
 160   Lisp_Object enable;
 161   int speccount = specpdl_ptr - specpdl;
 162
 163   Lisp_Object prefix_arg;
 164   unsigned char *string;
 165   unsigned char *tem;
 166
 167   /* If varies[i] > 0, the i'th argument shouldn't just have its value
 168      in this call quoted in the command history.  It should be
 169      recorded as a call to the function named callint_argfuns[varies[i]].  */
 170   int *varies;
 171
 172   register int i, j;
 173   int count, foo;
 174   char prompt[100];
 175   char prompt1[100];
 176   char *tem1;
 177   int arg_from_tty = 0;
 178   struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
 179
 180   /* Save this now, since use of minibuffer will clobber it. */
 181   prefix_arg = Vcurrent_prefix_arg;
 182
 183  retry:
 184
 185   if (XTYPE (function) == Lisp_Symbol)
 186     enable = Fget (function, Qenable_recursive_minibuffers);
 187
 188   fun = indirect_function (function);
 189
 190   specs = Qnil;
 191   string = 0;
 192
 193   /* Decode the kind of function.  Either handle it and return,
 194      or go to `lose' if not interactive, or go to `retry'
 195      to specify a different function, or set either STRING or SPECS.  */
 196
 197   if (XTYPE (fun) == Lisp_Subr)
 198     {
 199       string = (unsigned char *) XSUBR (fun)->prompt;
 200       if (!string)
 201         {
 202         lose:
 203           function = wrong_type_argument (Qcommandp, function, 0);
 204           goto retry;
 205         }
 206       if ((int) string == 1)
 207         /* Let SPECS (which is nil) be used as the args.  */
 208         string = 0;
 209     }
 210   else if (XTYPE (fun) == Lisp_Compiled)
 211     {
 212       if (XVECTOR (fun)->size <= COMPILED_INTERACTIVE)
 213         goto lose;
 214       specs = XVECTOR (fun)->contents[COMPILED_INTERACTIVE];
 215     }
 216   else if (!CONSP (fun))
 217     goto lose;
 218   else if (funcar = Fcar (fun), EQ (funcar, Qautoload))
 219     {
 220       GCPRO2 (function, prefix_arg);
 221       do_autoload (fun, function);
 222       UNGCPRO;
 223       goto retry;
 224     }
 225   else if (EQ (funcar, Qlambda))
 226     {
 227       specs = Fassq (Qinteractive, Fcdr (Fcdr (fun)));
 228       if (NILP (specs))
 229         goto lose;
 230       specs = Fcar (Fcdr (specs));
 231     }
 232   else if (EQ (funcar, Qmocklisp))
 233     return ml_apply (fun, Qinteractive);
 234   else
 235     goto lose;
 236
 237   /* If either specs or string is set to a string, use it.  */
 238   if (XTYPE (specs) == Lisp_String)
 239     {
 240       /* Make a copy of string so that if a GC relocates specs,
 241          `string' will still be valid.  */
 242       string = (unsigned char *) alloca (XSTRING (specs)->size + 1);
 243       bcopy (XSTRING (specs)->data, string, XSTRING (specs)->size + 1);
 244     }
 245   else if (string == 0)
 246     {
 247       i = num_input_chars;
 248       specs = Feval (specs);
 249       if (i != num_input_chars || !NILP (record))
 250         Vcommand_history
 251           = Fcons (Fcons (function, quotify_args (Fcopy_sequence (specs))),
 252                    Vcommand_history);
 253       return apply1 (function, specs);
 254     }
 255
 256   /* Here if function specifies a string to control parsing the defaults */
 257
 258   /* Handle special starting chars `*' and `@'.  */
 259   while (1)
 260     {
 261       if (*string == '*')
 262         {
 263           string++;
 264           if (!NILP (current_buffer->read_only))
 265             Fbarf_if_buffer_read_only ();
 266         }
 267       else if (*string == '@')
 268         {
 269           string++;
 270           if (!NILP (Vmouse_window))
 271             Fselect_window (Vmouse_window);
 272         }
 273       else break;
 274     }
 275
 276   /* Count the number of arguments the interactive spec would have
 277      us give to the function.  */
 278   tem = string;
 279   for (j = 0; *tem; j++)
 280     {
 281       /* 'r' specifications ("point and mark as 2 numeric args")
 282          produce *two* arguments.  */
 283       if (*tem == 'r') j++;
 284       tem = (unsigned char *) index (tem, '\n');
 285       if (tem)
 286         tem++;
 287       else
 288         tem = (unsigned char *) "";
 289     }
 290   count = j;
 291
 292   args = (Lisp_Object *) alloca ((count + 1) * sizeof (Lisp_Object));
 293   visargs = (Lisp_Object *) alloca ((count + 1) * sizeof (Lisp_Object));
 294   argstrings = (unsigned char **) alloca ((count + 1) * sizeof (char *));
 295   varies = (int *) alloca ((count + 1) * sizeof (int));
 296
 297   for (i = 0; i < (count + 1); i++)
 298     {
 299       args[i] = Qnil;
 300       visargs[i] = Qnil;
 301       varies[i] = 0;
 302     }
 303
 304   GCPRO4 (prefix_arg, function, *args, *visargs);
 305   gcpro3.nvars = (count + 1);
 306   gcpro4.nvars = (count + 1);
 307
 308   if (!NILP (enable))
 309     specbind (Qenable_recursive_minibuffers, Qt);
 310
 311   tem = string;
 312   for (i = 1; *tem; i++)
 313     {
 314       strncpy (prompt1, tem + 1, sizeof prompt1 - 1);
 315       prompt1[sizeof prompt1 - 1] = 0;
 316       tem1 = index (prompt1, '\n');
 317       if (tem1) *tem1 = 0;
 318       /* Fill argstrings with a vector of C strings
 319          corresponding to the Lisp strings in visargs.  */
 320       for (j = 1; j < i; j++)
 321         argstrings[j]
 322           = EQ (visargs[j], Qnil)
 323             ? (unsigned char *) ""
 324               : XSTRING (visargs[j])->data;
 325
 326       doprnt (prompt, sizeof prompt, prompt1, 0, j - 1, argstrings + 1);
 327
 328       switch (*tem)
 329         {
 330         case 'a':               /* Symbol defined as a function */
 331           visargs[i] = Fcompleting_read (build_string (prompt),
 332                                          Vobarray, Qfboundp, Qt, Qnil, Qnil);
 333           /* Passing args[i] directly stimulates compiler bug */
 334           teml = visargs[i];
 335           args[i] = Fintern (teml, Qnil);
 336           break;
 337
 338         case 'b':               /* Name of existing buffer */
 339           args[i] = Fcurrent_buffer ();
 340           if (EQ (selected_window, minibuf_window))
 341             args[i] = Fother_buffer (args[i]);
 342           args[i] = Fread_buffer (build_string (prompt), args[i], Qt);
 343           break;
 344
 345         case 'B':               /* Name of buffer, possibly nonexistent */
 346           args[i] = Fread_buffer (build_string (prompt),
 347                                   Fother_buffer (Fcurrent_buffer ()), Qnil);
 348           break;
 349
 350         case 'c':               /* Character */
 351           message1 (prompt);
 352           args[i] = Fread_char ();
 353           /* Passing args[i] directly stimulates compiler bug */
 354           teml = args[i];
 355           visargs[i] = Fchar_to_string (teml);
 356           break;
 357
 358         case 'C':               /* Command: symbol with interactive function */
 359           visargs[i] = Fcompleting_read (build_string (prompt),
 360                                          Vobarray, Qcommandp, Qt, Qnil, Qnil);
 361           /* Passing args[i] directly stimulates compiler bug */
 362           teml = visargs[i];
 363           args[i] = Fintern (teml, Qnil);
 364           break;
 365
 366         case 'd':               /* Value of point.  Does not do I/O.  */
 367           XFASTINT (args[i]) = point;
 368           /* visargs[i] = Qnil; */
 369           varies[i] = 1;
 370           break;
 371
 372         case 'D':               /* Directory name. */
 373           args[i] = Fread_file_name (build_string (prompt), Qnil,
 374                                      current_buffer->directory, Qlambda, Qnil);
 375           break;
 376
 377         case 'f':               /* Existing file name. */
 378           args[i] = Fread_file_name (build_string (prompt),
 379                                      Qnil, Qnil, Qlambda, Qnil);
 380           break;
 381
 382         case 'F':               /* Possibly nonexistent file name. */
 383           args[i] = Fread_file_name (build_string (prompt),
 384                                      Qnil, Qnil, Qnil, Qnil);
 385           break;
 386
 387         case 'k':               /* Key sequence (string) */
 388           args[i] = Fread_key_sequence (build_string (prompt), Qnil);
 389           teml = args[i];
 390           visargs[i] = Fkey_description (teml);
 391           break;
 392
 393         case 'e':               /* Mouse click.  */
 394           args[i] = last_command_char;
 395           if (NILP (Fmouse_click_p (args[i])))
 396             error ("%s must be bound to a mouse click.",
 397                    (XTYPE (function) == Lisp_Symbol
 398                     ? (char *) XSYMBOL (function)->name->data
 399                     : "Command"));
 400           varies[i] = -1;
 401           break;
 402
 403         case 'm':               /* Value of mark.  Does not do I/O.  */
 404           check_mark ();
 405           /* visargs[i] = Qnil; */
 406           XFASTINT (args[i]) = marker_position (current_buffer->mark);
 407           varies[i] = 2;
 408           break;
 409
 410         case 'N':               /* Prefix arg, else number from minibuffer */
 411           if (!NILP (prefix_arg))
 412             goto have_prefix_arg;
 413         case 'n':               /* Read number from minibuffer.  */
 414           do
 415             args[i] = Fread_minibuffer (build_string (prompt), Qnil);
 416           while (! NUMBERP (args[i]));
 417           visargs[i] = last_minibuf_string;
 418           break;
 419
 420         case 'P':               /* Prefix arg in raw form.  Does no I/O.  */
 421         have_prefix_arg:
 422           args[i] = prefix_arg;
 423           /* visargs[i] = Qnil; */
 424           varies[i] = -1;
 425           break;
 426
 427         case 'p':               /* Prefix arg converted to number.  No I/O. */
 428           args[i] = Fprefix_numeric_value (prefix_arg);
 429           /* visargs[i] = Qnil; */
 430           varies[i] = -1;
 431           break;
 432
 433         case 'r':               /* Region, point and mark as 2 args. */
 434           check_mark ();
 435           /* visargs[i+1] = Qnil; */
 436           foo = marker_position (current_buffer->mark);
 437           /* visargs[i] = Qnil; */
 438           XFASTINT (args[i]) = point < foo ? point : foo;
 439           varies[i] = 3;
 440           XFASTINT (args[++i]) = point > foo ? point : foo;
 441           varies[i] = 4;
 442           break;
 443
 444         case 's':               /* String read via minibuffer.  */
 445           args[i] = Fread_string (build_string (prompt), Qnil);
 446           break;
 447
 448         case 'S':               /* Any symbol.  */
 449           visargs[i] = Fread_no_blanks_input (build_string (prompt), Qnil);
 450           /* Passing args[i] directly stimulates compiler bug */
 451           teml = visargs[i];
 452           args[i] = Fintern (teml, Qnil);
 453           break;
 454
 455         case 'v':               /* Variable name: symbol that is
 456                                    user-variable-p. */
 457           args[i] = Fread_variable (build_string (prompt));
 458           visargs[i] = last_minibuf_string;
 459           break;
 460
 461         case 'x':               /* Lisp expression read but not evaluated */
 462           args[i] = Fread_minibuffer (build_string (prompt), Qnil);
 463           visargs[i] = last_minibuf_string;
 464           break;
 465
 466         case 'X':               /* Lisp expression read and evaluated */
 467           args[i] = Feval_minibuffer (build_string (prompt), Qnil);
 468           visargs[i] = last_minibuf_string;
 469           break;
 470
 471         default:
 472           error ("Invalid control letter \"%c\" (%03o) in interactive calling string",
 473                  *tem, *tem);
 474         }
 475
 476       if (varies[i] == 0)
 477         arg_from_tty = 1;
 478
 479       if (NILP (visargs[i]) && XTYPE (args[i]) == Lisp_String)
 480         visargs[i] = args[i];
 481
 482       tem = (unsigned char *) index (tem, '\n');
 483       if (tem) tem++;
 484       else tem = (unsigned char *) "";
 485     }
 486   unbind_to (speccount, Qnil);
 487
 488   QUIT;
 489
 490   args[0] = function;
 491
 492   if (arg_from_tty || !NILP (record))
 493     {
 494       visargs[0] = function;
 495       for (i = 1; i < count + 1; i++)
 496         if (varies[i] > 0)
 497           visargs[i] = Fcons (intern (callint_argfuns[varies[i]]), Qnil);
 498         else
 499           visargs[i] = quotify_arg (args[i]);
 500       Vcommand_history = Fcons (Flist (count + 1, visargs),
 501                                 Vcommand_history);
 502     }
 503
 504   {
 505     Lisp_Object val;
 506     specbind (Qcommand_debug_status, Qnil);
 507
 508     val = Ffuncall (count + 1, args);
 509     UNGCPRO;
 510     return unbind_to (speccount, val);
 511   }
 512 }
 513
 514 DEFUN ("prefix-numeric-value", Fprefix_numeric_value, Sprefix_numeric_value,
 515   1, 1, 0,
 516   "Return numeric meaning of raw prefix argument ARG.\n\
 517 A raw prefix argument is what you get from `(interactive \"P\")'.\n\
 518 Its numeric meaning is what you would get from `(interactive \"p\")'.")
 519   (raw)
 520      Lisp_Object raw;
 521 {
 522   Lisp_Object val;
 523
 524   /* Tag val as an integer, so the rest of the assignments
 525      may use XSETINT.  */
 526   XFASTINT (val) = 0;
 527
 528   if (NILP (raw))
 529     XFASTINT (val) = 1;
 530   else if (EQ (raw, Qminus))
 531     XSETINT (val, -1);
 532   else if (CONSP (raw))
 533     XSETINT (val, XINT (XCONS (raw)->car));
 534   else if (XTYPE (raw) == Lisp_Int)
 535     val = raw;
 536   else
 537     XFASTINT (val) = 1;
 538
 539   return val;
 540 }
 541
 542 syms_of_callint ()
 543 {
 544   Qminus = intern ("-");
 545   staticpro (&Qminus);
 546
 547   Qcall_interactively = intern ("call-interactively");
 548   staticpro (&Qcall_interactively);
 549
 550   Qcommand_debug_status = intern ("command-debug-status");
 551   staticpro (&Qcommand_debug_status);
 552
 553   Qenable_recursive_minibuffers = intern ("enable-recursive-minibuffers");
 554   staticpro (&Qenable_recursive_minibuffers);
 555
 556   DEFVAR_LISP ("prefix-arg", &Vprefix_arg,
 557     "The value of the prefix argument for the next editing command.\n\
 558 It may be a number, or the symbol `-' for just a minus sign as arg,\n\
 559 or a list whose car is a number for just one or more C-U's\n\
 560 or nil if no argument has been specified.\n\
 561 \n\
 562 You cannot examine this variable to find the argument for this command\n\
 563 since it has been set to nil by the time you can look.\n\
 564 Instead, you should use the variable `current-prefix-arg', although\n\
 565 normally commands can get this prefix argument with (interactive \"P\").");
 566   Vprefix_arg = Qnil;
 567
 568   DEFVAR_LISP ("current-prefix-arg", &Vcurrent_prefix_arg,
 569     "The value of the prefix argument for this editing command.\n\
 570 It may be a number, or the symbol `-' for just a minus sign as arg,\n\
 571 or a list whose car is a number for just one or more C-U's\n\
 572 or nil if no argument has been specified.\n\
 573 This is what `(interactive \"P\")' returns.");
 574   Vcurrent_prefix_arg = Qnil;
 575
 576   DEFVAR_LISP ("command-history", &Vcommand_history,
 577     "List of recent commands that read arguments from terminal.\n\
 578 Each command is represented as a form to evaluate.");
 579   Vcommand_history = Qnil;
 580
 581   DEFVAR_LISP ("command-debug-status", &Vcommand_debug_status,
 582     "Debugging status of current interactive command.\n\
 583 Bound each time `call-interactively' is called;\n\
 584 may be set by the debugger as a reminder for itself.");
 585   Vcommand_debug_status = Qnil;
 586
 587   defsubr (&Sinteractive);
 588   defsubr (&Scall_interactively);
 589   defsubr (&Sprefix_numeric_value);
 590 }