aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorJim Blandy1991-05-16 18:19:08 +0000
committerJim Blandy1991-05-16 18:19:08 +0000
commitdb9f027896e815f919b717e699cd3a6c3daef956 (patch)
tree4a69d993cf63a71244b41d03f0f376a63ad5ad27
parent37b2be94f1200a35c9bc2aa675480f1e5b5058ce (diff)
downloademacs-db9f027896e815f919b717e699cd3a6c3daef956.tar.gz
emacs-db9f027896e815f919b717e699cd3a6c3daef956.zip
Initial revision
-rw-r--r--src/eval.c2332
1 files changed, 2332 insertions, 0 deletions
diff --git a/src/eval.c b/src/eval.c
new file mode 100644
index 00000000000..f2cb96e911b
--- /dev/null
+++ b/src/eval.c
@@ -0,0 +1,2332 @@
1/* Evaluator for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 1986, 1987 Free Software Foundation, Inc.
3
4This file is part of GNU Emacs.
5
6GNU Emacs is free software; you can redistribute it and/or modify
7it under the terms of the GNU General Public License as published by
8the Free Software Foundation; either version 1, or (at your option)
9any later version.
10
11GNU Emacs is distributed in the hope that it will be useful,
12but WITHOUT ANY WARRANTY; without even the implied warranty of
13MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14GNU General Public License for more details.
15
16You should have received a copy of the GNU General Public License
17along with GNU Emacs; see the file COPYING. If not, write to
18the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
19
20
21#include "config.h"
22#include "lisp.h"
23#ifdef HAVE_X_WINDOWS
24#include "xterm.h"
25#endif
26
27#ifndef standalone
28#include "commands.h"
29#else
30#define INTERACTIVE 1
31#endif
32
33#include <setjmp.h>
34
35/* This definition is duplicated in alloc.c and keyboard.c */
36/* Putting it in lisp.h makes cc bomb out! */
37
38struct backtrace
39 {
40 struct backtrace *next;
41 Lisp_Object *function;
42 Lisp_Object *args; /* Points to vector of args. */
43 int nargs; /* length of vector */
44 /* if nargs is UNEVALLED, args points to slot holding list of unevalled args */
45 char evalargs;
46 /* Nonzero means call value of debugger when done with this operation. */
47 char debug_on_exit;
48 };
49
50struct backtrace *backtrace_list;
51
52struct catchtag
53 {
54 Lisp_Object tag;
55 Lisp_Object val;
56 struct catchtag *next;
57 struct gcpro *gcpro;
58 jmp_buf jmp;
59 struct backtrace *backlist;
60 struct handler *handlerlist;
61 int lisp_eval_depth;
62 int pdlcount;
63 int poll_suppress_count;
64 };
65
66struct catchtag *catchlist;
67
68Lisp_Object Qautoload, Qmacro, Qexit, Qinteractive, Qcommandp, Qdefun;
69Lisp_Object Vquit_flag, Vinhibit_quit;
70Lisp_Object Qmocklisp_arguments, Vmocklisp_arguments, Qmocklisp;
71Lisp_Object Qand_rest, Qand_optional;
72Lisp_Object Qdebug_on_error;
73
74Lisp_Object Vrun_hooks;
75
76/* Non-nil means record all fset's and provide's, to be undone
77 if the file being autoloaded is not fully loaded.
78 They are recorded by being consed onto the front of Vautoload_queue:
79 (FUN . ODEF) for a defun, (OFEATURES . nil) for a provide. */
80
81Lisp_Object Vautoload_queue;
82
83/* Current number of specbindings allocated in specpdl. */
84int specpdl_size;
85
86/* Pointer to beginning of specpdl. */
87struct specbinding *specpdl;
88
89/* Pointer to first unused element in specpdl. */
90struct specbinding *specpdl_ptr;
91
92/* Maximum size allowed for specpdl allocation */
93int max_specpdl_size;
94
95/* Depth in Lisp evaluations and function calls. */
96int lisp_eval_depth;
97
98/* Maximum allowed depth in Lisp evaluations and function calls. */
99int max_lisp_eval_depth;
100
101/* Nonzero means enter debugger before next function call */
102int debug_on_next_call;
103
104/* Nonzero means display a backtrace if an error
105 is handled by the command loop's error handler. */
106int stack_trace_on_error;
107
108/* Nonzero means enter debugger if an error
109 is handled by the command loop's error handler. */
110int debug_on_error;
111
112/* Nonzero means enter debugger if a quit signal
113 is handled by the command loop's error handler. */
114int debug_on_quit;
115
116/* Nonzero means we are trying to enter the debugger.
117 This is to prevent recursive attempts. */
118int entering_debugger;
119
120Lisp_Object Vdebugger;
121
122void specbind (), record_unwind_protect ();
123
124Lisp_Object funcall_lambda ();
125extern Lisp_Object ml_apply (); /* Apply a mocklisp function to unevaluated argument list */
126
127init_eval_once ()
128{
129 specpdl_size = 50;
130 specpdl = (struct specbinding *) malloc (specpdl_size * sizeof (struct specbinding));
131 max_specpdl_size = 600;
132 max_lisp_eval_depth = 200;
133}
134
135init_eval ()
136{
137 specpdl_ptr = specpdl;
138 catchlist = 0;
139 handlerlist = 0;
140 backtrace_list = 0;
141 Vquit_flag = Qnil;
142 debug_on_next_call = 0;
143 lisp_eval_depth = 0;
144 entering_debugger = 0;
145}
146
147Lisp_Object
148call_debugger (arg)
149 Lisp_Object arg;
150{
151 if (lisp_eval_depth + 20 > max_lisp_eval_depth)
152 max_lisp_eval_depth = lisp_eval_depth + 20;
153 if (specpdl_size + 40 > max_specpdl_size)
154 max_specpdl_size = specpdl_size + 40;
155 debug_on_next_call = 0;
156 entering_debugger = 1;
157 return apply1 (Vdebugger, arg);
158}
159
160do_debug_on_call (code)
161 Lisp_Object code;
162{
163 debug_on_next_call = 0;
164 backtrace_list->debug_on_exit = 1;
165 call_debugger (Fcons (code, Qnil));
166}
167
168/* NOTE!!! Every function that can call EVAL must protect its args
169 and temporaries from garbage collection while it needs them.
170 The definition of `For' shows what you have to do. */
171
172DEFUN ("or", For, Sor, 0, UNEVALLED, 0,
173 "Eval args until one of them yields non-nil, then return that value.\n\
174The remaining args are not evalled at all.\n\
175If all args return nil, return nil.")
176 (args)
177 Lisp_Object args;
178{
179 register Lisp_Object val;
180 Lisp_Object args_left;
181 struct gcpro gcpro1;
182
183 if (NULL(args))
184 return Qnil;
185
186 args_left = args;
187 GCPRO1 (args_left);
188
189 do
190 {
191 val = Feval (Fcar (args_left));
192 if (!NULL (val))
193 break;
194 args_left = Fcdr (args_left);
195 }
196 while (!NULL(args_left));
197
198 UNGCPRO;
199 return val;
200}
201
202DEFUN ("and", Fand, Sand, 0, UNEVALLED, 0,
203 "Eval args until one of them yields nil, then return nil.\n\
204The remaining args are not evalled at all.\n\
205If no arg yields nil, return the last arg's value.")
206 (args)
207 Lisp_Object args;
208{
209 register Lisp_Object val;
210 Lisp_Object args_left;
211 struct gcpro gcpro1;
212
213 if (NULL(args))
214 return Qt;
215
216 args_left = args;
217 GCPRO1 (args_left);
218
219 do
220 {
221 val = Feval (Fcar (args_left));
222 if (NULL (val))
223 break;
224 args_left = Fcdr (args_left);
225 }
226 while (!NULL(args_left));
227
228 UNGCPRO;
229 return val;
230}
231
232DEFUN ("if", Fif, Sif, 2, UNEVALLED, 0,
233 "(if COND THEN ELSE...): if COND yields non-nil, do THEN, else do ELSE...\n\
234Returns the value of THEN or the value of the last of the ELSE's.\n\
235THEN must be one expression, but ELSE... can be zero or more expressions.\n\
236If COND yields nil, and there are no ELSE's, the value is nil.")
237 (args)
238 Lisp_Object args;
239{
240 register Lisp_Object cond;
241 struct gcpro gcpro1;
242
243 GCPRO1 (args);
244 cond = Feval (Fcar (args));
245 UNGCPRO;
246
247 if (!NULL (cond))
248 return Feval (Fcar (Fcdr (args)));
249 return Fprogn (Fcdr (Fcdr (args)));
250}
251
252DEFUN ("cond", Fcond, Scond, 0, UNEVALLED, 0,
253 "(cond CLAUSES...): try each clause until one succeeds.\n\
254Each clause looks like (CONDITION BODY...). CONDITION is evaluated\n\
255and, if the value is non-nil, this clause succeeds:\n\
256then the expressions in BODY are evaluated and the last one's\n\
257value is the value of the cond-form.\n\
258If no clause succeeds, cond returns nil.\n\
259If a clause has one element, as in (CONDITION),\n\
260CONDITION's value if non-nil is returned from the cond-form.")
261 (args)
262 Lisp_Object args;
263{
264 register Lisp_Object clause, val;
265 struct gcpro gcpro1;
266
267 val = Qnil;
268 GCPRO1 (args);
269 while (!NULL (args))
270 {
271 clause = Fcar (args);
272 val = Feval (Fcar (clause));
273 if (!NULL (val))
274 {
275 if (!EQ (XCONS (clause)->cdr, Qnil))
276 val = Fprogn (XCONS (clause)->cdr);
277 break;
278 }
279 args = XCONS (args)->cdr;
280 }
281 UNGCPRO;
282
283 return val;
284}
285
286DEFUN ("progn", Fprogn, Sprogn, 0, UNEVALLED, 0,
287 "(progn BODY...): eval BODY forms sequentially and return value of last one.")
288 (args)
289 Lisp_Object args;
290{
291 register Lisp_Object val, tem;
292 Lisp_Object args_left;
293 struct gcpro gcpro1;
294
295 /* In Mocklisp code, symbols at the front of the progn arglist
296 are to be bound to zero. */
297 if (!EQ (Vmocklisp_arguments, Qt))
298 {
299 val = make_number (0);
300 while (!NULL (args) && (tem = Fcar (args), XTYPE (tem) == Lisp_Symbol))
301 {
302 QUIT;
303 specbind (tem, val), args = Fcdr (args);
304 }
305 }
306
307 if (NULL(args))
308 return Qnil;
309
310 args_left = args;
311 GCPRO1 (args_left);
312
313 do
314 {
315 val = Feval (Fcar (args_left));
316 args_left = Fcdr (args_left);
317 }
318 while (!NULL(args_left));
319
320 UNGCPRO;
321 return val;
322}
323
324DEFUN ("prog1", Fprog1, Sprog1, 1, UNEVALLED, 0,
325 "(prog1 FIRST BODY...): eval FIRST and BODY sequentially; value from FIRST.\n\
326The value of FIRST is saved during the evaluation of the remaining args,\n\
327whose values are discarded.")
328 (args)
329 Lisp_Object args;
330{
331 Lisp_Object val;
332 register Lisp_Object args_left;
333 struct gcpro gcpro1, gcpro2;
334 register int argnum = 0;
335
336 if (NULL(args))
337 return Qnil;
338
339 args_left = args;
340 val = Qnil;
341 GCPRO2 (args, val);
342
343 do
344 {
345 if (!(argnum++))
346 val = Feval (Fcar (args_left));
347 else
348 Feval (Fcar (args_left));
349 args_left = Fcdr (args_left);
350 }
351 while (!NULL(args_left));
352
353 UNGCPRO;
354 return val;
355}
356
357DEFUN ("prog2", Fprog2, Sprog2, 2, UNEVALLED, 0,
358 "(prog1 X Y BODY...): eval X, Y and BODY sequentially; value from Y.\n\
359The value of Y is saved during the evaluation of the remaining args,\n\
360whose values are discarded.")
361 (args)
362 Lisp_Object args;
363{
364 Lisp_Object val;
365 register Lisp_Object args_left;
366 struct gcpro gcpro1, gcpro2;
367 register int argnum = -1;
368
369 val = Qnil;
370
371 if (NULL(args))
372 return Qnil;
373
374 args_left = args;
375 val = Qnil;
376 GCPRO2 (args, val);
377
378 do
379 {
380 if (!(argnum++))
381 val = Feval (Fcar (args_left));
382 else
383 Feval (Fcar (args_left));
384 args_left = Fcdr (args_left);
385 }
386 while (!NULL(args_left));
387
388 UNGCPRO;
389 return val;
390}
391
392DEFUN ("setq", Fsetq, Ssetq, 0, UNEVALLED, 0,
393 "(setq SYM VAL SYM VAL ...): set each SYM to the value of its VAL.\n\
394The SYMs are not evaluated. Thus (setq x y) sets x to the value of y.\n\
395Each SYM is set before the next VAL is computed.")
396 (args)
397 Lisp_Object args;
398{
399 register Lisp_Object args_left;
400 register Lisp_Object val, sym;
401 struct gcpro gcpro1;
402
403 if (NULL(args))
404 return Qnil;
405
406 args_left = args;
407 GCPRO1 (args);
408
409 do
410 {
411 val = Feval (Fcar (Fcdr (args_left)));
412 sym = Fcar (args_left);
413 Fset (sym, val);
414 args_left = Fcdr (Fcdr (args_left));
415 }
416 while (!NULL(args_left));
417
418 UNGCPRO;
419 return val;
420}
421
422DEFUN ("quote", Fquote, Squote, 1, UNEVALLED, 0,
423 "Return the argument, without evaluating it. `(quote x)' yields `x'.")
424 (args)
425 Lisp_Object args;
426{
427 return Fcar (args);
428}
429
430DEFUN ("function", Ffunction, Sfunction, 1, UNEVALLED, 0,
431 "Like `quote', but preferred for objects which are functions.\n\
432In byte compilation, `function' causes its argument to be compiled.\n\
433`quote' cannot do that.")
434 (args)
435 Lisp_Object args;
436{
437 return Fcar (args);
438}
439
440DEFUN ("interactive-p", Finteractive_p, Sinteractive_p, 0, 0, 0,
441 "Return t if function in which this appears was called interactively.\n\
442This means that the function was called with call-interactively (which\n\
443includes being called as the binding of a key)\n\
444and input is currently coming from the keyboard (not in keyboard macro).")
445 ()
446{
447 register struct backtrace *btp;
448 register Lisp_Object fun;
449
450 if (!INTERACTIVE)
451 return Qnil;
452
453 /* Unless the object was compiled, skip the frame of interactive-p itself
454 (if interpreted) or the frame of byte-code (if called from
455 compiled function). */
456 btp = backtrace_list;
457 if (! XTYPE (*btp->function) == Lisp_Compiled)
458 btp = btp->next;
459 for (;
460 btp && (btp->nargs == UNEVALLED
461 || EQ (*btp->function, Qbytecode));
462 btp = btp->next)
463 {}
464 /* btp now points at the frame of the innermost function
465 that DOES eval its args.
466 If it is a built-in function (such as load or eval-region)
467 return nil. */
468 fun = *btp->function;
469 while (XTYPE (fun) == Lisp_Symbol)
470 {
471 QUIT;
472 fun = Fsymbol_function (fun);
473 }
474 if (XTYPE (fun) == Lisp_Subr)
475 return Qnil;
476 /* btp points to the frame of a Lisp function that called interactive-p.
477 Return t if that function was called interactively. */
478 if (btp && btp->next && EQ (*btp->next->function, Qcall_interactively))
479 return Qt;
480 return Qnil;
481}
482
483DEFUN ("defun", Fdefun, Sdefun, 2, UNEVALLED, 0,
484 "(defun NAME ARGLIST [DOCSTRING] BODY...): define NAME as a function.\n\
485The definition is (lambda ARGLIST [DOCSTRING] BODY...).\n\
486See also the function `interactive'.")
487 (args)
488 Lisp_Object args;
489{
490 register Lisp_Object fn_name;
491 register Lisp_Object defn;
492
493 fn_name = Fcar (args);
494 defn = Fcons (Qlambda, Fcdr (args));
495 if (!NULL (Vpurify_flag))
496 defn = Fpurecopy (defn);
497 Ffset (fn_name, defn);
498 return fn_name;
499}
500
501DEFUN ("defmacro", Fdefmacro, Sdefmacro, 2, UNEVALLED, 0,
502 "(defmacro NAME ARGLIST [DOCSTRING] BODY...): define NAME as a macro.\n\
503The definition is (macro lambda ARGLIST [DOCSTRING] BODY...).\n\
504When the macro is called, as in (NAME ARGS...),\n\
505the function (lambda ARGLIST BODY...) is applied to\n\
506the list ARGS... as it appears in the expression,\n\
507and the result should be a form to be evaluated instead of the original.")
508 (args)
509 Lisp_Object args;
510{
511 register Lisp_Object fn_name;
512 register Lisp_Object defn;
513
514 fn_name = Fcar (args);
515 defn = Fcons (Qmacro, Fcons (Qlambda, Fcdr (args)));
516 if (!NULL (Vpurify_flag))
517 defn = Fpurecopy (defn);
518 Ffset (fn_name, defn);
519 return fn_name;
520}
521
522DEFUN ("defvar", Fdefvar, Sdefvar, 1, UNEVALLED, 0,
523 "(defvar SYMBOL INITVALUE DOCSTRING): define SYMBOL as a variable.\n\
524You are not required to define a variable in order to use it,\n\
525but the definition can supply documentation and an initial value\n\
526in a way that tags can recognize.\n\n\
527INITVALUE is evaluated, and used to set SYMBOL, only if SYMBOL's value is void.\n\
528If SYMBOL is buffer-local, its default value is initialized in this way.\n\
529INITVALUE and DOCSTRING are optional.\n\
530If DOCSTRING starts with *, this variable is identified as a user option.\n\
531 This means that M-x set-variable and M-x edit-options recognize it.\n\
532If INITVALUE is missing, SYMBOL's value is not set.")
533 (args)
534 Lisp_Object args;
535{
536 register Lisp_Object sym, tem;
537
538 sym = Fcar (args);
539 tem = Fcdr (args);
540 if (!NULL (tem))
541 {
542 tem = Fdefault_boundp (sym);
543 if (NULL (tem))
544 Fset_default (sym, Feval (Fcar (Fcdr (args))));
545 }
546 tem = Fcar (Fcdr (Fcdr (args)));
547 if (!NULL (tem))
548 {
549 if (!NULL (Vpurify_flag))
550 tem = Fpurecopy (tem);
551 Fput (sym, Qvariable_documentation, tem);
552 }
553 return sym;
554}
555
556DEFUN ("defconst", Fdefconst, Sdefconst, 2, UNEVALLED, 0,
557 "(defconst SYMBOL INITVALUE DOCSTRING): define SYMBOL as a constant variable.\n\
558The intent is that programs do not change this value, but users may.\n\
559Always sets the value of SYMBOL to the result of evalling INITVALUE.\n\
560If SYMBOL is buffer-local, its default value is initialized in this way.\n\
561DOCSTRING is optional.\n\
562If DOCSTRING starts with *, this variable is identified as a user option.\n\
563 This means that M-x set-variable and M-x edit-options recognize it.\n\n\
564Note: do not use `defconst' for user options in libraries that are not\n\
565normally loaded, since it is useful for users to be able to specify\n\
566their own values for such variables before loading the library.\n\
567Since `defconst' unconditionally assigns the variable,\n\
568it would override the user's choice.")
569 (args)
570 Lisp_Object args;
571{
572 register Lisp_Object sym, tem;
573
574 sym = Fcar (args);
575 Fset_default (sym, Feval (Fcar (Fcdr (args))));
576 tem = Fcar (Fcdr (Fcdr (args)));
577 if (!NULL (tem))
578 {
579 if (!NULL (Vpurify_flag))
580 tem = Fpurecopy (tem);
581 Fput (sym, Qvariable_documentation, tem);
582 }
583 return sym;
584}
585
586DEFUN ("user-variable-p", Fuser_variable_p, Suser_variable_p, 1, 1, 0,
587 "Returns t if VARIABLE is intended to be set and modified by users.\n\
588\(The alternative is a variable used internally in a Lisp program.)\n\
589Determined by whether the first character of the documentation\n\
590for the variable is \"*\"")
591 (variable)
592 Lisp_Object variable;
593{
594 Lisp_Object documentation;
595
596 documentation = Fget (variable, Qvariable_documentation);
597 if (XTYPE (documentation) == Lisp_Int && XINT (documentation) < 0)
598 return Qt;
599 if ((XTYPE (documentation) == Lisp_String) &&
600 ((unsigned char) XSTRING (documentation)->data[0] == '*'))
601 return Qt;
602 return Qnil;
603}
604
605DEFUN ("let*", FletX, SletX, 1, UNEVALLED, 0,
606 "(let* VARLIST BODY...): bind variables according to VARLIST then eval BODY.\n\
607The value of the last form in BODY is returned.\n\
608Each element of VARLIST is a symbol (which is bound to nil)\n\
609or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).\n\
610Each VALUEFORM can refer to the symbols already bound by this VARLIST.")
611 (args)
612 Lisp_Object args;
613{
614 Lisp_Object varlist, val, elt;
615 int count = specpdl_ptr - specpdl;
616 struct gcpro gcpro1, gcpro2, gcpro3;
617
618 GCPRO3 (args, elt, varlist);
619
620 varlist = Fcar (args);
621 while (!NULL (varlist))
622 {
623 QUIT;
624 elt = Fcar (varlist);
625 if (XTYPE (elt) == Lisp_Symbol)
626 specbind (elt, Qnil);
627 else
628 {
629 val = Feval (Fcar (Fcdr (elt)));
630 specbind (Fcar (elt), val);
631 }
632 varlist = Fcdr (varlist);
633 }
634 UNGCPRO;
635 val = Fprogn (Fcdr (args));
636 return unbind_to (count, val);
637}
638
639DEFUN ("let", Flet, Slet, 1, UNEVALLED, 0,
640 "(let VARLIST BODY...): bind variables according to VARLIST then eval BODY.\n\
641The value of the last form in BODY is returned.\n\
642Each element of VARLIST is a symbol (which is bound to nil)\n\
643or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).\n\
644All the VALUEFORMs are evalled before any symbols are bound.")
645 (args)
646 Lisp_Object args;
647{
648 Lisp_Object *temps, tem;
649 register Lisp_Object elt, varlist;
650 int count = specpdl_ptr - specpdl;
651 register int argnum;
652 struct gcpro gcpro1, gcpro2;
653
654 varlist = Fcar (args);
655
656 /* Make space to hold the values to give the bound variables */
657 elt = Flength (varlist);
658 temps = (Lisp_Object *) alloca (XFASTINT (elt) * sizeof (Lisp_Object));
659
660 /* Compute the values and store them in `temps' */
661
662 GCPRO2 (args, *temps);
663 gcpro2.nvars = 0;
664
665 for (argnum = 0; !NULL (varlist); varlist = Fcdr (varlist))
666 {
667 QUIT;
668 elt = Fcar (varlist);
669 if (XTYPE (elt) == Lisp_Symbol)
670 temps [argnum++] = Qnil;
671 else
672 temps [argnum++] = Feval (Fcar (Fcdr (elt)));
673 gcpro2.nvars = argnum;
674 }
675 UNGCPRO;
676
677 varlist = Fcar (args);
678 for (argnum = 0; !NULL (varlist); varlist = Fcdr (varlist))
679 {
680 elt = Fcar (varlist);
681 tem = temps[argnum++];
682 if (XTYPE (elt) == Lisp_Symbol)
683 specbind (elt, tem);
684 else
685 specbind (Fcar (elt), tem);
686 }
687
688 elt = Fprogn (Fcdr (args));
689 return unbind_to (count, elt);
690}
691
692DEFUN ("while", Fwhile, Swhile, 1, UNEVALLED, 0,
693 "(while TEST BODY...): if TEST yields non-nil, eval BODY... and repeat.\n\
694The order of execution is thus TEST, BODY, TEST, BODY and so on\n\
695until TEST returns nil.")
696 (args)
697 Lisp_Object args;
698{
699 Lisp_Object test, body, tem;
700 struct gcpro gcpro1, gcpro2;
701
702 GCPRO2 (test, body);
703
704 test = Fcar (args);
705 body = Fcdr (args);
706 while (tem = Feval (test), !NULL (tem))
707 {
708 QUIT;
709 Fprogn (body);
710 }
711
712 UNGCPRO;
713 return Qnil;
714}
715
716DEFUN ("macroexpand", Fmacroexpand, Smacroexpand, 1, 2, 0,
717 "Return result of expanding macros at top level of FORM.\n\
718If FORM is not a macro call, it is returned unchanged.\n\
719Otherwise, the macro is expanded and the expansion is considered\n\
720in place of FORM. When a non-macro-call results, it is returned.\n\n\
721The second optional arg ENVIRONMENT species an environment of macro\n\
722definitions to shadow the loaded ones for use in file byte-compilation.")
723 (form, env)
724 register Lisp_Object form;
725 Lisp_Object env;
726{
727 register Lisp_Object expander, sym, def, tem;
728
729 while (1)
730 {
731 /* Come back here each time we expand a macro call,
732 in case it expands into another macro call. */
733 if (XTYPE (form) != Lisp_Cons)
734 break;
735 sym = XCONS (form)->car;
736 /* Detect ((macro lambda ...) ...) */
737 if (XTYPE (sym) == Lisp_Cons
738 && EQ (XCONS (sym)->car, Qmacro))
739 {
740 expander = XCONS (sym)->cdr;
741 goto explicit;
742 }
743 if (XTYPE (sym) != Lisp_Symbol)
744 break;
745 /* Trace symbols aliases to other symbols
746 until we get a symbol that is not an alias. */
747 while (1)
748 {
749 QUIT;
750 tem = Fassq (sym, env);
751 if (NULL (tem))
752 {
753 def = XSYMBOL (sym)->function;
754 if (XTYPE (def) == Lisp_Symbol && !EQ (def, Qunbound))
755 sym = def;
756 else
757 break;
758 }
759 else
760 {
761#if 0 /* This is turned off because it caused an element (foo . bar)
762 to have the effect of defining foo as an alias for the macro bar.
763 That is inconsistent; bar should be a function to expand foo. */
764 if (XTYPE (tem) == Lisp_Cons
765 && XTYPE (XCONS (tem)->cdr) == Lisp_Symbol)
766 sym = XCONS (tem)->cdr;
767 else
768#endif
769 break;
770 }
771 }
772 /* Right now TEM is the result from SYM in ENV,
773 and if TEM is nil then DEF is SYM's function definition. */
774 if (NULL (tem))
775 {
776 /* SYM is not mentioned in ENV.
777 Look at its function definition. */
778 if (EQ (def, Qunbound)
779 || XTYPE (def) != Lisp_Cons)
780 /* Not defined or definition not suitable */
781 break;
782 if (EQ (XCONS (def)->car, Qautoload))
783 {
784 /* Autoloading function: will it be a macro when loaded? */
785 tem = Fcar (Fnthcdr (make_number (4), def));
786 if (NULL (tem))
787 break;
788 /* Yes, load it and try again. */
789 do_autoload (def, sym);
790 continue;
791 }
792 else if (!EQ (XCONS (def)->car, Qmacro))
793 break;
794 else expander = XCONS (def)->cdr;
795 }
796 else
797 {
798 expander = XCONS (tem)->cdr;
799 if (NULL (expander))
800 break;
801 }
802 explicit:
803 form = apply1 (expander, XCONS (form)->cdr);
804 }
805 return form;
806}
807
808DEFUN ("catch", Fcatch, Scatch, 1, UNEVALLED, 0,
809 "(catch TAG BODY...): eval BODY allowing nonlocal exits using `throw'.\n\
810TAG is evalled to get the tag to use. Then the BODY is executed.\n\
811Within BODY, (throw TAG) with same tag exits BODY and exits this `catch'.\n\
812If no throw happens, `catch' returns the value of the last BODY form.\n\
813If a throw happens, it specifies the value to return from `catch'.")
814 (args)
815 Lisp_Object args;
816{
817 register Lisp_Object tag;
818 struct gcpro gcpro1;
819
820 GCPRO1 (args);
821 tag = Feval (Fcar (args));
822 UNGCPRO;
823 return internal_catch (tag, Fprogn, Fcdr (args));
824}
825
826/* Set up a catch, then call C function FUNC on argument ARG.
827 FUNC should return a Lisp_Object.
828 This is how catches are done from within C code. */
829
830Lisp_Object
831internal_catch (tag, func, arg)
832 Lisp_Object tag;
833 Lisp_Object (*func) ();
834 Lisp_Object arg;
835{
836 /* This structure is made part of the chain `catchlist'. */
837 struct catchtag c;
838
839 /* Fill in the components of c, and put it on the list. */
840 c.next = catchlist;
841 c.tag = tag;
842 c.val = Qnil;
843 c.backlist = backtrace_list;
844 c.handlerlist = handlerlist;
845 c.lisp_eval_depth = lisp_eval_depth;
846 c.pdlcount = specpdl_ptr - specpdl;
847 c.poll_suppress_count = poll_suppress_count;
848 c.gcpro = gcprolist;
849 catchlist = &c;
850
851 /* Call FUNC. */
852 if (! _setjmp (c.jmp))
853 c.val = (*func) (arg);
854
855 /* Throw works by a longjmp that comes right here. */
856 catchlist = c.next;
857 return c.val;
858}
859
860/* Discard from the catchlist all catch tags back through CATCH.
861 Before each catch is discarded, unbind all special bindings
862 made within that catch. Also, when discarding a catch that
863 corresponds to a condition handler, discard that handler.
864
865 At the end, restore some static info saved in CATCH.
866
867 This is used for correct unwinding in Fthrow and Fsignal,
868 before doing the longjmp that actually destroys the stack frames
869 in which these handlers and catches reside. */
870
871static void
872unbind_catch (catch)
873 struct catchtag *catch;
874{
875 register int last_time;
876
877 do
878 {
879 last_time = catchlist == catch;
880 unbind_to (catchlist->pdlcount, Qnil);
881 handlerlist = catchlist->handlerlist;
882 catchlist = catchlist->next;
883 }
884 while (! last_time);
885
886 gcprolist = catch->gcpro;
887 backtrace_list = catch->backlist;
888 lisp_eval_depth = catch->lisp_eval_depth;
889}
890
891DEFUN ("throw", Fthrow, Sthrow, 2, 2, 0,
892 "(throw TAG VALUE): throw to the catch for TAG and return VALUE from it.\n\
893Both TAG and VALUE are evalled.")
894 (tag, val)
895 register Lisp_Object tag, val;
896{
897 register struct catchtag *c;
898
899 while (1)
900 {
901 if (!NULL (tag))
902 for (c = catchlist; c; c = c->next)
903 {
904 if (EQ (c->tag, tag))
905 {
906 /* Restore the polling-suppression count. */
907 if (c->poll_suppress_count > poll_suppress_count)
908 abort ();
909 while (c->poll_suppress_count < poll_suppress_count)
910 start_polling ();
911 c->val = val;
912 unbind_catch (c);
913 _longjmp (c->jmp, 1);
914 }
915 }
916 tag = Fsignal (Qno_catch, Fcons (tag, Fcons (val, Qnil)));
917 }
918}
919
920
921DEFUN ("unwind-protect", Funwind_protect, Sunwind_protect, 1, UNEVALLED, 0,
922 "Do BODYFORM, protecting with UNWINDFORMS.\n\
923Usage looks like (unwind-protect BODYFORM UNWINDFORMS...).\n\
924If BODYFORM completes normally, its value is returned\n\
925after executing the UNWINDFORMS.\n\
926If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.")
927 (args)
928 Lisp_Object args;
929{
930 Lisp_Object val;
931 int count = specpdl_ptr - specpdl;
932
933 record_unwind_protect (0, Fcdr (args));
934 val = Feval (Fcar (args));
935 return unbind_to (count, val);
936}
937
938/* Chain of condition handlers currently in effect.
939 The elements of this chain are contained in the stack frames
940 of Fcondition_case and internal_condition_case.
941 When an error is signaled (by calling Fsignal, below),
942 this chain is searched for an element that applies. */
943
944struct handler *handlerlist;
945
946DEFUN ("condition-case", Fcondition_case, Scondition_case, 2, UNEVALLED, 0,
947 "Regain control when an error is signaled.\n\
948Usage looks like (condition-case VAR BODYFORM HANDLERS...).\n\
949executes BODYFORM and returns its value if no error happens.\n\
950Each element of HANDLERS looks like (CONDITION-NAME BODY...)\n\
951where the BODY is made of Lisp expressions.\n\n\
952A handler is applicable to an error\n\
953if CONDITION-NAME is one of the error's condition names.\n\
954If an error happens, the first applicable handler is run.\n\
955\n\
956When a handler handles an error,\n\
957control returns to the condition-case and the handler BODY... is executed\n\
958with VAR bound to (SIGNALED-CONDITIONS . SIGNAL-DATA).\n\
959VAR may be nil; then you do not get access to the signal information.\n\
960\n\
961The value of the last BODY form is returned from the condition-case.\n\
962See also the function `signal' for more info.")
963 (args)
964 Lisp_Object args;
965{
966 Lisp_Object val;
967 struct catchtag c;
968 struct handler h;
969 register Lisp_Object tem;
970
971 tem = Fcar (args);
972 CHECK_SYMBOL (tem, 0);
973
974 c.tag = Qnil;
975 c.val = Qnil;
976 c.backlist = backtrace_list;
977 c.handlerlist = handlerlist;
978 c.lisp_eval_depth = lisp_eval_depth;
979 c.pdlcount = specpdl_ptr - specpdl;
980 c.poll_suppress_count = poll_suppress_count;
981 c.gcpro = gcprolist;
982 if (_setjmp (c.jmp))
983 {
984 if (!NULL (h.var))
985 specbind (h.var, Fcdr (c.val));
986 val = Fprogn (Fcdr (Fcar (c.val)));
987 unbind_to (c.pdlcount, Qnil);
988 return val;
989 }
990 c.next = catchlist;
991 catchlist = &c;
992 h.var = Fcar (args);
993 h.handler = Fcdr (Fcdr (args));
994
995 for (val = h.handler; ! NULL (val); val = Fcdr (val))
996 {
997 tem = Fcar (val);
998 if ((!NULL (tem)) &&
999 (!CONSP (tem) || (XTYPE (XCONS (tem)->car) != Lisp_Symbol)))
1000 error ("Invalid condition handler", tem);
1001 }
1002
1003 h.next = handlerlist;
1004 h.poll_suppress_count = poll_suppress_count;
1005 h.tag = &c;
1006 handlerlist = &h;
1007
1008 val = Feval (Fcar (Fcdr (args)));
1009 catchlist = c.next;
1010 handlerlist = h.next;
1011 return val;
1012}
1013
1014Lisp_Object
1015internal_condition_case (bfun, handlers, hfun)
1016 Lisp_Object (*bfun) ();
1017 Lisp_Object handlers;
1018 Lisp_Object (*hfun) ();
1019{
1020 Lisp_Object val;
1021 struct catchtag c;
1022 struct handler h;
1023
1024 c.tag = Qnil;
1025 c.val = Qnil;
1026 c.backlist = backtrace_list;
1027 c.handlerlist = handlerlist;
1028 c.lisp_eval_depth = lisp_eval_depth;
1029 c.pdlcount = specpdl_ptr - specpdl;
1030 c.poll_suppress_count = poll_suppress_count;
1031 c.gcpro = gcprolist;
1032 if (_setjmp (c.jmp))
1033 {
1034 return (*hfun) (Fcdr (c.val));
1035 }
1036 c.next = catchlist;
1037 catchlist = &c;
1038 h.handler = handlers;
1039 h.var = Qnil;
1040 h.poll_suppress_count = poll_suppress_count;
1041 h.next = handlerlist;
1042 h.tag = &c;
1043 handlerlist = &h;
1044
1045 val = (*bfun) ();
1046 catchlist = c.next;
1047 handlerlist = h.next;
1048 return val;
1049}
1050
1051static Lisp_Object find_handler_clause ();
1052
1053DEFUN ("signal", Fsignal, Ssignal, 2, 2, 0,
1054 "Signal an error. Args are SIGNAL-NAME, and associated DATA.\n\
1055This function does not return.\n\n\
1056A signal name is a symbol with an `error-conditions' property\n\
1057that is a list of condition names.\n\
1058A handler for any of those names will get to handle this signal.\n\
1059The symbol `error' should normally be one of them.\n\
1060\n\
1061DATA should be a list. Its elements are printed as part of the error message.\n\
1062If the signal is handled, DATA is made available to the handler.\n\
1063See also the function `condition-case'.")
1064 (sig, data)
1065 Lisp_Object sig, data;
1066{
1067 register struct handler *allhandlers = handlerlist;
1068 Lisp_Object conditions;
1069 extern int gc_in_progress;
1070 extern int waiting_for_input;
1071 Lisp_Object debugger_value;
1072
1073 quit_error_check ();
1074 immediate_quit = 0;
1075 if (gc_in_progress || waiting_for_input)
1076 abort ();
1077
1078 TOTALLY_UNBLOCK_INPUT;
1079
1080 conditions = Fget (sig, Qerror_conditions);
1081
1082 for (; handlerlist; handlerlist = handlerlist->next)
1083 {
1084 register Lisp_Object clause;
1085 clause = find_handler_clause (handlerlist->handler, conditions,
1086 sig, data, &debugger_value);
1087
1088#if 0 /* Most callers are not prepared to handle gc if this returns.
1089 So, since this feature is not very useful, take it out. */
1090 /* If have called debugger and user wants to continue,
1091 just return nil. */
1092 if (EQ (clause, Qlambda))
1093 return debugger_value;
1094#else
1095 if (EQ (clause, Qlambda))
1096 error ("Returning a value from an error is no longer supported");
1097#endif
1098
1099 if (!NULL (clause))
1100 {
1101 struct handler *h = handlerlist;
1102 /* Restore the polling-suppression count. */
1103 if (h->poll_suppress_count > poll_suppress_count)
1104 abort ();
1105 while (h->poll_suppress_count < poll_suppress_count)
1106 start_polling ();
1107 handlerlist = allhandlers;
1108 unbind_catch (h->tag);
1109 h->tag->val = Fcons (clause, Fcons (sig, data));
1110 _longjmp (h->tag->jmp, 1);
1111 }
1112 }
1113
1114 handlerlist = allhandlers;
1115 /* If no handler is present now, try to run the debugger,
1116 and if that fails, throw to top level. */
1117 find_handler_clause (Qerror, conditions, sig, data, &debugger_value);
1118 Fthrow (Qtop_level, Qt);
1119}
1120
1121/* Value of Qlambda means we have called debugger and
1122 user has continued. Store value returned fromdebugger
1123 into *debugger_value_ptr */
1124
1125static Lisp_Object
1126find_handler_clause (handlers, conditions, sig, data, debugger_value_ptr)
1127 Lisp_Object handlers, conditions, sig, data;
1128 Lisp_Object *debugger_value_ptr;
1129{
1130 register Lisp_Object h;
1131 register Lisp_Object tem;
1132 register Lisp_Object tem1;
1133
1134 if (EQ (handlers, Qt)) /* t is used by handlers for all conditions, set up by C code. */
1135 return Qt;
1136 if (EQ (handlers, Qerror)) /* error is used similarly, but means display a backtrace too */
1137 {
1138 if (stack_trace_on_error)
1139 internal_with_output_to_temp_buffer ("*Backtrace*", Fbacktrace, Qnil);
1140 if (!entering_debugger
1141 && EQ (sig, Qquit) ? debug_on_quit : debug_on_error)
1142 {
1143 int count = specpdl_ptr - specpdl;
1144 specbind (Qdebug_on_error, Qnil);
1145 *debugger_value_ptr =
1146 call_debugger (Fcons (Qerror,
1147 Fcons (Fcons (sig, data),
1148 Qnil)));
1149 return unbind_to (count, Qlambda);
1150 }
1151 return Qt;
1152 }
1153 for (h = handlers; CONSP (h); h = Fcdr (h))
1154 {
1155 tem1 = Fcar (h);
1156 if (!CONSP (tem1))
1157 continue;
1158 tem = Fmemq (Fcar (tem1), conditions);
1159 if (!NULL (tem))
1160 return tem1;
1161 }
1162 return Qnil;
1163}
1164
1165/* dump an error message; called like printf */
1166
1167/* VARARGS 1 */
1168void
1169error (m, a1, a2, a3)
1170 char *m;
1171{
1172 char buf[200];
1173 sprintf (buf, m, a1, a2, a3);
1174
1175 while (1)
1176 Fsignal (Qerror, Fcons (build_string (buf), Qnil));
1177}
1178
1179DEFUN ("commandp", Fcommandp, Scommandp, 1, 1, 0,
1180 "T if FUNCTION makes provisions for interactive calling.\n\
1181This means it contains a description for how to read arguments to give it.\n\
1182The value is nil for an invalid function or a symbol with no function\n\
1183definition.\n\
1184\n\
1185Interactively callable functions include strings and vectors (treated\n\
1186as keyboard macros), lambda-expressions that contain a top-level call\n\
1187to `interactive', autoload definitions made by `autoload' with non-nil\n\
1188fourth argument, and some of the built-in functions of Lisp.\n\
1189\n\
1190Also, a symbol satisfies `commandp' if its function definition does so.")
1191 (function)
1192 Lisp_Object function;
1193{
1194 register Lisp_Object fun;
1195 register Lisp_Object funcar;
1196 register Lisp_Object tem;
1197 register int i = 0;
1198
1199 fun = function;
1200
1201 /* Dereference symbols, but avoid infinte loops. Eech. */
1202 while (XTYPE (fun) == Lisp_Symbol)
1203 {
1204 if (++i > 10) return Qnil;
1205 tem = Ffboundp (fun);
1206 if (NULL (tem)) return Qnil;
1207 fun = Fsymbol_function (fun);
1208 }
1209
1210 /* Emacs primitives are interactive if their DEFUN specifies an
1211 interactive spec. */
1212 if (XTYPE (fun) == Lisp_Subr)
1213 {
1214 if (XSUBR (fun)->prompt)
1215 return Qt;
1216 else
1217 return Qnil;
1218 }
1219
1220 /* Bytecode objects are interactive if they are long enough to
1221 have an element whose index is COMPILED_INTERACTIVE, which is
1222 where the interactive spec is stored. */
1223 else if (XTYPE (fun) == Lisp_Compiled)
1224 return (XVECTOR (fun)->size > COMPILED_INTERACTIVE
1225 ? Qt : Qnil);
1226
1227 /* Strings and vectors are keyboard macros. */
1228 if (XTYPE (fun) == Lisp_String
1229 || XTYPE (fun) == Lisp_Vector)
1230 return Qt;
1231
1232 /* Lists may represent commands. */
1233 if (!CONSP (fun))
1234 return Qnil;
1235 funcar = Fcar (fun);
1236 if (XTYPE (funcar) != Lisp_Symbol)
1237 return Fsignal (Qinvalid_function, Fcons (fun, Qnil));
1238 if (EQ (funcar, Qlambda))
1239 return Fassq (Qinteractive, Fcdr (Fcdr (fun)));
1240 if (EQ (funcar, Qmocklisp))
1241 return Qt; /* All mocklisp functions can be called interactively */
1242 if (EQ (funcar, Qautoload))
1243 return Fcar (Fcdr (Fcdr (Fcdr (fun))));
1244 else
1245 return Qnil;
1246}
1247
1248/* ARGSUSED */
1249DEFUN ("autoload", Fautoload, Sautoload, 2, 5, 0,
1250 "Define FUNCTION to autoload from FILE.\n\
1251FUNCTION is a symbol; FILE is a file name string to pass to `load'.\n\
1252Third arg DOCSTRING is documentation for the function.\n\
1253Fourth arg INTERACTIVE if non-nil says function can be called interactively.\n\
1254Fifth arg MACRO if non-nil says the function is really a macro.\n\
1255Third through fifth args give info about the real definition.\n\
1256They default to nil.\n\
1257If FUNCTION is already defined other than as an autoload,\n\
1258this does nothing and returns nil.")
1259 (function, file, docstring, interactive, macro)
1260 Lisp_Object function, file, docstring, interactive, macro;
1261{
1262#ifdef NO_ARG_ARRAY
1263 Lisp_Object args[4];
1264#endif
1265
1266 CHECK_SYMBOL (function, 0);
1267 CHECK_STRING (file, 1);
1268
1269 /* If function is defined and not as an autoload, don't override */
1270 if (!EQ (XSYMBOL (function)->function, Qunbound)
1271 && !(XTYPE (XSYMBOL (function)->function) == Lisp_Cons
1272 && EQ (XCONS (XSYMBOL (function)->function)->car, Qautoload)))
1273 return Qnil;
1274
1275#ifdef NO_ARG_ARRAY
1276 args[0] = file;
1277 args[1] = docstring;
1278 args[2] = interactive;
1279 args[3] = macro;
1280
1281 return Ffset (function, Fcons (Qautoload, Flist (4, &args[0])));
1282#else /* NO_ARG_ARRAY */
1283 return Ffset (function, Fcons (Qautoload, Flist (4, &file)));
1284#endif /* not NO_ARG_ARRAY */
1285}
1286
1287Lisp_Object
1288un_autoload (oldqueue)
1289 Lisp_Object oldqueue;
1290{
1291 register Lisp_Object queue, first, second;
1292
1293 /* Queue to unwind is current value of Vautoload_queue.
1294 oldqueue is the shadowed value to leave in Vautoload_queue. */
1295 queue = Vautoload_queue;
1296 Vautoload_queue = oldqueue;
1297 while (CONSP (queue))
1298 {
1299 first = Fcar (queue);
1300 second = Fcdr (first);
1301 first = Fcar (first);
1302 if (EQ (second, Qnil))
1303 Vfeatures = first;
1304 else
1305 Ffset (first, second);
1306 queue = Fcdr (queue);
1307 }
1308 return Qnil;
1309}
1310
1311do_autoload (fundef, funname)
1312 Lisp_Object fundef, funname;
1313{
1314 int count = specpdl_ptr - specpdl;
1315 Lisp_Object fun, val;
1316
1317 fun = funname;
1318 CHECK_SYMBOL (funname, 0);
1319
1320 /* Value saved here is to be restored into Vautoload_queue */
1321 record_unwind_protect (un_autoload, Vautoload_queue);
1322 Vautoload_queue = Qt;
1323 Fload (Fcar (Fcdr (fundef)), Qnil, noninteractive ? Qt : Qnil, Qnil);
1324 /* Once loading finishes, don't undo it. */
1325 Vautoload_queue = Qt;
1326 unbind_to (count, Qnil);
1327
1328 while (XTYPE (fun) == Lisp_Symbol)
1329 {
1330 QUIT;
1331 val = XSYMBOL (fun)->function;
1332 if (EQ (val, Qunbound))
1333 Fsymbol_function (fun); /* Get the right kind of error! */
1334 fun = val;
1335 }
1336 if (XTYPE (fun) == Lisp_Cons
1337 && EQ (XCONS (fun)->car, Qautoload))
1338 error ("Autoloading failed to define function %s",
1339 XSYMBOL (funname)->name->data);
1340}
1341
1342DEFUN ("eval", Feval, Seval, 1, 1, 0,
1343 "Evaluate FORM and return its value.")
1344 (form)
1345 Lisp_Object form;
1346{
1347 Lisp_Object fun, val, original_fun, original_args;
1348 Lisp_Object funcar;
1349 struct backtrace backtrace;
1350 struct gcpro gcpro1, gcpro2, gcpro3;
1351
1352 if (XTYPE (form) == Lisp_Symbol)
1353 {
1354 if (EQ (Vmocklisp_arguments, Qt))
1355 return Fsymbol_value (form);
1356 val = Fsymbol_value (form);
1357 if (NULL (val))
1358 XFASTINT (val) = 0;
1359 else if (EQ (val, Qt))
1360 XFASTINT (val) = 1;
1361 return val;
1362 }
1363 if (!CONSP (form))
1364 return form;
1365
1366 QUIT;
1367 if (consing_since_gc > gc_cons_threshold)
1368 {
1369 GCPRO1 (form);
1370 Fgarbage_collect ();
1371 UNGCPRO;
1372 }
1373
1374 if (++lisp_eval_depth > max_lisp_eval_depth)
1375 {
1376 if (max_lisp_eval_depth < 100)
1377 max_lisp_eval_depth = 100;
1378 if (lisp_eval_depth > max_lisp_eval_depth)
1379 error ("Lisp nesting exceeds max-lisp-eval-depth");
1380 }
1381
1382 original_fun = Fcar (form);
1383 original_args = Fcdr (form);
1384
1385 backtrace.next = backtrace_list;
1386 backtrace_list = &backtrace;
1387 backtrace.function = &original_fun; /* This also protects them from gc */
1388 backtrace.args = &original_args;
1389 backtrace.nargs = UNEVALLED;
1390 backtrace.evalargs = 1;
1391 backtrace.debug_on_exit = 0;
1392
1393 if (debug_on_next_call)
1394 do_debug_on_call (Qt);
1395
1396 /* At this point, only original_fun and original_args
1397 have values that will be used below */
1398 retry:
1399 fun = original_fun;
1400 while (XTYPE (fun) == Lisp_Symbol)
1401 {
1402 QUIT;
1403 val = XSYMBOL (fun)->function;
1404 if (EQ (val, Qunbound))
1405 Fsymbol_function (fun); /* Get the right kind of error! */
1406 fun = val;
1407 }
1408
1409 if (XTYPE (fun) == Lisp_Subr)
1410 {
1411 Lisp_Object numargs;
1412 Lisp_Object argvals[7];
1413 Lisp_Object args_left;
1414 register int i, maxargs;
1415
1416 args_left = original_args;
1417 numargs = Flength (args_left);
1418
1419 if (XINT (numargs) < XSUBR (fun)->min_args ||
1420 (XSUBR (fun)->max_args >= 0 && XSUBR (fun)->max_args < XINT (numargs)))
1421 return Fsignal (Qwrong_number_of_arguments, Fcons (fun, Fcons (numargs, Qnil)));
1422
1423 if (XSUBR (fun)->max_args == UNEVALLED)
1424 {
1425 backtrace.evalargs = 0;
1426 val = (*XSUBR (fun)->function) (args_left);
1427 goto done;
1428 }
1429
1430 if (XSUBR (fun)->max_args == MANY)
1431 {
1432 /* Pass a vector of evaluated arguments */
1433 Lisp_Object *vals;
1434 register int argnum = 0;
1435
1436 vals = (Lisp_Object *) alloca (XINT (numargs) * sizeof (Lisp_Object));
1437
1438 GCPRO3 (args_left, fun, fun);
1439 gcpro3.var = vals;
1440 gcpro3.nvars = 0;
1441
1442 while (!NULL (args_left))
1443 {
1444 vals[argnum++] = Feval (Fcar (args_left));
1445 args_left = Fcdr (args_left);
1446 gcpro3.nvars = argnum;
1447 }
1448 UNGCPRO;
1449
1450 backtrace.args = vals;
1451 backtrace.nargs = XINT (numargs);
1452
1453 val = (*XSUBR (fun)->function) (XINT (numargs), vals);
1454 goto done;
1455 }
1456
1457 GCPRO3 (args_left, fun, fun);
1458 gcpro3.var = argvals;
1459 gcpro3.nvars = 0;
1460
1461 maxargs = XSUBR (fun)->max_args;
1462 for (i = 0; i < maxargs; args_left = Fcdr (args_left))
1463 {
1464 argvals[i] = Feval (Fcar (args_left));
1465 gcpro3.nvars = ++i;
1466 }
1467
1468 UNGCPRO;
1469
1470 backtrace.args = argvals;
1471 backtrace.nargs = XINT (numargs);
1472
1473 switch (i)
1474 {
1475 case 0:
1476 val = (*XSUBR (fun)->function) ();
1477 goto done;
1478 case 1:
1479 val = (*XSUBR (fun)->function) (argvals[0]);
1480 goto done;
1481 case 2:
1482 val = (*XSUBR (fun)->function) (argvals[0], argvals[1]);
1483 goto done;
1484 case 3:
1485 val = (*XSUBR (fun)->function) (argvals[0], argvals[1],
1486 argvals[2]);
1487 goto done;
1488 case 4:
1489 val = (*XSUBR (fun)->function) (argvals[0], argvals[1],
1490 argvals[2], argvals[3]);
1491 goto done;
1492 case 5:
1493 val = (*XSUBR (fun)->function) (argvals[0], argvals[1], argvals[2],
1494 argvals[3], argvals[4]);
1495 goto done;
1496 case 6:
1497 val = (*XSUBR (fun)->function) (argvals[0], argvals[1], argvals[2],
1498 argvals[3], argvals[4], argvals[5]);
1499 goto done;
1500
1501 default:
1502 error ("Ffuncall doesn't handle that number of arguments.");
1503 goto done;
1504 }
1505 }
1506 if (XTYPE (fun) == Lisp_Compiled)
1507 val = apply_lambda (fun, original_args, 1);
1508 else
1509 {
1510 if (!CONSP (fun))
1511 return Fsignal (Qinvalid_function, Fcons (fun, Qnil));
1512 funcar = Fcar (fun);
1513 if (XTYPE (funcar) != Lisp_Symbol)
1514 return Fsignal (Qinvalid_function, Fcons (fun, Qnil));
1515 if (EQ (funcar, Qautoload))
1516 {
1517 do_autoload (fun, original_fun);
1518 goto retry;
1519 }
1520 if (EQ (funcar, Qmacro))
1521 val = Feval (apply1 (Fcdr (fun), original_args));
1522 else if (EQ (funcar, Qlambda))
1523 val = apply_lambda (fun, original_args, 1);
1524 else if (EQ (funcar, Qmocklisp))
1525 val = ml_apply (fun, original_args);
1526 else
1527 return Fsignal (Qinvalid_function, Fcons (fun, Qnil));
1528 }
1529 done:
1530 if (!EQ (Vmocklisp_arguments, Qt))
1531 {
1532 if (NULL (val))
1533 XFASTINT (val) = 0;
1534 else if (EQ (val, Qt))
1535 XFASTINT (val) = 1;
1536 }
1537 lisp_eval_depth--;
1538 if (backtrace.debug_on_exit)
1539 val = call_debugger (Fcons (Qexit, Fcons (val, Qnil)));
1540 backtrace_list = backtrace.next;
1541 return val;
1542}
1543
1544DEFUN ("apply", Fapply, Sapply, 2, MANY, 0,
1545 "Call FUNCTION with our remaining args, using our last arg as list of args.\n\
1546Thus, (apply '+ 1 2 '(3 4)) returns 10.")
1547 (nargs, args)
1548 int nargs;
1549 Lisp_Object *args;
1550{
1551 register int i, numargs;
1552 register Lisp_Object spread_arg;
1553 register Lisp_Object *funcall_args;
1554 struct gcpro gcpro1;
1555 Lisp_Object fun;
1556
1557 fun = args [0];
1558 funcall_args = 0;
1559 spread_arg = args [nargs - 1];
1560 CHECK_LIST (spread_arg, nargs);
1561
1562 numargs = XINT (Flength (spread_arg));
1563
1564 if (numargs == 0)
1565 return Ffuncall (nargs - 1, args);
1566 else if (numargs == 1)
1567 {
1568 args [nargs - 1] = XCONS (spread_arg)->car;
1569 return Ffuncall (nargs, args);
1570 }
1571
1572 numargs = nargs - 2 + numargs;
1573
1574 while (XTYPE (fun) == Lisp_Symbol)
1575 {
1576 QUIT;
1577 fun = XSYMBOL (fun)->function;
1578 if (EQ (fun, Qunbound))
1579 {
1580 /* Let funcall get the error */
1581 fun = args[0];
1582 goto funcall;
1583 }
1584 }
1585
1586 if (XTYPE (fun) == Lisp_Subr)
1587 {
1588 if (numargs < XSUBR (fun)->min_args
1589 || (XSUBR (fun)->max_args >= 0 && XSUBR (fun)->max_args < numargs))
1590 goto funcall; /* Let funcall get the error */
1591 else if (XSUBR (fun)->max_args > numargs)
1592 {
1593 /* Avoid making funcall cons up a yet another new vector of arguments
1594 by explicitly supplying nil's for optional values */
1595 funcall_args = (Lisp_Object *) alloca ((1 + XSUBR (fun)->max_args)
1596 * sizeof (Lisp_Object));
1597 for (i = numargs; i < XSUBR (fun)->max_args;)
1598 funcall_args[++i] = Qnil;
1599 }
1600 }
1601 funcall:
1602 /* We add 1 to numargs because funcall_args includes the
1603 function itself as well as its arguments. */
1604 if (!funcall_args)
1605 funcall_args = (Lisp_Object *) alloca ((1 + numargs)
1606 * sizeof (Lisp_Object));
1607 bcopy (args, funcall_args, nargs * sizeof (Lisp_Object));
1608 /* Spread the last arg we got. Its first element goes in
1609 the slot that it used to occupy, hence this value of I. */
1610 i = nargs - 1;
1611 while (!NULL (spread_arg))
1612 {
1613 funcall_args [i++] = XCONS (spread_arg)->car;
1614 spread_arg = XCONS (spread_arg)->cdr;
1615 }
1616
1617 GCPRO1 (*funcall_args);
1618 gcpro1.nvars = numargs + 1;
1619 {
1620 Lisp_Object val = Ffuncall (numargs + 1, funcall_args);
1621 UNGCPRO;
1622 return val;
1623 }
1624}
1625
1626/* Apply fn to arg */
1627Lisp_Object
1628apply1 (fn, arg)
1629 Lisp_Object fn, arg;
1630{
1631 if (NULL (arg))
1632 return Ffuncall (1, &fn);
1633#ifdef NO_ARG_ARRAY
1634 {
1635 Lisp_Object args[2];
1636 args[0] = fn;
1637 args[1] = arg;
1638 return Fapply (2, args);
1639 }
1640#else /* not NO_ARG_ARRAY */
1641 return Fapply (2, &fn);
1642#endif /* not NO_ARG_ARRAY */
1643}
1644
1645/* Call function fn on no arguments */
1646Lisp_Object
1647call0 (fn)
1648 Lisp_Object fn;
1649{
1650 return Ffuncall (1, &fn);
1651}
1652
1653/* Call function fn with argument arg */
1654/* ARGSUSED */
1655Lisp_Object
1656call1 (fn, arg)
1657 Lisp_Object fn, arg;
1658{
1659#ifdef NO_ARG_ARRAY
1660 Lisp_Object args[2];
1661 args[0] = fn;
1662 args[1] = arg;
1663 return Ffuncall (2, args);
1664#else /* not NO_ARG_ARRAY */
1665 return Ffuncall (2, &fn);
1666#endif /* not NO_ARG_ARRAY */
1667}
1668
1669/* Call function fn with arguments arg, arg1 */
1670/* ARGSUSED */
1671Lisp_Object
1672call2 (fn, arg, arg1)
1673 Lisp_Object fn, arg, arg1;
1674{
1675#ifdef NO_ARG_ARRAY
1676 Lisp_Object args[3];
1677 args[0] = fn;
1678 args[1] = arg;
1679 args[2] = arg1;
1680 return Ffuncall (3, args);
1681#else /* not NO_ARG_ARRAY */
1682 return Ffuncall (3, &fn);
1683#endif /* not NO_ARG_ARRAY */
1684}
1685
1686/* Call function fn with arguments arg, arg1, arg2 */
1687/* ARGSUSED */
1688Lisp_Object
1689call3 (fn, arg, arg1, arg2)
1690 Lisp_Object fn, arg, arg1, arg2;
1691{
1692#ifdef NO_ARG_ARRAY
1693 Lisp_Object args[4];
1694 args[0] = fn;
1695 args[1] = arg;
1696 args[2] = arg1;
1697 args[3] = arg2;
1698 return Ffuncall (4, args);
1699#else /* not NO_ARG_ARRAY */
1700 return Ffuncall (4, &fn);
1701#endif /* not NO_ARG_ARRAY */
1702}
1703
1704DEFUN ("funcall", Ffuncall, Sfuncall, 1, MANY, 0,
1705 "Call first argument as a function, passing remaining arguments to it.\n\
1706Thus, (funcall 'cons 'x 'y) returns (x . y).")
1707 (nargs, args)
1708 int nargs;
1709 Lisp_Object *args;
1710{
1711 Lisp_Object fun;
1712 Lisp_Object funcar;
1713 int numargs = nargs - 1;
1714 Lisp_Object lisp_numargs;
1715 Lisp_Object val;
1716 struct backtrace backtrace;
1717 register Lisp_Object *internal_args;
1718 register int i;
1719
1720 QUIT;
1721 if (consing_since_gc > gc_cons_threshold)
1722 Fgarbage_collect ();
1723
1724
1725 if (++lisp_eval_depth > max_lisp_eval_depth)
1726 {
1727 if (max_lisp_eval_depth < 100)
1728 max_lisp_eval_depth = 100;
1729 if (lisp_eval_depth > max_lisp_eval_depth)
1730 error ("Lisp nesting exceeds max-lisp-eval-depth");
1731 }
1732
1733 backtrace.next = backtrace_list;
1734 backtrace_list = &backtrace;
1735 backtrace.function = &args[0];
1736 backtrace.args = &args[1];
1737 backtrace.nargs = nargs - 1;
1738 backtrace.evalargs = 0;
1739 backtrace.debug_on_exit = 0;
1740
1741 if (debug_on_next_call)
1742 do_debug_on_call (Qlambda);
1743
1744 retry:
1745
1746 fun = args[0];
1747 while (XTYPE (fun) == Lisp_Symbol)
1748 {
1749 QUIT;
1750 val = XSYMBOL (fun)->function;
1751 if (EQ (val, Qunbound))
1752 Fsymbol_function (fun); /* Get the right kind of error! */
1753 fun = val;
1754 }
1755
1756 if (XTYPE (fun) == Lisp_Subr)
1757 {
1758 if (numargs < XSUBR (fun)->min_args
1759 || (XSUBR (fun)->max_args >= 0 && XSUBR (fun)->max_args < numargs))
1760 {
1761 XFASTINT (lisp_numargs) = numargs;
1762 return Fsignal (Qwrong_number_of_arguments, Fcons (fun, Fcons (lisp_numargs, Qnil)));
1763 }
1764
1765 if (XSUBR (fun)->max_args == UNEVALLED)
1766 return Fsignal (Qinvalid_function, Fcons (fun, Qnil));
1767
1768 if (XSUBR (fun)->max_args == MANY)
1769 {
1770 val = (*XSUBR (fun)->function) (numargs, args + 1);
1771 goto done;
1772 }
1773
1774 if (XSUBR (fun)->max_args > numargs)
1775 {
1776 internal_args = (Lisp_Object *) alloca (XSUBR (fun)->max_args * sizeof (Lisp_Object));
1777 bcopy (args + 1, internal_args, numargs * sizeof (Lisp_Object));
1778 for (i = numargs; i < XSUBR (fun)->max_args; i++)
1779 internal_args[i] = Qnil;
1780 }
1781 else
1782 internal_args = args + 1;
1783 switch (XSUBR (fun)->max_args)
1784 {
1785 case 0:
1786 val = (*XSUBR (fun)->function) ();
1787 goto done;
1788 case 1:
1789 val = (*XSUBR (fun)->function) (internal_args[0]);
1790 goto done;
1791 case 2:
1792 val = (*XSUBR (fun)->function) (internal_args[0],
1793 internal_args[1]);
1794 goto done;
1795 case 3:
1796 val = (*XSUBR (fun)->function) (internal_args[0], internal_args[1],
1797 internal_args[2]);
1798 goto done;
1799 case 4:
1800 val = (*XSUBR (fun)->function) (internal_args[0], internal_args[1],
1801 internal_args[2],
1802 internal_args[3]);
1803 goto done;
1804 case 5:
1805 val = (*XSUBR (fun)->function) (internal_args[0], internal_args[1],
1806 internal_args[2], internal_args[3],
1807 internal_args[4]);
1808 goto done;
1809 case 6:
1810 val = (*XSUBR (fun)->function) (internal_args[0], internal_args[1],
1811 internal_args[2], internal_args[3],
1812 internal_args[4], internal_args[5]);
1813 goto done;
1814
1815 default:
1816 error ("funcall: this number of args not handled.");
1817 }
1818 }
1819 if (XTYPE (fun) == Lisp_Compiled)
1820 val = funcall_lambda (fun, numargs, args + 1);
1821 else
1822 {
1823 if (!CONSP (fun))
1824 return Fsignal (Qinvalid_function, Fcons (fun, Qnil));
1825 funcar = Fcar (fun);
1826 if (XTYPE (funcar) != Lisp_Symbol)
1827 return Fsignal (Qinvalid_function, Fcons (fun, Qnil));
1828 if (EQ (funcar, Qlambda))
1829 val = funcall_lambda (fun, numargs, args + 1);
1830 else if (EQ (funcar, Qmocklisp))
1831 val = ml_apply (fun, Flist (numargs, args + 1));
1832 else if (EQ (funcar, Qautoload))
1833 {
1834 do_autoload (fun, args[0]);
1835 goto retry;
1836 }
1837 else
1838 return Fsignal (Qinvalid_function, Fcons (fun, Qnil));
1839 }
1840 done:
1841 lisp_eval_depth--;
1842 if (backtrace.debug_on_exit)
1843 val = call_debugger (Fcons (Qexit, Fcons (val, Qnil)));
1844 backtrace_list = backtrace.next;
1845 return val;
1846}
1847
1848Lisp_Object
1849apply_lambda (fun, args, eval_flag)
1850 Lisp_Object fun, args;
1851 int eval_flag;
1852{
1853 Lisp_Object args_left;
1854 Lisp_Object numargs;
1855 register Lisp_Object *arg_vector;
1856 struct gcpro gcpro1, gcpro2, gcpro3;
1857 register int i;
1858 register Lisp_Object tem;
1859
1860 numargs = Flength (args);
1861 arg_vector = (Lisp_Object *) alloca (XINT (numargs) * sizeof (Lisp_Object));
1862 args_left = args;
1863
1864 GCPRO3 (*arg_vector, args_left, fun);
1865 gcpro1.nvars = 0;
1866
1867 for (i = 0; i < XINT (numargs);)
1868 {
1869 tem = Fcar (args_left), args_left = Fcdr (args_left);
1870 if (eval_flag) tem = Feval (tem);
1871 arg_vector[i++] = tem;
1872 gcpro1.nvars = i;
1873 }
1874
1875 UNGCPRO;
1876
1877 if (eval_flag)
1878 {
1879 backtrace_list->args = arg_vector;
1880 backtrace_list->nargs = i;
1881 }
1882 backtrace_list->evalargs = 0;
1883 tem = funcall_lambda (fun, XINT (numargs), arg_vector);
1884
1885 /* Do the debug-on-exit now, while arg_vector still exists. */
1886 if (backtrace_list->debug_on_exit)
1887 tem = call_debugger (Fcons (Qexit, Fcons (tem, Qnil)));
1888 /* Don't do it again when we return to eval. */
1889 backtrace_list->debug_on_exit = 0;
1890 return tem;
1891}
1892
1893/* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
1894 and return the result of evaluation.
1895 FUN must be either a lambda-expression or a compiled-code object. */
1896
1897Lisp_Object
1898funcall_lambda (fun, nargs, arg_vector)
1899 Lisp_Object fun;
1900 int nargs;
1901 register Lisp_Object *arg_vector;
1902{
1903 Lisp_Object val, tem;
1904 register Lisp_Object syms_left;
1905 Lisp_Object numargs;
1906 register Lisp_Object next;
1907 int count = specpdl_ptr - specpdl;
1908 register int i;
1909 int optional = 0, rest = 0;
1910
1911 specbind (Qmocklisp_arguments, Qt); /* t means NOT mocklisp! */
1912
1913 XFASTINT (numargs) = nargs;
1914
1915 if (XTYPE (fun) == Lisp_Cons)
1916 syms_left = Fcar (Fcdr (fun));
1917 else if (XTYPE (fun) == Lisp_Compiled)
1918 syms_left = XVECTOR (fun)->contents[COMPILED_ARGLIST];
1919 else abort ();
1920
1921 i = 0;
1922 for (; !NULL (syms_left); syms_left = Fcdr (syms_left))
1923 {
1924 QUIT;
1925 next = Fcar (syms_left);
1926 if (EQ (next, Qand_rest))
1927 rest = 1;
1928 else if (EQ (next, Qand_optional))
1929 optional = 1;
1930 else if (rest)
1931 {
1932 specbind (Fcar (syms_left), Flist (nargs - i, &arg_vector[i]));
1933 i = nargs;
1934 }
1935 else if (i < nargs)
1936 {
1937 tem = arg_vector[i++];
1938 specbind (next, tem);
1939 }
1940 else if (!optional)
1941 return Fsignal (Qwrong_number_of_arguments, Fcons (fun, Fcons (numargs, Qnil)));
1942 else
1943 specbind (next, Qnil);
1944 }
1945
1946 if (i < nargs)
1947 return Fsignal (Qwrong_number_of_arguments, Fcons (fun, Fcons (numargs, Qnil)));
1948
1949 if (XTYPE (fun) == Lisp_Cons)
1950 val = Fprogn (Fcdr (Fcdr (fun)));
1951 else
1952 val = Fbyte_code (XVECTOR (fun)->contents[COMPILED_BYTECODE],
1953 XVECTOR (fun)->contents[COMPILED_CONSTANTS],
1954 XVECTOR (fun)->contents[COMPILED_STACK_DEPTH]);
1955 return unbind_to (count, val);
1956}
1957
1958void
1959grow_specpdl ()
1960{
1961 register int count = specpdl_ptr - specpdl;
1962 if (specpdl_size >= max_specpdl_size)
1963 {
1964 if (max_specpdl_size < 400)
1965 max_specpdl_size = 400;
1966 if (specpdl_size >= max_specpdl_size)
1967 {
1968 Fsignal (Qerror,
1969 Fcons (build_string ("Variable binding depth exceeds max-specpdl-size"), Qnil));
1970 max_specpdl_size *= 2;
1971 }
1972 }
1973 specpdl_size *= 2;
1974 if (specpdl_size > max_specpdl_size)
1975 specpdl_size = max_specpdl_size;
1976 specpdl = (struct specbinding *) xrealloc (specpdl, specpdl_size * sizeof (struct specbinding));
1977 specpdl_ptr = specpdl + count;
1978}
1979
1980void
1981specbind (symbol, value)
1982 Lisp_Object symbol, value;
1983{
1984 extern void store_symval_forwarding (); /* in eval.c */
1985 Lisp_Object ovalue;
1986
1987 if (specpdl_ptr == specpdl + specpdl_size)
1988 grow_specpdl ();
1989 specpdl_ptr->symbol = symbol;
1990 specpdl_ptr->func = 0;
1991 ovalue = XSYMBOL (symbol)->value;
1992 specpdl_ptr->old_value = EQ (ovalue, Qunbound) ? Qunbound : Fsymbol_value (symbol);
1993 specpdl_ptr++;
1994 if (XTYPE (ovalue) == Lisp_Buffer_Objfwd)
1995 store_symval_forwarding (symbol, ovalue, value);
1996 else
1997 Fset (symbol, value);
1998}
1999
2000void
2001record_unwind_protect (function, arg)
2002 Lisp_Object (*function)();
2003 Lisp_Object arg;
2004{
2005 if (specpdl_ptr == specpdl + specpdl_size)
2006 grow_specpdl ();
2007 specpdl_ptr->func = function;
2008 specpdl_ptr->symbol = Qnil;
2009 specpdl_ptr->old_value = arg;
2010 specpdl_ptr++;
2011}
2012
2013Lisp_Object
2014unbind_to (count, value)
2015 int count;
2016 Lisp_Object value;
2017{
2018 int quitf = !NULL (Vquit_flag);
2019 struct gcpro gcpro1;
2020
2021 GCPRO1 (value);
2022
2023 Vquit_flag = Qnil;
2024
2025 while (specpdl_ptr != specpdl + count)
2026 {
2027 --specpdl_ptr;
2028 if (specpdl_ptr->func != 0)
2029 (*specpdl_ptr->func) (specpdl_ptr->old_value);
2030 /* Note that a "binding" of nil is really an unwind protect,
2031 so in that case the "old value" is a list of forms to evaluate. */
2032 else if (NULL (specpdl_ptr->symbol))
2033 Fprogn (specpdl_ptr->old_value);
2034 else
2035 Fset (specpdl_ptr->symbol, specpdl_ptr->old_value);
2036 }
2037 if (NULL (Vquit_flag) && quitf) Vquit_flag = Qt;
2038
2039 UNGCPRO;
2040
2041 return value;
2042}
2043
2044#if 0
2045
2046/* Get the value of symbol's global binding, even if that binding
2047 is not now dynamically visible. */
2048
2049Lisp_Object
2050top_level_value (symbol)
2051 Lisp_Object symbol;
2052{
2053 register struct specbinding *ptr = specpdl;
2054
2055 CHECK_SYMBOL (symbol, 0);
2056 for (; ptr != specpdl_ptr; ptr++)
2057 {
2058 if (EQ (ptr->symbol, symbol))
2059 return ptr->old_value;
2060 }
2061 return Fsymbol_value (symbol);
2062}
2063
2064Lisp_Object
2065top_level_set (symbol, newval)
2066 Lisp_Object symbol, newval;
2067{
2068 register struct specbinding *ptr = specpdl;
2069
2070 CHECK_SYMBOL (symbol, 0);
2071 for (; ptr != specpdl_ptr; ptr++)
2072 {
2073 if (EQ (ptr->symbol, symbol))
2074 {
2075 ptr->old_value = newval;
2076 return newval;
2077 }
2078 }
2079 return Fset (symbol, newval);
2080}
2081
2082#endif /* 0 */
2083
2084DEFUN ("backtrace-debug", Fbacktrace_debug, Sbacktrace_debug, 2, 2, 0,
2085 "Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.\n\
2086The debugger is entered when that frame exits, if the flag is non-nil.")
2087 (level, flag)
2088 Lisp_Object level, flag;
2089{
2090 register struct backtrace *backlist = backtrace_list;
2091 register int i;
2092
2093 CHECK_NUMBER (level, 0);
2094
2095 for (i = 0; backlist && i < XINT (level); i++)
2096 {
2097 backlist = backlist->next;
2098 }
2099
2100 if (backlist)
2101 backlist->debug_on_exit = !NULL (flag);
2102
2103 return flag;
2104}
2105
2106DEFUN ("backtrace", Fbacktrace, Sbacktrace, 0, 0, "",
2107 "Print a trace of Lisp function calls currently active.\n\
2108Output stream used is value of `standard-output'.")
2109 ()
2110{
2111 register struct backtrace *backlist = backtrace_list;
2112 register int i;
2113 Lisp_Object tail;
2114 Lisp_Object tem;
2115 extern Lisp_Object Vprint_level;
2116 struct gcpro gcpro1;
2117
2118 entering_debugger = 0;
2119
2120 XFASTINT (Vprint_level) = 3;
2121
2122 tail = Qnil;
2123 GCPRO1 (tail);
2124
2125 while (backlist)
2126 {
2127 write_string (backlist->debug_on_exit ? "* " : " ", 2);
2128 if (backlist->nargs == UNEVALLED)
2129 {
2130 Fprin1 (Fcons (*backlist->function, *backlist->args), Qnil);
2131 }
2132 else
2133 {
2134 tem = *backlist->function;
2135 Fprin1 (tem, Qnil); /* This can QUIT */
2136 write_string ("(", -1);
2137 if (backlist->nargs == MANY)
2138 {
2139 for (tail = *backlist->args, i = 0;
2140 !NULL (tail);
2141 tail = Fcdr (tail), i++)
2142 {
2143 if (i) write_string (" ", -1);
2144 Fprin1 (Fcar (tail), Qnil);
2145 }
2146 }
2147 else
2148 {
2149 for (i = 0; i < backlist->nargs; i++)
2150 {
2151 if (i) write_string (" ", -1);
2152 Fprin1 (backlist->args[i], Qnil);
2153 }
2154 }
2155 }
2156 write_string (")\n", -1);
2157 backlist = backlist->next;
2158 }
2159
2160 Vprint_level = Qnil;
2161 UNGCPRO;
2162 return Qnil;
2163}
2164
2165DEFUN ("backtrace-frame", Fbacktrace_frame, Sbacktrace_frame, 1, 1, "",
2166 "Return the function and arguments N frames up from current execution point.\n\
2167If that frame has not evaluated the arguments yet (or is a special form),\n\
2168the value is (nil FUNCTION ARG-FORMS...).\n\
2169If that frame has evaluated its arguments and called its function already,\n\
2170the value is (t FUNCTION ARG-VALUES...).\n\
2171A &rest arg is represented as the tail of the list ARG-VALUES.\n\
2172FUNCTION is whatever was supplied as car of evaluated list,\n\
2173or a lambda expression for macro calls.\n\
2174If N is more than the number of frames, the value is nil.")
2175 (nframes)
2176 Lisp_Object nframes;
2177{
2178 register struct backtrace *backlist = backtrace_list;
2179 register int i;
2180 Lisp_Object tem;
2181
2182 CHECK_NATNUM (nframes, 0);
2183
2184 /* Find the frame requested. */
2185 for (i = 0; i < XFASTINT (nframes); i++)
2186 backlist = backlist->next;
2187
2188 if (!backlist)
2189 return Qnil;
2190 if (backlist->nargs == UNEVALLED)
2191 return Fcons (Qnil, Fcons (*backlist->function, *backlist->args));
2192 else
2193 {
2194 if (backlist->nargs == MANY)
2195 tem = *backlist->args;
2196 else
2197 tem = Flist (backlist->nargs, backlist->args);
2198
2199 return Fcons (Qt, Fcons (*backlist->function, tem));
2200 }
2201}
2202
2203syms_of_eval ()
2204{
2205 DEFVAR_INT ("max-specpdl-size", &max_specpdl_size,
2206 "Limit on number of Lisp variable bindings & unwind-protects before error.");
2207
2208 DEFVAR_INT ("max-lisp-eval-depth", &max_lisp_eval_depth,
2209 "Limit on depth in `eval', `apply' and `funcall' before error.\n\
2210This limit is to catch infinite recursions for you before they cause\n\
2211actual stack overflow in C, which would be fatal for Emacs.\n\
2212You can safely make it considerably larger than its default value,\n\
2213if that proves inconveniently small.");
2214
2215 DEFVAR_LISP ("quit-flag", &Vquit_flag,
2216 "Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.\n\
2217Typing C-G sets `quit-flag' non-nil, regardless of `inhibit-quit'.");
2218 Vquit_flag = Qnil;
2219
2220 DEFVAR_LISP ("inhibit-quit", &Vinhibit_quit,
2221 "Non-nil inhibits C-g quitting from happening immediately.\n\
2222Note that `quit-flag' will still be set by typing C-g,\n\
2223so a quit will be signalled as soon as `inhibit-quit' is nil.\n\
2224To prevent this happening, set `quit-flag' to nil\n\
2225before making `inhibit-quit' nil.");
2226 Vinhibit_quit = Qnil;
2227
2228 Qautoload = intern ("autoload");
2229 staticpro (&Qautoload);
2230
2231 Qdebug_on_error = intern ("debug-on-error");
2232 staticpro (&Qdebug_on_error);
2233
2234 Qmacro = intern ("macro");
2235 staticpro (&Qmacro);
2236
2237 /* Note that the process handling also uses Qexit, but we don't want
2238 to staticpro it twice, so we just do it here. */
2239 Qexit = intern ("exit");
2240 staticpro (&Qexit);
2241
2242 Qinteractive = intern ("interactive");
2243 staticpro (&Qinteractive);
2244
2245 Qcommandp = intern ("commandp");
2246 staticpro (&Qcommandp);
2247
2248 Qdefun = intern ("defun");
2249 staticpro (&Qdefun);
2250
2251 Qand_rest = intern ("&rest");
2252 staticpro (&Qand_rest);
2253
2254 Qand_optional = intern ("&optional");
2255 staticpro (&Qand_optional);
2256
2257 DEFVAR_BOOL ("stack-trace-on-error", &stack_trace_on_error,
2258 "*Non-nil means automatically display a backtrace buffer\n\
2259after any error that is handled by the editor command loop.");
2260 stack_trace_on_error = 0;
2261
2262 DEFVAR_BOOL ("debug-on-error", &debug_on_error,
2263 "*Non-nil means enter debugger if an error is signaled.\n\
2264Does not apply to errors handled by `condition-case'.\n\
2265See also variable `debug-on-quit'.");
2266 debug_on_error = 0;
2267
2268 DEFVAR_BOOL ("debug-on-quit", &debug_on_quit,
2269 "*Non-nil means enter debugger if quit is signaled (C-G, for example).\n\
2270Does not apply if quit is handled by a `condition-case'.");
2271 debug_on_quit = 0;
2272
2273 DEFVAR_BOOL ("debug-on-next-call", &debug_on_next_call,
2274 "Non-nil means enter debugger before next `eval', `apply' or `funcall'.");
2275
2276 DEFVAR_LISP ("debugger", &Vdebugger,
2277 "Function to call to invoke debugger.\n\
2278If due to frame exit, args are `exit' and the value being returned;\n\
2279 this function's value will be returned instead of that.\n\
2280If due to error, args are `error' and a list of the args to `signal'.\n\
2281If due to `apply' or `funcall' entry, one arg, `lambda'.\n\
2282If due to `eval' entry, one arg, t.");
2283 Vdebugger = Qnil;
2284
2285 Qmocklisp_arguments = intern ("mocklisp-arguments");
2286 staticpro (&Qmocklisp_arguments);
2287 DEFVAR_LISP ("mocklisp-arguments", &Vmocklisp_arguments,
2288 "While in a mocklisp function, the list of its unevaluated args.");
2289 Vmocklisp_arguments = Qt;
2290
2291 DEFVAR_LISP ("run-hooks", &Vrun_hooks,
2292 "Set to the function `run-hooks', if that function has been defined.\n\
2293Otherwise, nil (in a bare Emacs without preloaded Lisp code).");
2294 Vrun_hooks = Qnil;
2295
2296 staticpro (&Vautoload_queue);
2297 Vautoload_queue = Qnil;
2298
2299 defsubr (&Sor);
2300 defsubr (&Sand);
2301 defsubr (&Sif);
2302 defsubr (&Scond);
2303 defsubr (&Sprogn);
2304 defsubr (&Sprog1);
2305 defsubr (&Sprog2);
2306 defsubr (&Ssetq);
2307 defsubr (&Squote);
2308 defsubr (&Sfunction);
2309 defsubr (&Sdefun);
2310 defsubr (&Sdefmacro);
2311 defsubr (&Sdefvar);
2312 defsubr (&Sdefconst);
2313 defsubr (&Suser_variable_p);
2314 defsubr (&Slet);
2315 defsubr (&SletX);
2316 defsubr (&Swhile);
2317 defsubr (&Smacroexpand);
2318 defsubr (&Scatch);
2319 defsubr (&Sthrow);
2320 defsubr (&Sunwind_protect);
2321 defsubr (&Scondition_case);
2322 defsubr (&Ssignal);
2323 defsubr (&Sinteractive_p);
2324 defsubr (&Scommandp);
2325 defsubr (&Sautoload);
2326 defsubr (&Seval);
2327 defsubr (&Sapply);
2328 defsubr (&Sfuncall);
2329 defsubr (&Sbacktrace_debug);
2330 defsubr (&Sbacktrace);
2331 defsubr (&Sbacktrace_frame);
2332}