Commit db9f0278 authored by Jim Blandy's avatar Jim Blandy
Browse files

Initial revision

parent 37b2be94
/* Evaluator for GNU Emacs Lisp interpreter.
Copyright (C) 1985, 1986, 1987 Free Software Foundation, Inc.
This file is part of GNU Emacs.
GNU Emacs is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 1, or (at your option)
any later version.
GNU Emacs is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with GNU Emacs; see the file COPYING. If not, write to
the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
#include "config.h"
#include "lisp.h"
#ifdef HAVE_X_WINDOWS
#include "xterm.h"
#endif
#ifndef standalone
#include "commands.h"
#else
#define INTERACTIVE 1
#endif
#include <setjmp.h>
/* This definition is duplicated in alloc.c and keyboard.c */
/* Putting it in lisp.h makes cc bomb out! */
struct backtrace
{
struct backtrace *next;
Lisp_Object *function;
Lisp_Object *args; /* Points to vector of args. */
int nargs; /* length of vector */
/* if nargs is UNEVALLED, args points to slot holding list of unevalled args */
char evalargs;
/* Nonzero means call value of debugger when done with this operation. */
char debug_on_exit;
};
struct backtrace *backtrace_list;
struct catchtag
{
Lisp_Object tag;
Lisp_Object val;
struct catchtag *next;
struct gcpro *gcpro;
jmp_buf jmp;
struct backtrace *backlist;
struct handler *handlerlist;
int lisp_eval_depth;
int pdlcount;
int poll_suppress_count;
};
struct catchtag *catchlist;
Lisp_Object Qautoload, Qmacro, Qexit, Qinteractive, Qcommandp, Qdefun;
Lisp_Object Vquit_flag, Vinhibit_quit;
Lisp_Object Qmocklisp_arguments, Vmocklisp_arguments, Qmocklisp;
Lisp_Object Qand_rest, Qand_optional;
Lisp_Object Qdebug_on_error;
Lisp_Object Vrun_hooks;
/* Non-nil means record all fset's and provide's, to be undone
if the file being autoloaded is not fully loaded.
They are recorded by being consed onto the front of Vautoload_queue:
(FUN . ODEF) for a defun, (OFEATURES . nil) for a provide. */
Lisp_Object Vautoload_queue;
/* Current number of specbindings allocated in specpdl. */
int specpdl_size;
/* Pointer to beginning of specpdl. */
struct specbinding *specpdl;
/* Pointer to first unused element in specpdl. */
struct specbinding *specpdl_ptr;
/* Maximum size allowed for specpdl allocation */
int max_specpdl_size;
/* Depth in Lisp evaluations and function calls. */
int lisp_eval_depth;
/* Maximum allowed depth in Lisp evaluations and function calls. */
int max_lisp_eval_depth;
/* Nonzero means enter debugger before next function call */
int debug_on_next_call;
/* Nonzero means display a backtrace if an error
is handled by the command loop's error handler. */
int stack_trace_on_error;
/* Nonzero means enter debugger if an error
is handled by the command loop's error handler. */
int debug_on_error;
/* Nonzero means enter debugger if a quit signal
is handled by the command loop's error handler. */
int debug_on_quit;
/* Nonzero means we are trying to enter the debugger.
This is to prevent recursive attempts. */
int entering_debugger;
Lisp_Object Vdebugger;
void specbind (), record_unwind_protect ();
Lisp_Object funcall_lambda ();
extern Lisp_Object ml_apply (); /* Apply a mocklisp function to unevaluated argument list */
init_eval_once ()
{
specpdl_size = 50;
specpdl = (struct specbinding *) malloc (specpdl_size * sizeof (struct specbinding));
max_specpdl_size = 600;
max_lisp_eval_depth = 200;
}
init_eval ()
{
specpdl_ptr = specpdl;
catchlist = 0;
handlerlist = 0;
backtrace_list = 0;
Vquit_flag = Qnil;
debug_on_next_call = 0;
lisp_eval_depth = 0;
entering_debugger = 0;
}
Lisp_Object
call_debugger (arg)
Lisp_Object arg;
{
if (lisp_eval_depth + 20 > max_lisp_eval_depth)
max_lisp_eval_depth = lisp_eval_depth + 20;
if (specpdl_size + 40 > max_specpdl_size)
max_specpdl_size = specpdl_size + 40;
debug_on_next_call = 0;
entering_debugger = 1;
return apply1 (Vdebugger, arg);
}
do_debug_on_call (code)
Lisp_Object code;
{
debug_on_next_call = 0;
backtrace_list->debug_on_exit = 1;
call_debugger (Fcons (code, Qnil));
}
/* NOTE!!! Every function that can call EVAL must protect its args
and temporaries from garbage collection while it needs them.
The definition of `For' shows what you have to do. */
DEFUN ("or", For, Sor, 0, UNEVALLED, 0,
"Eval args until one of them yields non-nil, then return that value.\n\
The remaining args are not evalled at all.\n\
If all args return nil, return nil.")
(args)
Lisp_Object args;
{
register Lisp_Object val;
Lisp_Object args_left;
struct gcpro gcpro1;
if (NULL(args))
return Qnil;
args_left = args;
GCPRO1 (args_left);
do
{
val = Feval (Fcar (args_left));
if (!NULL (val))
break;
args_left = Fcdr (args_left);
}
while (!NULL(args_left));
UNGCPRO;
return val;
}
DEFUN ("and", Fand, Sand, 0, UNEVALLED, 0,
"Eval args until one of them yields nil, then return nil.\n\
The remaining args are not evalled at all.\n\
If no arg yields nil, return the last arg's value.")
(args)
Lisp_Object args;
{
register Lisp_Object val;
Lisp_Object args_left;
struct gcpro gcpro1;
if (NULL(args))
return Qt;
args_left = args;
GCPRO1 (args_left);
do
{
val = Feval (Fcar (args_left));
if (NULL (val))
break;
args_left = Fcdr (args_left);
}
while (!NULL(args_left));
UNGCPRO;
return val;
}
DEFUN ("if", Fif, Sif, 2, UNEVALLED, 0,
"(if COND THEN ELSE...): if COND yields non-nil, do THEN, else do ELSE...\n\
Returns the value of THEN or the value of the last of the ELSE's.\n\
THEN must be one expression, but ELSE... can be zero or more expressions.\n\
If COND yields nil, and there are no ELSE's, the value is nil.")
(args)
Lisp_Object args;
{
register Lisp_Object cond;
struct gcpro gcpro1;
GCPRO1 (args);
cond = Feval (Fcar (args));
UNGCPRO;
if (!NULL (cond))
return Feval (Fcar (Fcdr (args)));
return Fprogn (Fcdr (Fcdr (args)));
}
DEFUN ("cond", Fcond, Scond, 0, UNEVALLED, 0,
"(cond CLAUSES...): try each clause until one succeeds.\n\
Each clause looks like (CONDITION BODY...). CONDITION is evaluated\n\
and, if the value is non-nil, this clause succeeds:\n\
then the expressions in BODY are evaluated and the last one's\n\
value is the value of the cond-form.\n\
If no clause succeeds, cond returns nil.\n\
If a clause has one element, as in (CONDITION),\n\
CONDITION's value if non-nil is returned from the cond-form.")
(args)
Lisp_Object args;
{
register Lisp_Object clause, val;
struct gcpro gcpro1;
val = Qnil;
GCPRO1 (args);
while (!NULL (args))
{
clause = Fcar (args);
val = Feval (Fcar (clause));
if (!NULL (val))
{
if (!EQ (XCONS (clause)->cdr, Qnil))
val = Fprogn (XCONS (clause)->cdr);
break;
}
args = XCONS (args)->cdr;
}
UNGCPRO;
return val;
}
DEFUN ("progn", Fprogn, Sprogn, 0, UNEVALLED, 0,
"(progn BODY...): eval BODY forms sequentially and return value of last one.")
(args)
Lisp_Object args;
{
register Lisp_Object val, tem;
Lisp_Object args_left;
struct gcpro gcpro1;
/* In Mocklisp code, symbols at the front of the progn arglist
are to be bound to zero. */
if (!EQ (Vmocklisp_arguments, Qt))
{
val = make_number (0);
while (!NULL (args) && (tem = Fcar (args), XTYPE (tem) == Lisp_Symbol))
{
QUIT;
specbind (tem, val), args = Fcdr (args);
}
}
if (NULL(args))
return Qnil;
args_left = args;
GCPRO1 (args_left);
do
{
val = Feval (Fcar (args_left));
args_left = Fcdr (args_left);
}
while (!NULL(args_left));
UNGCPRO;
return val;
}
DEFUN ("prog1", Fprog1, Sprog1, 1, UNEVALLED, 0,
"(prog1 FIRST BODY...): eval FIRST and BODY sequentially; value from FIRST.\n\
The value of FIRST is saved during the evaluation of the remaining args,\n\
whose values are discarded.")
(args)
Lisp_Object args;
{
Lisp_Object val;
register Lisp_Object args_left;
struct gcpro gcpro1, gcpro2;
register int argnum = 0;
if (NULL(args))
return Qnil;
args_left = args;
val = Qnil;
GCPRO2 (args, val);
do
{
if (!(argnum++))
val = Feval (Fcar (args_left));
else
Feval (Fcar (args_left));
args_left = Fcdr (args_left);
}
while (!NULL(args_left));
UNGCPRO;
return val;
}
DEFUN ("prog2", Fprog2, Sprog2, 2, UNEVALLED, 0,
"(prog1 X Y BODY...): eval X, Y and BODY sequentially; value from Y.\n\
The value of Y is saved during the evaluation of the remaining args,\n\
whose values are discarded.")
(args)
Lisp_Object args;
{
Lisp_Object val;
register Lisp_Object args_left;
struct gcpro gcpro1, gcpro2;
register int argnum = -1;
val = Qnil;
if (NULL(args))
return Qnil;
args_left = args;
val = Qnil;
GCPRO2 (args, val);
do
{
if (!(argnum++))
val = Feval (Fcar (args_left));
else
Feval (Fcar (args_left));
args_left = Fcdr (args_left);
}
while (!NULL(args_left));
UNGCPRO;
return val;
}
DEFUN ("setq", Fsetq, Ssetq, 0, UNEVALLED, 0,
"(setq SYM VAL SYM VAL ...): set each SYM to the value of its VAL.\n\
The SYMs are not evaluated. Thus (setq x y) sets x to the value of y.\n\
Each SYM is set before the next VAL is computed.")
(args)
Lisp_Object args;
{
register Lisp_Object args_left;
register Lisp_Object val, sym;
struct gcpro gcpro1;
if (NULL(args))
return Qnil;
args_left = args;
GCPRO1 (args);
do
{
val = Feval (Fcar (Fcdr (args_left)));
sym = Fcar (args_left);
Fset (sym, val);
args_left = Fcdr (Fcdr (args_left));
}
while (!NULL(args_left));
UNGCPRO;
return val;
}
DEFUN ("quote", Fquote, Squote, 1, UNEVALLED, 0,
"Return the argument, without evaluating it. `(quote x)' yields `x'.")
(args)
Lisp_Object args;
{
return Fcar (args);
}
DEFUN ("function", Ffunction, Sfunction, 1, UNEVALLED, 0,
"Like `quote', but preferred for objects which are functions.\n\
In byte compilation, `function' causes its argument to be compiled.\n\
`quote' cannot do that.")
(args)
Lisp_Object args;
{
return Fcar (args);
}
DEFUN ("interactive-p", Finteractive_p, Sinteractive_p, 0, 0, 0,
"Return t if function in which this appears was called interactively.\n\
This means that the function was called with call-interactively (which\n\
includes being called as the binding of a key)\n\
and input is currently coming from the keyboard (not in keyboard macro).")
()
{
register struct backtrace *btp;
register Lisp_Object fun;
if (!INTERACTIVE)
return Qnil;
/* Unless the object was compiled, skip the frame of interactive-p itself
(if interpreted) or the frame of byte-code (if called from
compiled function). */
btp = backtrace_list;
if (! XTYPE (*btp->function) == Lisp_Compiled)
btp = btp->next;
for (;
btp && (btp->nargs == UNEVALLED
|| EQ (*btp->function, Qbytecode));
btp = btp->next)
{}
/* btp now points at the frame of the innermost function
that DOES eval its args.
If it is a built-in function (such as load or eval-region)
return nil. */
fun = *btp->function;
while (XTYPE (fun) == Lisp_Symbol)
{
QUIT;
fun = Fsymbol_function (fun);
}
if (XTYPE (fun) == Lisp_Subr)
return Qnil;
/* btp points to the frame of a Lisp function that called interactive-p.
Return t if that function was called interactively. */
if (btp && btp->next && EQ (*btp->next->function, Qcall_interactively))
return Qt;
return Qnil;
}
DEFUN ("defun", Fdefun, Sdefun, 2, UNEVALLED, 0,
"(defun NAME ARGLIST [DOCSTRING] BODY...): define NAME as a function.\n\
The definition is (lambda ARGLIST [DOCSTRING] BODY...).\n\
See also the function `interactive'.")
(args)
Lisp_Object args;
{
register Lisp_Object fn_name;
register Lisp_Object defn;
fn_name = Fcar (args);
defn = Fcons (Qlambda, Fcdr (args));
if (!NULL (Vpurify_flag))
defn = Fpurecopy (defn);
Ffset (fn_name, defn);
return fn_name;
}
DEFUN ("defmacro", Fdefmacro, Sdefmacro, 2, UNEVALLED, 0,
"(defmacro NAME ARGLIST [DOCSTRING] BODY...): define NAME as a macro.\n\
The definition is (macro lambda ARGLIST [DOCSTRING] BODY...).\n\
When the macro is called, as in (NAME ARGS...),\n\
the function (lambda ARGLIST BODY...) is applied to\n\
the list ARGS... as it appears in the expression,\n\
and the result should be a form to be evaluated instead of the original.")
(args)
Lisp_Object args;
{
register Lisp_Object fn_name;
register Lisp_Object defn;
fn_name = Fcar (args);
defn = Fcons (Qmacro, Fcons (Qlambda, Fcdr (args)));
if (!NULL (Vpurify_flag))
defn = Fpurecopy (defn);
Ffset (fn_name, defn);
return fn_name;
}
DEFUN ("defvar", Fdefvar, Sdefvar, 1, UNEVALLED, 0,
"(defvar SYMBOL INITVALUE DOCSTRING): define SYMBOL as a variable.\n\
You are not required to define a variable in order to use it,\n\
but the definition can supply documentation and an initial value\n\
in a way that tags can recognize.\n\n\
INITVALUE is evaluated, and used to set SYMBOL, only if SYMBOL's value is void.\n\
If SYMBOL is buffer-local, its default value is initialized in this way.\n\
INITVALUE and DOCSTRING are optional.\n\
If DOCSTRING starts with *, this variable is identified as a user option.\n\
This means that M-x set-variable and M-x edit-options recognize it.\n\
If INITVALUE is missing, SYMBOL's value is not set.")
(args)
Lisp_Object args;
{
register Lisp_Object sym, tem;
sym = Fcar (args);
tem = Fcdr (args);
if (!NULL (tem))
{
tem = Fdefault_boundp (sym);
if (NULL (tem))
Fset_default (sym, Feval (Fcar (Fcdr (args))));
}
tem = Fcar (Fcdr (Fcdr (args)));
if (!NULL (tem))
{
if (!NULL (Vpurify_flag))
tem = Fpurecopy (tem);
Fput (sym, Qvariable_documentation, tem);
}
return sym;
}
DEFUN ("defconst", Fdefconst, Sdefconst, 2, UNEVALLED, 0,
"(defconst SYMBOL INITVALUE DOCSTRING): define SYMBOL as a constant variable.\n\
The intent is that programs do not change this value, but users may.\n\
Always sets the value of SYMBOL to the result of evalling INITVALUE.\n\
If SYMBOL is buffer-local, its default value is initialized in this way.\n\
DOCSTRING is optional.\n\
If DOCSTRING starts with *, this variable is identified as a user option.\n\
This means that M-x set-variable and M-x edit-options recognize it.\n\n\
Note: do not use `defconst' for user options in libraries that are not\n\
normally loaded, since it is useful for users to be able to specify\n\
their own values for such variables before loading the library.\n\
Since `defconst' unconditionally assigns the variable,\n\
it would override the user's choice.")
(args)
Lisp_Object args;
{
register Lisp_Object sym, tem;
sym = Fcar (args);
Fset_default (sym, Feval (Fcar (Fcdr (args))));
tem = Fcar (Fcdr (Fcdr (args)));
if (!NULL (tem))
{
if (!NULL (Vpurify_flag))
tem = Fpurecopy (tem);
Fput (sym, Qvariable_documentation, tem);
}
return sym;
}
DEFUN ("user-variable-p", Fuser_variable_p, Suser_variable_p, 1, 1, 0,
"Returns t if VARIABLE is intended to be set and modified by users.\n\
\(The alternative is a variable used internally in a Lisp program.)\n\
Determined by whether the first character of the documentation\n\
for the variable is \"*\"")
(variable)
Lisp_Object variable;
{
Lisp_Object documentation;
documentation = Fget (variable, Qvariable_documentation);
if (XTYPE (documentation) == Lisp_Int && XINT (documentation) < 0)
return Qt;
if ((XTYPE (documentation) == Lisp_String) &&
((unsigned char) XSTRING (documentation)->data[0] == '*'))
return Qt;
return Qnil;
}
DEFUN ("let*", FletX, SletX, 1, UNEVALLED, 0,
"(let* VARLIST BODY...): bind variables according to VARLIST then eval BODY.\n\
The value of the last form in BODY is returned.\n\
Each element of VARLIST is a symbol (which is bound to nil)\n\
or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).\n\
Each VALUEFORM can refer to the symbols already bound by this VARLIST.")
(args)
Lisp_Object args;
{
Lisp_Object varlist, val, elt;
int count = specpdl_ptr - specpdl;
struct gcpro gcpro1, gcpro2, gcpro3;
GCPRO3 (args, elt, varlist);
varlist = Fcar (args);
while (!NULL (varlist))
{
QUIT;
elt = Fcar (varlist);
if (XTYPE (elt) == Lisp_Symbol)
specbind (elt, Qnil);
else
{
val = Feval (Fcar (Fcdr (elt)));
specbind (Fcar (elt), val);
}
varlist = Fcdr (varlist);
}
UNGCPRO;
val = Fprogn (Fcdr (args));
return unbind_to (count, val);
}
DEFUN ("let", Flet, Slet, 1, UNEVALLED, 0,
"(let VARLIST BODY...): bind variables according to VARLIST then eval BODY.\n\
The value of the last form in BODY is returned.\n\
Each element of VARLIST is a symbol (which is bound to nil)\n\
or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).\n\