#include <config.h>
#include "lisp.h"
#include "buffer.h"
#include "commands.h"
#include "keyboard.h"
#include "window.h"
#include "keymap.h"
#ifdef HAVE_INDEX
extern char *index P_ ((const char *, int));
#endif
extern Lisp_Object Qcursor_in_echo_area;
extern Lisp_Object Qfile_directory_p;
Lisp_Object Vcurrent_prefix_arg, Qminus, Qplus;
Lisp_Object Qcall_interactively;
Lisp_Object Vcommand_history;
extern Lisp_Object Vhistory_length;
extern Lisp_Object Vthis_original_command, real_this_command;
Lisp_Object Vcommand_debug_status, Qcommand_debug_status;
Lisp_Object Qenable_recursive_minibuffers;
Lisp_Object Vmark_even_if_inactive;
Lisp_Object Vmouse_leave_buffer_hook, Qmouse_leave_buffer_hook;
Lisp_Object Qlist, Qlet, Qletx, Qsave_excursion, Qprogn, Qif, Qwhen;
static Lisp_Object preserved_fns;
static Lisp_Object point_marker;
static Lisp_Object callint_message;
DEFUN ("interactive", Finteractive, Sinteractive, 0, UNEVALLED, 0,
doc: )
(args)
Lisp_Object args;
{
return Qnil;
}
Lisp_Object
quotify_arg (exp)
register Lisp_Object exp;
{
if (!INTEGERP (exp) && !STRINGP (exp)
&& !NILP (exp) && !EQ (exp, Qt))
return Fcons (Qquote, Fcons (exp, Qnil));
return exp;
}
Lisp_Object
quotify_args (exp)
Lisp_Object exp;
{
register Lisp_Object tail;
Lisp_Object next;
for (tail = exp; CONSP (tail); tail = next)
{
next = XCDR (tail);
XSETCAR (tail, quotify_arg (XCAR (tail)));
}
return exp;
}
char *callint_argfuns[]
= {"", "point", "mark", "region-beginning", "region-end"};
static void
check_mark (for_region)
int for_region;
{
Lisp_Object tem;
tem = Fmarker_buffer (current_buffer->mark);
if (NILP (tem) || (XBUFFER (tem) != current_buffer))
error (for_region ? "The mark is not set now, so there is no region"
: "The mark is not set now");
if (!NILP (Vtransient_mark_mode) && NILP (Vmark_even_if_inactive)
&& NILP (current_buffer->mark_active))
xsignal0 (Qmark_inactive);
}
static void
fix_command (input, values)
Lisp_Object input, values;
{
if (CONSP (input))
{
Lisp_Object car;
car = XCAR (input);
while (EQ (car, Qlet) || EQ (car, Qletx)
|| EQ (car, Qsave_excursion)
|| EQ (car, Qprogn))
{
while (CONSP (XCDR (input)))
input = XCDR (input);
input = XCAR (input);
if (!CONSP (input))
break;
car = XCAR (input);
}
if (EQ (car, Qlist))
{
Lisp_Object intail, valtail;
for (intail = Fcdr (input), valtail = values;
CONSP (valtail);
intail = Fcdr (intail), valtail = XCDR (valtail))
{
Lisp_Object elt;
elt = Fcar (intail);
if (CONSP (elt))
{
Lisp_Object presflag, carelt;
carelt = Fcar (elt);
if (EQ (carelt, Qif)
&& EQ (Fnthcdr (make_number (3), elt), Qnil))
elt = Fnth (make_number (2), elt);
else if (EQ (carelt, Qwhen))
{
while (CONSP (XCDR (elt)))
elt = XCDR (elt);
elt = Fcar (elt);
}
if (CONSP (elt))
{
presflag = Fmemq (Fcar (elt), preserved_fns);
if (!NILP (presflag))
Fsetcar (valtail, Fcar (intail));
}
}
}
}
}
}
DEFUN ("call-interactively", Fcall_interactively, Scall_interactively, 1, 3, 0,
doc: )
(function, record_flag, keys)
Lisp_Object function, record_flag, keys;
{
Lisp_Object *args, *visargs;
Lisp_Object fun;
Lisp_Object specs;
Lisp_Object filter_specs;
Lisp_Object teml;
Lisp_Object up_event;
Lisp_Object enable;
int speccount = SPECPDL_INDEX ();
int next_event;
Lisp_Object prefix_arg;
unsigned char *string;
unsigned char *tem;
int *varies;
register int i, j;
int count, foo;
char prompt1[100];
char *tem1;
int arg_from_tty = 0;
struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
int key_count;
int record_then_fail = 0;
Lisp_Object save_this_command, save_last_command;
Lisp_Object save_this_original_command, save_real_this_command;
save_this_command = Vthis_command;
save_this_original_command = Vthis_original_command;
save_real_this_command = real_this_command;
save_last_command = current_kboard->Vlast_command;
if (NILP (keys))
keys = this_command_keys, key_count = this_command_key_count;
else
{
CHECK_VECTOR (keys);
key_count = XVECTOR (keys)->size;
}
prefix_arg = Vcurrent_prefix_arg;
if (SYMBOLP (function))
enable = Fget (function, Qenable_recursive_minibuffers);
else
enable = Qnil;
fun = indirect_function (function);
specs = Qnil;
string = 0;
filter_specs = Qnil;
up_event = Qnil;
if (SUBRP (fun))
{
string = (unsigned char *) XSUBR (fun)->prompt;
if (!string)
{
lose:
wrong_type_argument (Qcommandp, function);
}
}
else if (COMPILEDP (fun))
{
if ((XVECTOR (fun)->size & PSEUDOVECTOR_SIZE_MASK) <= COMPILED_INTERACTIVE)
goto lose;
specs = XVECTOR (fun)->contents[COMPILED_INTERACTIVE];
}
else
{
Lisp_Object form;
GCPRO2 (function, prefix_arg);
form = Finteractive_form (function);
UNGCPRO;
if (CONSP (form))
specs = filter_specs = Fcar (XCDR (form));
else
goto lose;
}
if (STRINGP (specs))
{
string = (unsigned char *) alloca (SBYTES (specs) + 1);
bcopy (SDATA (specs), string,
SBYTES (specs) + 1);
}
else if (string == 0)
{
Lisp_Object input;
i = num_input_events;
input = specs;
GCPRO2 (input, filter_specs);
specs = Feval (specs);
UNGCPRO;
if (i != num_input_events || !NILP (record_flag))
{
Lisp_Object values;
values = quotify_args (Fcopy_sequence (specs));
fix_command (input, values);
Vcommand_history
= Fcons (Fcons (function, values), Vcommand_history);
if (INTEGERP (Vhistory_length) && XINT (Vhistory_length) > 0)
{
teml = Fnthcdr (Vhistory_length, Vcommand_history);
if (CONSP (teml))
XSETCDR (teml, Qnil);
}
}
Vthis_command = save_this_command;
Vthis_original_command = save_this_original_command;
real_this_command= save_real_this_command;
current_kboard->Vlast_command = save_last_command;
single_kboard_state ();
return apply1 (function, specs);
}
for (next_event = 0; next_event < key_count; next_event++)
if (EVENT_HAS_PARAMETERS (XVECTOR (keys)->contents[next_event]))
break;
while (1)
{
if (*string == '+')
error ("`+' is not used in `interactive' for ordinary commands");
else if (*string == '*')
{
string++;
if (!NILP (current_buffer->read_only))
{
if (!NILP (record_flag))
{
unsigned char *p = string;
while (*p)
{
if (! (*p == 'r' || *p == 'p' || *p == 'P'
|| *p == '\n'))
Fbarf_if_buffer_read_only ();
p++;
}
record_then_fail = 1;
}
else
Fbarf_if_buffer_read_only ();
}
}
else if (*string == '-')
string++;
else if (*string == '@')
{
Lisp_Object event, tem;
event = (next_event < key_count
? XVECTOR (keys)->contents[next_event]
: Qnil);
if (EVENT_HAS_PARAMETERS (event)
&& (tem = XCDR (event), CONSP (tem))
&& (tem = XCAR (tem), CONSP (tem))
&& (tem = XCAR (tem), WINDOWP (tem)))
{
if (MINI_WINDOW_P (XWINDOW (tem))
&& ! (minibuf_level > 0 && EQ (tem, minibuf_window)))
error ("Attempt to select inactive minibuffer window");
if (!NILP (Vmouse_leave_buffer_hook))
call1 (Vrun_hooks, Qmouse_leave_buffer_hook);
Fselect_window (tem, Qnil);
}
string++;
}
else break;
}
tem = string;
for (j = 0; *tem; j++)
{
if (*tem == 'r') j++;
tem = (unsigned char *) index (tem, '\n');
if (tem)
tem++;
else
tem = (unsigned char *) "";
}
count = j;
args = (Lisp_Object *) alloca ((count + 1) * sizeof (Lisp_Object));
visargs = (Lisp_Object *) alloca ((count + 1) * sizeof (Lisp_Object));
varies = (int *) alloca ((count + 1) * sizeof (int));
for (i = 0; i < (count + 1); i++)
{
args[i] = Qnil;
visargs[i] = Qnil;
varies[i] = 0;
}
GCPRO5 (prefix_arg, function, *args, *visargs, up_event);
gcpro3.nvars = (count + 1);
gcpro4.nvars = (count + 1);
if (!NILP (enable))
specbind (Qenable_recursive_minibuffers, Qt);
tem = string;
for (i = 1; *tem; i++)
{
strncpy (prompt1, tem + 1, sizeof prompt1 - 1);
prompt1[sizeof prompt1 - 1] = 0;
tem1 = (char *) index (prompt1, '\n');
if (tem1) *tem1 = 0;
visargs[0] = build_string (prompt1);
if (index (prompt1, '%'))
callint_message = Fformat (i, visargs);
else
callint_message = visargs[0];
switch (*tem)
{
case 'a':
visargs[i] = Fcompleting_read (callint_message,
Vobarray, Qfboundp, Qt,
Qnil, Qnil, Qnil, Qnil);
teml = visargs[i];
args[i] = Fintern (teml, Qnil);
break;
case 'b':
args[i] = Fcurrent_buffer ();
if (EQ (selected_window, minibuf_window))
args[i] = Fother_buffer (args[i], Qnil, Qnil);
args[i] = Fread_buffer (callint_message, args[i], Qt);
break;
case 'B':
args[i] = Fread_buffer (callint_message,
Fother_buffer (Fcurrent_buffer (), Qnil, Qnil),
Qnil);
break;
case 'c':
args[i] = Fread_char (callint_message, Qnil, Qnil);
message1_nolog ((char *) 0);
teml = args[i];
visargs[i] = Fchar_to_string (teml);
break;
case 'C':
visargs[i] = Fcompleting_read (callint_message,
Vobarray, Qcommandp,
Qt, Qnil, Qnil, Qnil, Qnil);
teml = visargs[i];
args[i] = Fintern (teml, Qnil);
break;
case 'd':
set_marker_both (point_marker, Qnil, PT, PT_BYTE);
args[i] = point_marker;
varies[i] = 1;
break;
case 'D':
args[i] = Fread_file_name (callint_message, Qnil,
current_buffer->directory, Qlambda, Qnil,
Qfile_directory_p);
break;
case 'f':
args[i] = Fread_file_name (callint_message,
Qnil, Qnil, Qlambda, Qnil, Qnil);
break;
case 'F':
args[i] = Fread_file_name (callint_message,
Qnil, Qnil, Qnil, Qnil, Qnil);
break;
case 'G':
args[i] = Fread_file_name (callint_message,
Qnil, Qnil, Qnil, build_string (""), Qnil);
break;
case 'i':
varies[i] = -1;
break;
case 'k':
{
int speccount1 = SPECPDL_INDEX ();
specbind (Qcursor_in_echo_area, Qt);
args[i] = Fread_key_sequence (callint_message,
Qnil, Qnil, Qnil, Qnil);
unbind_to (speccount1, Qnil);
teml = args[i];
visargs[i] = Fkey_description (teml, Qnil);
teml = Faref (args[i], make_number (XINT (Flength (args[i])) - 1));
if (CONSP (teml))
teml = XCAR (teml);
if (SYMBOLP (teml))
{
Lisp_Object tem2;
teml = Fget (teml, intern ("event-symbol-elements"));
tem2 = Fmemq (intern ("down"), Fcdr (teml));
if (! NILP (tem2))
up_event = Fread_event (Qnil, Qnil, Qnil);
}
}
break;
case 'K':
{
int speccount1 = SPECPDL_INDEX ();
specbind (Qcursor_in_echo_area, Qt);
args[i] = Fread_key_sequence (callint_message,
Qnil, Qt, Qnil, Qnil);
teml = args[i];
visargs[i] = Fkey_description (teml, Qnil);
unbind_to (speccount1, Qnil);
teml = Faref (args[i], make_number (XINT (Flength (args[i])) - 1));
if (CONSP (teml))
teml = XCAR (teml);
if (SYMBOLP (teml))
{
Lisp_Object tem2;
teml = Fget (teml, intern ("event-symbol-elements"));
tem2 = Fmemq (intern ("down"), Fcdr (teml));
if (! NILP (tem2))
up_event = Fread_event (Qnil, Qnil, Qnil);
}
}
break;
case 'U':
if (!NILP (up_event))
{
args[i] = Fmake_vector (make_number (1), up_event);
up_event = Qnil;
teml = args[i];
visargs[i] = Fkey_description (teml, Qnil);
}
break;
case 'e':
if (next_event >= key_count)
error ("%s must be bound to an event with parameters",
(SYMBOLP (function)
? (char *) SDATA (SYMBOL_NAME (function))
: "command"));
args[i] = XVECTOR (keys)->contents[next_event++];
varies[i] = -1;
while (next_event < key_count
&& ! (EVENT_HAS_PARAMETERS
(XVECTOR (keys)->contents[next_event])))
next_event++;
break;
case 'm':
check_mark (0);
args[i] = current_buffer->mark;
varies[i] = 2;
break;
case 'M':
args[i] = Fread_string (callint_message,
Qnil, Qnil, Qnil, Qt);
break;
case 'N':
if (!NILP (prefix_arg))
goto have_prefix_arg;
case 'n':
{
int first = 1;
do
{
Lisp_Object tem;
if (! first)
{
message ("Please enter a number.");
sit_for (make_number (1), 0, 0);
}
first = 0;
tem = Fread_from_minibuffer (callint_message,
Qnil, Qnil, Qnil, Qnil, Qnil,
Qnil);
if (! STRINGP (tem) || SCHARS (tem) == 0)
args[i] = Qnil;
else
args[i] = Fread (tem);
}
while (! NUMBERP (args[i]));
}
visargs[i] = args[i];
break;
case 'P':
args[i] = prefix_arg;
varies[i] = -1;
break;
case 'p':
have_prefix_arg:
args[i] = Fprefix_numeric_value (prefix_arg);
varies[i] = -1;
break;
case 'r':
check_mark (1);
set_marker_both (point_marker, Qnil, PT, PT_BYTE);
foo = marker_position (current_buffer->mark);
args[i] = PT < foo ? point_marker : current_buffer->mark;
varies[i] = 3;
args[++i] = PT > foo ? point_marker : current_buffer->mark;
varies[i] = 4;
break;
case 's':
args[i] = Fread_string (callint_message,
Qnil, Qnil, Qnil, Qnil);
break;
case 'S':
visargs[i] = Fread_string (callint_message,
Qnil, Qnil, Qnil, Qnil);
teml = visargs[i];
args[i] = Fintern (teml, Qnil);
break;
case 'v':
args[i] = Fread_variable (callint_message, Qnil);
visargs[i] = last_minibuf_string;
break;
case 'x':
args[i] = Fread_minibuffer (callint_message, Qnil);
visargs[i] = last_minibuf_string;
break;
case 'X':
args[i] = Feval_minibuffer (callint_message, Qnil);
visargs[i] = last_minibuf_string;
break;
case 'Z':
if (NILP (prefix_arg))
{
args[i] = Qnil;
varies[i] = -1;
}
else
{
args[i]
= Fread_non_nil_coding_system (callint_message);
visargs[i] = last_minibuf_string;
}
break;
case 'z':
args[i] = Fread_coding_system (callint_message, Qnil);
visargs[i] = last_minibuf_string;
break;
case '+':
default:
error ("Invalid control letter `%c' (%03o) in interactive calling string",
*tem, *tem);
}
if (varies[i] == 0)
arg_from_tty = 1;
if (NILP (visargs[i]) && STRINGP (args[i]))
visargs[i] = args[i];
tem = (unsigned char *) index (tem, '\n');
if (tem) tem++;
else tem = (unsigned char *) "";
}
unbind_to (speccount, Qnil);
QUIT;
args[0] = function;
if (arg_from_tty || !NILP (record_flag))
{
visargs[0] = function;
for (i = 1; i < count + 1; i++)
{
if (varies[i] > 0)
visargs[i] = Fcons (intern (callint_argfuns[varies[i]]), Qnil);
else
visargs[i] = quotify_arg (args[i]);
}
Vcommand_history = Fcons (Flist (count + 1, visargs),
Vcommand_history);
if (INTEGERP (Vhistory_length) && XINT (Vhistory_length) > 0)
{
teml = Fnthcdr (Vhistory_length, Vcommand_history);
if (CONSP (teml))
XSETCDR (teml, Qnil);
}
}
for (i = 1; i <= count; i++)
if (varies[i] >= 1 && varies[i] <= 4)
XSETINT (args[i], marker_position (args[i]));
if (record_then_fail)
Fbarf_if_buffer_read_only ();
Vthis_command = save_this_command;
Vthis_original_command = save_this_original_command;
real_this_command= save_real_this_command;
current_kboard->Vlast_command = save_last_command;
single_kboard_state ();
{
Lisp_Object val;
specbind (Qcommand_debug_status, Qnil);
val = Ffuncall (count + 1, args);
UNGCPRO;
return unbind_to (speccount, val);
}
}
DEFUN ("prefix-numeric-value", Fprefix_numeric_value, Sprefix_numeric_value,
1, 1, 0,
doc: )
(raw)
Lisp_Object raw;
{
Lisp_Object val;
if (NILP (raw))
XSETFASTINT (val, 1);
else if (EQ (raw, Qminus))
XSETINT (val, -1);
else if (CONSP (raw) && INTEGERP (XCAR (raw)))
XSETINT (val, XINT (XCAR (raw)));
else if (INTEGERP (raw))
val = raw;
else
XSETFASTINT (val, 1);
return val;
}
void
syms_of_callint ()
{
point_marker = Fmake_marker ();
staticpro (&point_marker);
callint_message = Qnil;
staticpro (&callint_message);
preserved_fns = Fcons (intern ("region-beginning"),
Fcons (intern ("region-end"),
Fcons (intern ("point"),
Fcons (intern ("mark"), Qnil))));
staticpro (&preserved_fns);
Qlist = intern ("list");
staticpro (&Qlist);
Qlet = intern ("let");
staticpro (&Qlet);
Qif = intern ("if");
staticpro (&Qif);
Qwhen = intern ("when");
staticpro (&Qwhen);
Qletx = intern ("let*");
staticpro (&Qletx);
Qsave_excursion = intern ("save-excursion");
staticpro (&Qsave_excursion);
Qprogn = intern ("progn");
staticpro (&Qprogn);
Qminus = intern ("-");
staticpro (&Qminus);
Qplus = intern ("+");
staticpro (&Qplus);
Qcall_interactively = intern ("call-interactively");
staticpro (&Qcall_interactively);
Qcommand_debug_status = intern ("command-debug-status");
staticpro (&Qcommand_debug_status);
Qenable_recursive_minibuffers = intern ("enable-recursive-minibuffers");
staticpro (&Qenable_recursive_minibuffers);
Qmouse_leave_buffer_hook = intern ("mouse-leave-buffer-hook");
staticpro (&Qmouse_leave_buffer_hook);
DEFVAR_KBOARD ("prefix-arg", Vprefix_arg,
doc: );
DEFVAR_KBOARD ("last-prefix-arg", Vlast_prefix_arg,
doc: );
DEFVAR_LISP ("current-prefix-arg", &Vcurrent_prefix_arg,
doc: );
Vcurrent_prefix_arg = Qnil;
DEFVAR_LISP ("command-history", &Vcommand_history,
doc: );
Vcommand_history = Qnil;
DEFVAR_LISP ("command-debug-status", &Vcommand_debug_status,
doc: );
Vcommand_debug_status = Qnil;
DEFVAR_LISP ("mark-even-if-inactive", &Vmark_even_if_inactive,
doc: );
Vmark_even_if_inactive = Qnil;
DEFVAR_LISP ("mouse-leave-buffer-hook", &Vmouse_leave_buffer_hook,
doc: );
Vmouse_leave_buffer_hook = Qnil;
defsubr (&Sinteractive);
defsubr (&Scall_interactively);
defsubr (&Sprefix_numeric_value);
}