272
|
1 /* Evaluator for GNU Emacs Lisp interpreter.
|
|
2 Copyright (C) 1985, 1986, 1987 Free Software Foundation, Inc.
|
|
3
|
|
4 This file is part of GNU Emacs.
|
|
5
|
|
6 GNU Emacs is free software; you can redistribute it and/or modify
|
|
7 it under the terms of the GNU General Public License as published by
|
|
8 the Free Software Foundation; either version 1, or (at your option)
|
|
9 any later version.
|
|
10
|
|
11 GNU Emacs is distributed in the hope that it will be useful,
|
|
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
14 GNU General Public License for more details.
|
|
15
|
|
16 You should have received a copy of the GNU General Public License
|
|
17 along with GNU Emacs; see the file COPYING. If not, write to
|
|
18 the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
|
|
19
|
|
20
|
|
21 #include "config.h"
|
|
22 #include "lisp.h"
|
|
23 #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
|
|
38 struct 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
|
|
50 struct backtrace *backtrace_list;
|
|
51
|
|
52 struct 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
|
|
66 struct catchtag *catchlist;
|
|
67
|
|
68 Lisp_Object Qautoload, Qmacro, Qexit, Qinteractive, Qcommandp, Qdefun;
|
|
69 Lisp_Object Vquit_flag, Vinhibit_quit;
|
|
70 Lisp_Object Qmocklisp_arguments, Vmocklisp_arguments, Qmocklisp;
|
|
71 Lisp_Object Qand_rest, Qand_optional;
|
|
72 Lisp_Object Qdebug_on_error;
|
|
73
|
|
74 Lisp_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
|
|
81 Lisp_Object Vautoload_queue;
|
|
82
|
|
83 /* Current number of specbindings allocated in specpdl. */
|
|
84 int specpdl_size;
|
|
85
|
|
86 /* Pointer to beginning of specpdl. */
|
|
87 struct specbinding *specpdl;
|
|
88
|
|
89 /* Pointer to first unused element in specpdl. */
|
|
90 struct specbinding *specpdl_ptr;
|
|
91
|
|
92 /* Maximum size allowed for specpdl allocation */
|
|
93 int max_specpdl_size;
|
|
94
|
|
95 /* Depth in Lisp evaluations and function calls. */
|
|
96 int lisp_eval_depth;
|
|
97
|
|
98 /* Maximum allowed depth in Lisp evaluations and function calls. */
|
|
99 int max_lisp_eval_depth;
|
|
100
|
|
101 /* Nonzero means enter debugger before next function call */
|
|
102 int debug_on_next_call;
|
|
103
|
|
104 /* Nonzero means display a backtrace if an error
|
|
105 is handled by the command loop's error handler. */
|
|
106 int stack_trace_on_error;
|
|
107
|
|
108 /* Nonzero means enter debugger if an error
|
|
109 is handled by the command loop's error handler. */
|
|
110 int debug_on_error;
|
|
111
|
|
112 /* Nonzero means enter debugger if a quit signal
|
|
113 is handled by the command loop's error handler. */
|
|
114 int debug_on_quit;
|
|
115
|
|
116 /* Nonzero means we are trying to enter the debugger.
|
|
117 This is to prevent recursive attempts. */
|
|
118 int entering_debugger;
|
|
119
|
|
120 Lisp_Object Vdebugger;
|
|
121
|
|
122 void specbind (), record_unwind_protect ();
|
|
123
|
|
124 Lisp_Object funcall_lambda ();
|
|
125 extern Lisp_Object ml_apply (); /* Apply a mocklisp function to unevaluated argument list */
|
|
126
|
|
127 init_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
|
|
135 init_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
|
|
147 Lisp_Object
|
|
148 call_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
|
|
160 do_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
|
|
172 DEFUN ("or", For, Sor, 0, UNEVALLED, 0,
|
|
173 "Eval args until one of them yields non-nil, then return that value.\n\
|
|
174 The remaining args are not evalled at all.\n\
|
|
175 If 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
|
|
202 DEFUN ("and", Fand, Sand, 0, UNEVALLED, 0,
|
|
203 "Eval args until one of them yields nil, then return nil.\n\
|
|
204 The remaining args are not evalled at all.\n\
|
|
205 If 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
|
|
232 DEFUN ("if", Fif, Sif, 2, UNEVALLED, 0,
|
|
233 "(if COND THEN ELSE...): if COND yields non-nil, do THEN, else do ELSE...\n\
|
|
234 Returns the value of THEN or the value of the last of the ELSE's.\n\
|
|
235 THEN must be one expression, but ELSE... can be zero or more expressions.\n\
|
|
236 If 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
|
|
252 DEFUN ("cond", Fcond, Scond, 0, UNEVALLED, 0,
|
|
253 "(cond CLAUSES...): try each clause until one succeeds.\n\
|
|
254 Each clause looks like (CONDITION BODY...). CONDITION is evaluated\n\
|
|
255 and, if the value is non-nil, this clause succeeds:\n\
|
|
256 then the expressions in BODY are evaluated and the last one's\n\
|
|
257 value is the value of the cond-form.\n\
|
|
258 If no clause succeeds, cond returns nil.\n\
|
|
259 If a clause has one element, as in (CONDITION),\n\
|
|
260 CONDITION'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
|
|
286 DEFUN ("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
|
|
324 DEFUN ("prog1", Fprog1, Sprog1, 1, UNEVALLED, 0,
|
|
325 "(prog1 FIRST BODY...): eval FIRST and BODY sequentially; value from FIRST.\n\
|
|
326 The value of FIRST is saved during the evaluation of the remaining args,\n\
|
|
327 whose 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
|
|
357 DEFUN ("prog2", Fprog2, Sprog2, 2, UNEVALLED, 0,
|
|
358 "(prog1 X Y BODY...): eval X, Y and BODY sequentially; value from Y.\n\
|
|
359 The value of Y is saved during the evaluation of the remaining args,\n\
|
|
360 whose 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
|
|
392 DEFUN ("setq", Fsetq, Ssetq, 0, UNEVALLED, 0,
|
|
393 "(setq SYM VAL SYM VAL ...): set each SYM to the value of its VAL.\n\
|
|
394 The SYMs are not evaluated. Thus (setq x y) sets x to the value of y.\n\
|
|
395 Each 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
|
|
422 DEFUN ("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
|
|
430 DEFUN ("function", Ffunction, Sfunction, 1, UNEVALLED, 0,
|
|
431 "Like `quote', but preferred for objects which are functions.\n\
|
|
432 In 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
|
|
440 DEFUN ("interactive-p", Finteractive_p, Sinteractive_p, 0, 0, 0,
|
|
441 "Return t if function in which this appears was called interactively.\n\
|
|
442 This means that the function was called with call-interactively (which\n\
|
|
443 includes being called as the binding of a key)\n\
|
|
444 and 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
|
|
483 DEFUN ("defun", Fdefun, Sdefun, 2, UNEVALLED, 0,
|
|
484 "(defun NAME ARGLIST [DOCSTRING] BODY...): define NAME as a function.\n\
|
|
485 The definition is (lambda ARGLIST [DOCSTRING] BODY...).\n\
|
|
486 See 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
|
|
501 DEFUN ("defmacro", Fdefmacro, Sdefmacro, 2, UNEVALLED, 0,
|
|
502 "(defmacro NAME ARGLIST [DOCSTRING] BODY...): define NAME as a macro.\n\
|
|
503 The definition is (macro lambda ARGLIST [DOCSTRING] BODY...).\n\
|
|
504 When the macro is called, as in (NAME ARGS...),\n\
|
|
505 the function (lambda ARGLIST BODY...) is applied to\n\
|
|
506 the list ARGS... as it appears in the expression,\n\
|
|
507 and 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
|
|
522 DEFUN ("defvar", Fdefvar, Sdefvar, 1, UNEVALLED, 0,
|
|
523 "(defvar SYMBOL INITVALUE DOCSTRING): define SYMBOL as a variable.\n\
|
|
524 You are not required to define a variable in order to use it,\n\
|
|
525 but the definition can supply documentation and an initial value\n\
|
|
526 in a way that tags can recognize.\n\n\
|
|
527 INITVALUE is evaluated, and used to set SYMBOL, only if SYMBOL's value is void.\n\
|
|
528 If SYMBOL is buffer-local, its default value is initialized in this way.\n\
|
|
529 INITVALUE and DOCSTRING are optional.\n\
|
|
530 If 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\
|
|
532 If 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
|
|
556 DEFUN ("defconst", Fdefconst, Sdefconst, 2, UNEVALLED, 0,
|
|
557 "(defconst SYMBOL INITVALUE DOCSTRING): define SYMBOL as a constant variable.\n\
|
|
558 The intent is that programs do not change this value, but users may.\n\
|
|
559 Always sets the value of SYMBOL to the result of evalling INITVALUE.\n\
|
|
560 If SYMBOL is buffer-local, its default value is initialized in this way.\n\
|
|
561 DOCSTRING is optional.\n\
|
|
562 If 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\
|
|
564 Note: do not use `defconst' for user options in libraries that are not\n\
|
|
565 normally loaded, since it is useful for users to be able to specify\n\
|
|
566 their own values for such variables before loading the library.\n\
|
|
567 Since `defconst' unconditionally assigns the variable,\n\
|
|
568 it 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
|
|
586 DEFUN ("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\
|
|
589 Determined by whether the first character of the documentation\n\
|
|
590 for 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
|
|
605 DEFUN ("let*", FletX, SletX, 1, UNEVALLED, 0,
|
|
606 "(let* VARLIST BODY...): bind variables according to VARLIST then eval BODY.\n\
|
|
607 The value of the last form in BODY is returned.\n\
|
|
608 Each element of VARLIST is a symbol (which is bound to nil)\n\
|
|
609 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).\n\
|
|
610 Each 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
|
|
639 DEFUN ("let", Flet, Slet, 1, UNEVALLED, 0,
|
|
640 "(let VARLIST BODY...): bind variables according to VARLIST then eval BODY.\n\
|
|
641 The value of the last form in BODY is returned.\n\
|
|
642 Each element of VARLIST is a symbol (which is bound to nil)\n\
|
|
643 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).\n\
|
|
644 All 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
|
|
692 DEFUN ("while", Fwhile, Swhile, 1, UNEVALLED, 0,
|
|
693 "(while TEST BODY...): if TEST yields non-nil, eval BODY... and repeat.\n\
|
|
694 The order of execution is thus TEST, BODY, TEST, BODY and so on\n\
|
|
695 until 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
|
|
716 DEFUN ("macroexpand", Fmacroexpand, Smacroexpand, 1, 2, 0,
|
|
717 "Return result of expanding macros at top level of FORM.\n\
|
|
718 If FORM is not a macro call, it is returned unchanged.\n\
|
|
719 Otherwise, the macro is expanded and the expansion is considered\n\
|
|
720 in place of FORM. When a non-macro-call results, it is returned.\n\n\
|
|
721 The second optional arg ENVIRONMENT species an environment of macro\n\
|
|
722 definitions 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
|
|
808 DEFUN ("catch", Fcatch, Scatch, 1, UNEVALLED, 0,
|
|
809 "(catch TAG BODY...): eval BODY allowing nonlocal exits using `throw'.\n\
|
|
810 TAG is evalled to get the tag to use. Then the BODY is executed.\n\
|
|
811 Within BODY, (throw TAG) with same tag exits BODY and exits this `catch'.\n\
|
|
812 If no throw happens, `catch' returns the value of the last BODY form.\n\
|
|
813 If 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
|
|
830 Lisp_Object
|
|
831 internal_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
|
|
871 static void
|
|
872 unbind_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
|
|
891 DEFUN ("throw", Fthrow, Sthrow, 2, 2, 0,
|
|
892 "(throw TAG VALUE): throw to the catch for TAG and return VALUE from it.\n\
|
|
893 Both 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
|
|
921 DEFUN ("unwind-protect", Funwind_protect, Sunwind_protect, 1, UNEVALLED, 0,
|
|
922 "Do BODYFORM, protecting with UNWINDFORMS.\n\
|
|
923 Usage looks like (unwind-protect BODYFORM UNWINDFORMS...).\n\
|
|
924 If BODYFORM completes normally, its value is returned\n\
|
|
925 after executing the UNWINDFORMS.\n\
|
|
926 If 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
|
|
944 struct handler *handlerlist;
|
|
945
|
|
946 DEFUN ("condition-case", Fcondition_case, Scondition_case, 2, UNEVALLED, 0,
|
|
947 "Regain control when an error is signaled.\n\
|
|
948 Usage looks like (condition-case VAR BODYFORM HANDLERS...).\n\
|
|
949 executes BODYFORM and returns its value if no error happens.\n\
|
|
950 Each element of HANDLERS looks like (CONDITION-NAME BODY...)\n\
|
|
951 where the BODY is made of Lisp expressions.\n\n\
|
|
952 A handler is applicable to an error\n\
|
|
953 if CONDITION-NAME is one of the error's condition names.\n\
|
|
954 If an error happens, the first applicable handler is run.\n\
|
|
955 \n\
|
|
956 When a handler handles an error,\n\
|
|
957 control returns to the condition-case and the handler BODY... is executed\n\
|
|
958 with VAR bound to (SIGNALED-CONDITIONS . SIGNAL-DATA).\n\
|
|
959 VAR may be nil; then you do not get access to the signal information.\n\
|
|
960 \n\
|
|
961 The value of the last BODY form is returned from the condition-case.\n\
|
|
962 See 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
|
|
1014 Lisp_Object
|
|
1015 internal_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
|
|
1051 static Lisp_Object find_handler_clause ();
|
|
1052
|
|
1053 DEFUN ("signal", Fsignal, Ssignal, 2, 2, 0,
|
|
1054 "Signal an error. Args are SIGNAL-NAME, and associated DATA.\n\
|
|
1055 This function does not return.\n\n\
|
|
1056 A signal name is a symbol with an `error-conditions' property\n\
|
|
1057 that is a list of condition names.\n\
|
|
1058 A handler for any of those names will get to handle this signal.\n\
|
|
1059 The symbol `error' should normally be one of them.\n\
|
|
1060 \n\
|
|
1061 DATA should be a list. Its elements are printed as part of the error message.\n\
|
|
1062 If the signal is handled, DATA is made available to the handler.\n\
|
|
1063 See 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
|
|
1125 static Lisp_Object
|
|
1126 find_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 */
|
|
1168 void
|
|
1169 error (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
|
|
1179 DEFUN ("commandp", Fcommandp, Scommandp, 1, 1, 0,
|
|
1180 "T if FUNCTION makes provisions for interactive calling.\n\
|
|
1181 This means it contains a description for how to read arguments to give it.\n\
|
|
1182 The value is nil for an invalid function or a symbol with no function\n\
|
|
1183 definition.\n\
|
|
1184 \n\
|
|
1185 Interactively callable functions include strings and vectors (treated\n\
|
|
1186 as keyboard macros), lambda-expressions that contain a top-level call\n\
|
|
1187 to `interactive', autoload definitions made by `autoload' with non-nil\n\
|
|
1188 fourth argument, and some of the built-in functions of Lisp.\n\
|
|
1189 \n\
|
|
1190 Also, 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 */
|
|
1249 DEFUN ("autoload", Fautoload, Sautoload, 2, 5, 0,
|
|
1250 "Define FUNCTION to autoload from FILE.\n\
|
|
1251 FUNCTION is a symbol; FILE is a file name string to pass to `load'.\n\
|
|
1252 Third arg DOCSTRING is documentation for the function.\n\
|
|
1253 Fourth arg INTERACTIVE if non-nil says function can be called interactively.\n\
|
|
1254 Fifth arg MACRO if non-nil says the function is really a macro.\n\
|
|
1255 Third through fifth args give info about the real definition.\n\
|
|
1256 They default to nil.\n\
|
|
1257 If FUNCTION is already defined other than as an autoload,\n\
|
|
1258 this 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
|
|
1287 Lisp_Object
|
|
1288 un_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
|
|
1311 do_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
|
|
1342 DEFUN ("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
|
|
1544 DEFUN ("apply", Fapply, Sapply, 2, MANY, 0,
|
|
1545 "Call FUNCTION with our remaining args, using our last arg as list of args.\n\
|
|
1546 Thus, (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 */
|
|
1627 Lisp_Object
|
|
1628 apply1 (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 */
|
|
1646 Lisp_Object
|
|
1647 call0 (fn)
|
|
1648 Lisp_Object fn;
|
|
1649 {
|
|
1650 return Ffuncall (1, &fn);
|
|
1651 }
|
|
1652
|
|
1653 /* Call function fn with argument arg */
|
|
1654 /* ARGSUSED */
|
|
1655 Lisp_Object
|
|
1656 call1 (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 */
|
|
1671 Lisp_Object
|
|
1672 call2 (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 */
|
|
1688 Lisp_Object
|
|
1689 call3 (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
|
|
1704 DEFUN ("funcall", Ffuncall, Sfuncall, 1, MANY, 0,
|
|
1705 "Call first argument as a function, passing remaining arguments to it.\n\
|
|
1706 Thus, (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
|
|
1848 Lisp_Object
|
|
1849 apply_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
|
|
1897 Lisp_Object
|
|
1898 funcall_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
|
|
1958 void
|
|
1959 grow_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
|
|
1980 void
|
|
1981 specbind (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
|
|
2000 void
|
|
2001 record_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
|
|
2013 Lisp_Object
|
|
2014 unbind_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
|
|
2049 Lisp_Object
|
|
2050 top_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
|
|
2064 Lisp_Object
|
|
2065 top_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
|
|
2084 DEFUN ("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\
|
|
2086 The 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
|
|
2106 DEFUN ("backtrace", Fbacktrace, Sbacktrace, 0, 0, "",
|
|
2107 "Print a trace of Lisp function calls currently active.\n\
|
|
2108 Output 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
|
|
2165 DEFUN ("backtrace-frame", Fbacktrace_frame, Sbacktrace_frame, 1, 1, "",
|
|
2166 "Return the function and arguments N frames up from current execution point.\n\
|
|
2167 If that frame has not evaluated the arguments yet (or is a special form),\n\
|
|
2168 the value is (nil FUNCTION ARG-FORMS...).\n\
|
|
2169 If that frame has evaluated its arguments and called its function already,\n\
|
|
2170 the value is (t FUNCTION ARG-VALUES...).\n\
|
|
2171 A &rest arg is represented as the tail of the list ARG-VALUES.\n\
|
|
2172 FUNCTION is whatever was supplied as car of evaluated list,\n\
|
|
2173 or a lambda expression for macro calls.\n\
|
|
2174 If 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
|
|
2203 syms_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\
|
|
2210 This limit is to catch infinite recursions for you before they cause\n\
|
|
2211 actual stack overflow in C, which would be fatal for Emacs.\n\
|
|
2212 You can safely make it considerably larger than its default value,\n\
|
|
2213 if 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\
|
|
2217 Typing 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\
|
|
2222 Note that `quit-flag' will still be set by typing C-g,\n\
|
|
2223 so a quit will be signalled as soon as `inhibit-quit' is nil.\n\
|
|
2224 To prevent this happening, set `quit-flag' to nil\n\
|
|
2225 before 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\
|
|
2259 after 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\
|
|
2264 Does not apply to errors handled by `condition-case'.\n\
|
|
2265 See 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\
|
|
2270 Does 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\
|
|
2278 If 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\
|
|
2280 If due to error, args are `error' and a list of the args to `signal'.\n\
|
|
2281 If due to `apply' or `funcall' entry, one arg, `lambda'.\n\
|
|
2282 If 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\
|
|
2293 Otherwise, 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 }
|