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