xemacs-beta: src/eval.c comparison

comparison src/eval.c @ 412:697ef44129c6 r21-2-14

Import from CVS: tag r21-2-14

author	cvs
date	Mon, 13 Aug 2007 11:20:41 +0200
parents	de805c49cfc1
children	41dbb7a9d5f2

comparison

equal deleted inserted replaced

-:12e008d41344
+:697ef44129c6
 /* If subrs take more than 8 arguments, more cases need to be added
 to this switch.  (But wait - don't do it - if you really need
 a SUBR with more than 8 arguments, use max_args == MANY.
 See the DEFUN macro in lisp.h)  */
 #define PRIMITIVE_FUNCALL(rv, fn, av, ac) do {			\
-void (*PF_fn)(void) = (void (*)(void)) fn;			\
+void (*PF_fn)() = (void (*)()) (fn);				\
 Lisp_Object *PF_av = (av);					\
 switch (ac)							\
 {								\
-default:rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 0); break;	\
+default: abort();						\
+case 0: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 0); break;	\
 case 1: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 1); break;	\
 case 2: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 2); break;	\
 case 3: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 3); break;	\
 case 4: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 4); break;	\
 case 5: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 5); break;	\
 Lisp_Object Vcurrent_warning_class;
 /* Special catch tag used in call_with_suspended_errors(). */
 Lisp_Object Qunbound_suspended_errors_tag;
+/* Non-nil means we're going down, so we better not run any hooks
+or do other non-essential stuff. */
+int preparing_for_armageddon;
 /* Non-nil means record all fset's and provide's, to be undone
 if the file being autoloaded is not fully loaded.
 They are recorded by being consed onto the front of Vautoload_queue:
 (FUN . ODEF) for a defun, (OFEATURES . nil) for a provide.  */
 Lisp_Object Vautoload_queue;
 /* Maximum size allowed for specpdl allocation */
 int max_specpdl_size;
 /* Depth in Lisp evaluations and function calls.  */
-static int lisp_eval_depth;
+int lisp_eval_depth;
 /* Maximum allowed depth in Lisp evaluations and function calls.  */
 int max_lisp_eval_depth;
 /* Nonzero means enter debugger before next function call */
 in.
 */
 static Lisp_Object Vcondition_handlers;
-#define DEFEND_AGAINST_THROW_RECURSION
+#if 0 /* no longer used */
-#ifdef DEFEND_AGAINST_THROW_RECURSION
 /* Used for error catching purposes by throw_or_bomb_out */
 static int throw_level;
-#endif
+#endif /* unused */
-#ifdef ERROR_CHECK_TYPECHECK
-void check_error_state_sanity (void);
-#endif
 /************************************************************************/
 /*			The subr object type				*/
 /************************************************************************/
 static void
 print_subr (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
 {
 Lisp_Subr *subr = XSUBR (obj);
-const char *header =
+CONST char *header =
 (subr->max_args == UNEVALLED) ? "#<special-form " : "#<subr ";
-const char *name = subr_name (subr);
+CONST char *name = subr_name (subr);
-const char *trailer = subr->prompt ? " (interactive)>" : ">";
+CONST char *trailer = subr->prompt ? " (interactive)>" : ">";
 if (print_readably)
 error ("printing unreadable object %s%s%s", header, name, trailer);
 write_c_string (header,  printcharfun);
 write_c_string (name,    printcharfun);
 write_c_string (trailer, printcharfun);
 }
-static const struct lrecord_description subr_description[] = {
+DEFINE_LRECORD_IMPLEMENTATION ("subr", subr,
-{ XD_DOC_STRING, offsetof (Lisp_Subr, doc) },
+this_one_is_unmarkable, print_subr, 0, 0, 0,
-{ XD_END }
+			       Lisp_Subr);
-};
-DEFINE_BASIC_LRECORD_IMPLEMENTATION ("subr", subr,
-				     0, print_subr, 0, 0, 0,
-				     subr_description,
-				     Lisp_Subr);
 /************************************************************************/
 /*			 Entering the debugger				*/
 /************************************************************************/
 /*			Defining functions/variables			*/
 /************************************************************************/
 static Lisp_Object
 define_function (Lisp_Object name, Lisp_Object defn)
 {
+if (purify_flag)
+defn = Fpurecopy (defn);
 Ffset (name, defn);
 LOADHIST_ATTACH (name);
 return name;
 }
 void.)
 If SYMBOL is buffer-local, its default value is what is set;
 buffer-local values are not affected.
 INITVALUE and DOCSTRING are optional.
 If DOCSTRING starts with *, this variable is identified as a user option.
-This means that M-x set-variable recognizes it.
+This means that M-x set-variable and M-x edit-options recognize it.
 If INITVALUE is missing, SYMBOL's value is not set.
 In lisp-interaction-mode defvar is treated as defconst.
 */
 (args))
 	}
 if (!NILP (args = XCDR (args)))
 	{
 	  Lisp_Object doc = XCAR (args);
+#if 0 /* FSFmacs */
+	  /* #### We should probably do this but it might be dangerous */
+	  if (purify_flag)
+	    doc = Fpurecopy (doc);
 	  Fput (sym, Qvariable_documentation, doc);
+#else
+	  pure_put (sym, Qvariable_documentation, doc);
+#endif
 	  if (!NILP (args = XCDR (args)))
 	    error ("too many arguments");
 	}
 }
 #ifdef I18N3
 if (!NILP (Vfile_domain))
-Fput (sym, Qvariable_domain, Vfile_domain);
+pure_put (sym, Qvariable_domain, Vfile_domain);
 #endif
 LOADHIST_ATTACH (sym);
 return sym;
 }
 Always sets the value of SYMBOL to the result of evalling INITVALUE.
 If SYMBOL is buffer-local, its default value is what is set;
 buffer-local values are not affected.
 DOCSTRING is optional.
 If DOCSTRING starts with *, this variable is identified as a user option.
-This means that M-x set-variable recognizes it.
+This means that M-x set-variable and M-x edit-options recognize it.
 Note: do not use `defconst' for user options in libraries that are not
 normally loaded, since it is useful for users to be able to specify
 their own values for such variables before loading the library.
 Since `defconst' unconditionally assigns the variable,
 UNGCPRO;
 if (!NILP (args = XCDR (args)))
 {
 Lisp_Object doc = XCAR (args);
+#if 0 /* FSFmacs */
+/* #### We should probably do this but it might be dangerous */
+if (purify_flag)
+	doc = Fpurecopy (doc);
 Fput (sym, Qvariable_documentation, doc);
+#else
+pure_put (sym, Qvariable_documentation, doc);
+#endif
 if (!NILP (args = XCDR (args)))
 	error ("too many arguments");
 }
 #ifdef I18N3
 if (!NILP (Vfile_domain))
-Fput (sym, Qvariable_domain, Vfile_domain);
+pure_put (sym, Qvariable_domain, Vfile_domain);
 #endif
 LOADHIST_ATTACH (sym);
 return sym;
 }
 Lisp_Object documentation = Fget (variable, Qvariable_documentation, Qnil);
 return
 ((INTP (documentation) && XINT (documentation) < 0) ||
-(STRINGP (documentation) &&
+((STRINGP (documentation)) &&
 (string_byte (XSTRING (documentation), 0) == '*')) ||
 /* If (STRING . INTEGER), a negative integer means a user variable. */
 (CONSP (documentation)
 && STRINGP (XCAR (documentation))
 return c.val;
 }
 c.val = (*func) (arg);
 if (threw) *threw = 0;
 catchlist = c.next;
-#ifdef ERROR_CHECK_TYPECHECK
-check_error_state_sanity ();
-#endif
 return c.val;
 }
 /* Unwind the specbind, catch, and handler stacks back to CATCH, and
 /* Unwind the specpdl stack, and then restore the proper set of
 handlers.  */
 unbind_to (catchlist->pdlcount, Qnil);
 handlerlist = catchlist->handlerlist;
 catchlist = catchlist->next;
-#ifdef ERROR_CHECK_TYPECHECK
-check_error_state_sanity ();
-#endif
 }
 while (! last_time);
 #else /* Actual XEmacs code */
 /* Unwind the specpdl stack */
 unbind_to (c->pdlcount, Qnil);
 catchlist = c->next;
-#ifdef ERROR_CHECK_TYPECHECK
-check_error_state_sanity ();
-#endif
 #endif
 gcprolist = c->gcpro;
 backtrace_list = c->backlist;
 lisp_eval_depth = c->lisp_eval_depth;
-#ifdef DEFEND_AGAINST_THROW_RECURSION
+#if 0 /* no longer used */
 throw_level = 0;
 #endif
 LONGJMP (c->jmp, 1);
 }
 static DOESNT_RETURN
 throw_or_bomb_out (Lisp_Object tag, Lisp_Object val, int bomb_out_p,
 		   Lisp_Object sig, Lisp_Object data)
 {
-#ifdef DEFEND_AGAINST_THROW_RECURSION
+#if 0
 /* die if we recurse more than is reasonable */
 if (++throw_level > 20)
 abort();
 #endif
 /************************************************************************/
 static Lisp_Object
 condition_bind_unwind (Lisp_Object loser)
 {
-Lisp_Cons *victim;
+struct Lisp_Cons *victim;
 /* ((handler-fun . handler-args) ... other handlers) */
 Lisp_Object tem = XCAR (loser);
 while (CONSP (tem))
 {
 }
 static Lisp_Object
 condition_case_unwind (Lisp_Object loser)
 {
-Lisp_Cons *victim;
+struct Lisp_Cons *victim;
 /* ((<unbound> . clauses) ... other handlers */
 victim = XCONS (XCAR (loser));
 free_cons (victim);
 ungcpro, restoring catchlist and condition_handlers are actually
 redundant since unbind_to now restores them.  But it looks funny not to
 have this code here, and it doesn't cost anything, so I'm leaving it.*/
 UNGCPRO;
 catchlist = c.next;
-#ifdef ERROR_CHECK_TYPECHECK
-check_error_state_sanity ();
-#endif
 Vcondition_handlers = XCDR (c.tag);
 return unbind_to (speccount, c.val);
 }
 if (!initialized)
 {
 /* who knows how much has been initialized?  Safest bet is
 just to bomb out immediately. */
-/* let's not use stderr_out() here, because that does a bunch of
-	 things that might not be safe yet. */
 fprintf (stderr, "Error before initialization is complete!\n");
 abort ();
 }
 if (gc_in_progress || in_display)
 signal_error (Lisp_Object sig, Lisp_Object data)
 {
 for (;;)
 Fsignal (sig, data);
 }
-#ifdef ERROR_CHECK_TYPECHECK
-void
+static Lisp_Object
-check_error_state_sanity (void)
+call_with_suspended_errors_1 (Lisp_Object opaque_arg)
 {
-struct catchtag *c;
+Lisp_Object val;
-int found_error_tag = 0;
+Lisp_Object *kludgy_args = (Lisp_Object *) get_opaque_ptr (opaque_arg);
+PRIMITIVE_FUNCALL (val, get_opaque_ptr (kludgy_args[0]),
-for (c = catchlist; c; c = c->next)
+		     kludgy_args + 2, XINT (kludgy_args[1]));
-{
+return val;
-if (EQ (c->tag, Qunbound_suspended_errors_tag))
+}
-	{
-	  found_error_tag = 1;
-	  break;
-	}
-}
-assert (found_error_tag || NILP (Vcurrent_error_state));
-}
-#endif
 static Lisp_Object
 restore_current_warning_class (Lisp_Object warning_class)
 {
 Vcurrent_warning_class = warning_class;
 static Lisp_Object
 restore_current_error_state (Lisp_Object error_state)
 {
 Vcurrent_error_state = error_state;
 return Qnil;
-}
-static Lisp_Object
-call_with_suspended_errors_1 (Lisp_Object opaque_arg)
-{
-Lisp_Object val;
-Lisp_Object *kludgy_args = (Lisp_Object *) get_opaque_ptr (opaque_arg);
-Lisp_Object no_error = kludgy_args[2];
-int speccount = specpdl_depth ();
-if (!EQ (Vcurrent_error_state, no_error))
-{
-record_unwind_protect (restore_current_error_state,
-			     Vcurrent_error_state);
-Vcurrent_error_state = no_error;
-}
-PRIMITIVE_FUNCALL (val, get_opaque_ptr (kludgy_args[0]),
-		     kludgy_args + 3, XINT (kludgy_args[1]));
-return unbind_to (speccount, val);
 }
 /* Many functions would like to do one of three things if an error
 occurs:
 			    Lisp_Object class, Error_behavior errb,
 			    int nargs, ...)
 {
 va_list vargs;
 int speccount;
-Lisp_Object kludgy_args[23];
+Lisp_Object kludgy_args[22];
-Lisp_Object *args = kludgy_args + 3;
+Lisp_Object *args = kludgy_args + 2;
 int i;
 Lisp_Object no_error;
 assert (SYMBOLP (class)); /* sanity-check */
 assert (!NILP (class));
 Lisp_Object val;
 PRIMITIVE_FUNCALL (val, fun, args, nargs);
 return val;
 }
-speccount = specpdl_depth ();
+speccount = specpdl_depth();
 if (NILP (class) || NILP (Vcurrent_warning_class))
 {
 /* If we're currently calling for no warnings, then make it so.
 	 If we're currently calling for warnings and we weren't
 	 previously, then set our warning class; otherwise, leave
 	 the existing one alone. */
 record_unwind_protect (restore_current_warning_class,
 			     Vcurrent_warning_class);
 Vcurrent_warning_class = class;
 }
+if (!EQ (Vcurrent_error_state, no_error))
+{
+record_unwind_protect (restore_current_error_state,
+			     Vcurrent_error_state);
+Vcurrent_error_state = no_error;
+}
 {
 int threw;
 Lisp_Object the_retval;
 Lisp_Object opaque1 = make_opaque_ptr (kludgy_args);
 struct gcpro gcpro1, gcpro2;
 GCPRO2 (opaque1, opaque2);
 kludgy_args[0] = opaque2;
 kludgy_args[1] = make_int (nargs);
-kludgy_args[2] = no_error;
 the_retval = internal_catch (Qunbound_suspended_errors_tag,
 				 call_with_suspended_errors_1,
 				 opaque1, &threw);
 free_opaque_ptr (opaque1);
 free_opaque_ptr (opaque2);
 is a single string, created using the arguments. */
 /* dump an error message; called like printf */
 DOESNT_RETURN
-error (const char *fmt, ...)
+error (CONST char *fmt, ...)
 {
 Lisp_Object obj;
 va_list args;
 va_start (args, fmt);
-obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
+obj = emacs_doprnt_string_va ((CONST Bufbyte *) GETTEXT (fmt), Qnil, -1,
 				args);
 va_end (args);
 /* Fsignal GC-protects its args */
 signal_error (Qerror, list1 (obj));
 }
 void
-maybe_error (Lisp_Object class, Error_behavior errb, const char *fmt, ...)
+maybe_error (Lisp_Object class, Error_behavior errb, CONST char *fmt, ...)
 {
 Lisp_Object obj;
 va_list args;
 /* Optimization: */
 if (ERRB_EQ (errb, ERROR_ME_NOT))
 return;
 va_start (args, fmt);
-obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
+obj = emacs_doprnt_string_va ((CONST Bufbyte *) GETTEXT (fmt), Qnil, -1,
 				args);
 va_end (args);
 /* Fsignal GC-protects its args */
 maybe_signal_error (Qerror, list1 (obj), class, errb);
 }
 Lisp_Object
-continuable_error (const char *fmt, ...)
+continuable_error (CONST char *fmt, ...)
 {
 Lisp_Object obj;
 va_list args;
 va_start (args, fmt);
-obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
+obj = emacs_doprnt_string_va ((CONST Bufbyte *) GETTEXT (fmt), Qnil, -1,
 				args);
 va_end (args);
 /* Fsignal GC-protects its args */
 return Fsignal (Qerror, list1 (obj));
 }
 Lisp_Object
 maybe_continuable_error (Lisp_Object class, Error_behavior errb,
-			 const char *fmt, ...)
+			 CONST char *fmt, ...)
 {
 Lisp_Object obj;
 va_list args;
 /* Optimization: */
 if (ERRB_EQ (errb, ERROR_ME_NOT))
 return Qnil;
 va_start (args, fmt);
-obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
+obj = emacs_doprnt_string_va ((CONST Bufbyte *) GETTEXT (fmt), Qnil, -1,
 				args);
 va_end (args);
 /* Fsignal GC-protects its args */
 return maybe_signal_continuable_error (Qerror, list1 (obj), class, errb);
 These functions signal an error of type Qerror, whose data
 is two objects, a string and a related Lisp object (usually the object
 where the error is occurring). */
 DOESNT_RETURN
-signal_simple_error (const char *reason, Lisp_Object frob)
+signal_simple_error (CONST char *reason, Lisp_Object frob)
 {
 signal_error (Qerror, list2 (build_translated_string (reason), frob));
 }
 void
-maybe_signal_simple_error (const char *reason, Lisp_Object frob,
+maybe_signal_simple_error (CONST char *reason, Lisp_Object frob,
 			   Lisp_Object class, Error_behavior errb)
 {
 /* Optimization: */
 if (ERRB_EQ (errb, ERROR_ME_NOT))
 return;
 maybe_signal_error (Qerror, list2 (build_translated_string (reason), frob),
 				     class, errb);
 }
 Lisp_Object
-signal_simple_continuable_error (const char *reason, Lisp_Object frob)
+signal_simple_continuable_error (CONST char *reason, Lisp_Object frob)
 {
 return Fsignal (Qerror, list2 (build_translated_string (reason), frob));
 }
 Lisp_Object
-maybe_signal_simple_continuable_error (const char *reason, Lisp_Object frob,
+maybe_signal_simple_continuable_error (CONST char *reason, Lisp_Object frob,
 				       Lisp_Object class, Error_behavior errb)
 {
 /* Optimization: */
 if (ERRB_EQ (errb, ERROR_ME_NOT))
 return Qnil;
 is a two objects, a string (created using the arguments) and a
 Lisp object.
 */
 DOESNT_RETURN
-error_with_frob (Lisp_Object frob, const char *fmt, ...)
+error_with_frob (Lisp_Object frob, CONST char *fmt, ...)
 {
 Lisp_Object obj;
 va_list args;
 va_start (args, fmt);
-obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
+obj = emacs_doprnt_string_va ((CONST Bufbyte *) GETTEXT (fmt), Qnil, -1,
 				args);
 va_end (args);
 /* Fsignal GC-protects its args */
 signal_error (Qerror, list2 (obj, frob));
 }
 void
 maybe_error_with_frob (Lisp_Object frob, Lisp_Object class,
-		       Error_behavior errb, const char *fmt, ...)
+		       Error_behavior errb, CONST char *fmt, ...)
 {
 Lisp_Object obj;
 va_list args;
 /* Optimization: */
 if (ERRB_EQ (errb, ERROR_ME_NOT))
 return;
 va_start (args, fmt);
-obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
+obj = emacs_doprnt_string_va ((CONST Bufbyte *) GETTEXT (fmt), Qnil, -1,
 				args);
 va_end (args);
 /* Fsignal GC-protects its args */
 maybe_signal_error (Qerror, list2 (obj, frob), class, errb);
 }
 Lisp_Object
-continuable_error_with_frob (Lisp_Object frob, const char *fmt, ...)
+continuable_error_with_frob (Lisp_Object frob, CONST char *fmt, ...)
 {
 Lisp_Object obj;
 va_list args;
 va_start (args, fmt);
-obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
+obj = emacs_doprnt_string_va ((CONST Bufbyte *) GETTEXT (fmt), Qnil, -1,
 				args);
 va_end (args);
 /* Fsignal GC-protects its args */
 return Fsignal (Qerror, list2 (obj, frob));
 }
 Lisp_Object
 maybe_continuable_error_with_frob (Lisp_Object frob, Lisp_Object class,
-				   Error_behavior errb, const char *fmt, ...)
+				   Error_behavior errb, CONST char *fmt, ...)
 {
 Lisp_Object obj;
 va_list args;
 /* Optimization: */
 if (ERRB_EQ (errb, ERROR_ME_NOT))
 return Qnil;
 va_start (args, fmt);
-obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
+obj = emacs_doprnt_string_va ((CONST Bufbyte *) GETTEXT (fmt), Qnil, -1,
 				args);
 va_end (args);
 /* Fsignal GC-protects its args */
 return maybe_signal_continuable_error (Qerror, list2 (obj, frob),
 /* Class 5: Signal an error with a string and two associated objects.
 These functions signal an error of type Qerror, whose data
 is three objects, a string and two related Lisp objects. */
 DOESNT_RETURN
-signal_simple_error_2 (const char *reason,
+signal_simple_error_2 (CONST char *reason,
 Lisp_Object frob0, Lisp_Object frob1)
 {
 signal_error (Qerror, list3 (build_translated_string (reason), frob0,
 			       frob1));
 }
 void
-maybe_signal_simple_error_2 (const char *reason, Lisp_Object frob0,
+maybe_signal_simple_error_2 (CONST char *reason, Lisp_Object frob0,
 			     Lisp_Object frob1, Lisp_Object class,
 			     Error_behavior errb)
 {
 /* Optimization: */
 if (ERRB_EQ (errb, ERROR_ME_NOT))
 				     frob1), class, errb);
 }
 Lisp_Object
-signal_simple_continuable_error_2 (const char *reason, Lisp_Object frob0,
+signal_simple_continuable_error_2 (CONST char *reason, Lisp_Object frob0,
 				   Lisp_Object frob1)
 {
 return Fsignal (Qerror, list3 (build_translated_string (reason), frob0,
 				 frob1));
 }
 Lisp_Object
-maybe_signal_simple_continuable_error_2 (const char *reason, Lisp_Object frob0,
+maybe_signal_simple_continuable_error_2 (CONST char *reason, Lisp_Object frob0,
 					 Lisp_Object frob1, Lisp_Object class,
 					 Error_behavior errb)
 {
 /* Optimization: */
 if (ERRB_EQ (errb, ERROR_ME_NOT))
 Fsignal (Qquit, Qnil);
 }
 /* Used in core lisp functions for efficiency */
-Lisp_Object
+void
 signal_void_function_error (Lisp_Object function)
 {
-return Fsignal (Qvoid_function, list1 (function));
+Fsignal (Qvoid_function, list1 (function));
 }
-Lisp_Object
+static void
 signal_invalid_function_error (Lisp_Object function)
 {
-return Fsignal (Qinvalid_function, list1 (function));
+Fsignal (Qinvalid_function, list1 (function));
 }
-Lisp_Object
+static void
 signal_wrong_number_of_arguments_error (Lisp_Object function, int nargs)
 {
-return Fsignal (Qwrong_number_of_arguments,
+Fsignal (Qwrong_number_of_arguments, list2 (function, make_int (nargs)));
-		  list2 (function, make_int (nargs)));
 }
 /* Used in list traversal macros for efficiency. */
-DOESNT_RETURN
+void
 signal_malformed_list_error (Lisp_Object list)
 {
-signal_error (Qmalformed_list, list1 (list));
+Fsignal (Qmalformed_list, list1 (list));
 }
-DOESNT_RETURN
+void
 signal_malformed_property_list_error (Lisp_Object list)
 {
-signal_error (Qmalformed_property_list, list1 (list));
+Fsignal (Qmalformed_property_list, list1 (list));
 }
-DOESNT_RETURN
+void
 signal_circular_list_error (Lisp_Object list)
 {
-signal_error (Qcircular_list, list1 (list));
+Fsignal (Qcircular_list, list1 (list));
 }
-DOESNT_RETURN
+void
 signal_circular_property_list_error (Lisp_Object list)
 {
-signal_error (Qcircular_property_list, list1 (list));
+Fsignal (Qcircular_property_list, list1 (list));
 }
 /************************************************************************/
 /*			      User commands				*/
 /************************************************************************/
 }
 else
 {
 Fsignal (Qwrong_type_argument,
 	       Fcons (Qcommandp,
-		      (EQ (cmd, final)
+		      ((EQ (cmd, final))
 ? list1 (cmd)
 : list2 (cmd, final))));
 return Qnil;
 }
 }
 {
 /* Attempt to avoid consing identical (string=) pure strings. */
 file = Fsymbol_name (Fintern (file, Qnil));
 }
-return Ffset (function, Fcons (Qautoload, list4 (file,
+return Ffset (function,
-						   docstring,
+Fpurecopy (Fcons (Qautoload, list4 (file,
-						   interactive,
+docstring,
-						   type)));
+interactive,
+type))));
 }
 Lisp_Object
 un_autoload (Lisp_Object oldqueue)
 {
 /************************************************************************/
 /*			   eval, funcall, apply				*/
 /************************************************************************/
 static Lisp_Object funcall_lambda (Lisp_Object fun,
-				   int nargs, Lisp_Object args[]);
+int nargs, Lisp_Object args[]);
 static int in_warnings;
 static Lisp_Object
 in_warnings_restore (Lisp_Object minimus)
 {
 	goto wrong_number_of_arguments;
 if (max_args == UNEVALLED) /* Optimize for the common case */
 	{
 	  backtrace.evalargs = 0;
-	  val = (((Lisp_Object (*) (Lisp_Object)) subr_function (subr))
+	  val = (((Lisp_Object (*) (Lisp_Object)) (subr_function (subr)))
 		 (original_args));
 	}
 else if (nargs <= max_args)
 {
 struct gcpro gcpro1;
 	  }
 	  backtrace.args  = args;
 	  backtrace.nargs = nargs;
-	  val = (((Lisp_Object (*) (int, Lisp_Object *)) subr_function (subr))
+	  val = (((Lisp_Object (*) (int, Lisp_Object *)) (subr_function (subr)))
 		 (nargs, args));
 	  UNGCPRO;
 	}
 else
 	{
 	wrong_number_of_arguments:
-	  val = signal_wrong_number_of_arguments_error (original_fun, nargs);
+	  signal_wrong_number_of_arguments_error (fun, nargs);
 	}
 }
 else if (COMPILED_FUNCTIONP (fun))
 {
 struct gcpro gcpro1;
 	}
 }
 else /* ! (SUBRP (fun) || COMPILED_FUNCTIONP (fun) || CONSP (fun)) */
 {
 invalid_function:
-val = signal_invalid_function_error (fun);
+signal_invalid_function_error (fun);
 }
 lisp_eval_depth--;
 if (backtrace.debug_on_exit)
 val = do_debug_on_exit (val);
 {
 Lisp_Subr *subr = XSUBR (fun);
 int max_args = subr->max_args;
 Lisp_Object spacious_args[SUBR_MAX_ARGS];
+if (fun_nargs < subr->min_args)
+	goto wrong_number_of_arguments;
 if (fun_nargs == max_args) /* Optimize for the common case */
 	{
 	funcall_subr:
 	  FUNCALL_SUBR (val, subr, fun_args, max_args);
 	}
-else if (fun_nargs < subr->min_args)
-	{
-	  goto wrong_number_of_arguments;
-	}
 else if (fun_nargs < max_args)
 	{
 	  Lisp_Object *p = spacious_args;
 /* Default optionals to nil */
 	  fun_args = spacious_args;
 	  goto funcall_subr;
 	}
 else if (max_args == MANY)
 	{
-	  val = SUBR_FUNCTION (subr, MANY) (fun_nargs, fun_args);
+	  val = ((Lisp_Object (*) (int, Lisp_Object *)) (subr_function (subr)))
+	    (fun_nargs, fun_args);
 	}
 else if (max_args == UNEVALLED) /* Can't funcall a special form */
 	{
 	  goto invalid_function;
 	}
 else
 	{
 	wrong_number_of_arguments:
-	  val = signal_wrong_number_of_arguments_error (fun, fun_nargs);
+	  signal_wrong_number_of_arguments_error (fun, fun_nargs);
 	}
 }
 else if (COMPILED_FUNCTIONP (fun))
 {
 val = funcall_compiled_function (fun, fun_nargs, fun_args);
 	  goto invalid_function;
 	}
 }
 else if (UNBOUNDP (fun))
 {
-val = signal_void_function_error (args[0]);
+signal_void_function_error (args[0]);
 }
 else
 {
 invalid_function:
-val = signal_invalid_function_error (fun);
+signal_invalid_function_error (fun);
 }
 lisp_eval_depth--;
 if (backtrace.debug_on_exit)
 val = do_debug_on_exit (val);
 if (SYMBOLP (function))
 function = indirect_function (function, 1);
 if (SUBRP (function))
 {
-/* Using return with the ?: operator tickles a DEC CC compiler bug. */
+return function_min_args_p ?
-if (function_min_args_p)
+	Fsubr_min_args (function):
-	return Fsubr_min_args (function);
+	Fsubr_max_args (function);
-else
-	return Fsubr_max_args (function);
 }
 else if (COMPILED_FUNCTIONP (function))
 {
 arglist = compiled_function_arglist (XCOMPILED_FUNCTION (function));
 }
 	}
 }
 else
 {
 invalid_function:
-return signal_invalid_function_error (function);
+return Fsignal (Qinvalid_function, list1 (function));
 }
 {
 int argcount = 0;
 Lisp_Object arg;
 goto wrong_number_of_arguments;
 return unbind_to (speccount, Fprogn (body));
 wrong_number_of_arguments:
-return signal_wrong_number_of_arguments_error (fun, nargs);
+return Fsignal (Qwrong_number_of_arguments, list2 (fun, make_int (nargs)));
 invalid_function:
-return signal_invalid_function_error (fun);
+return Fsignal (Qinvalid_function, list1 (fun));
 }
 /************************************************************************/
 /*		     Run hook variables in various ways.		*/
 args[0] = val;
 return Ffuncall (nargs, args);
 }
 else
 {
-struct gcpro gcpro1, gcpro2, gcpro3;
+struct gcpro gcpro1, gcpro2;
-Lisp_Object globals = Qnil;
+GCPRO2 (sym, val);
-GCPRO3 (sym, val, globals);
 for (;
 	   CONSP (val) && ((cond == RUN_HOOKS_TO_COMPLETION)
 			   || (cond == RUN_HOOKS_UNTIL_SUCCESS ? NILP (ret)
 			       : !NILP (ret)));
 	{
 	  if (EQ (XCAR (val), Qt))
 	    {
 	      /* t indicates this hook has a local binding;
 		 it means to run the global binding too.  */
-	      globals = Fdefault_value (sym);
+	      Lisp_Object globals = Fdefault_value (sym);
 	      if ((! CONSP (globals) || EQ (XCAR (globals), Qlambda)) &&
 		  ! NILP (globals))
 		{
 		  args[0] = globals;
 	 (with-output-to-string (display-error errordata))
 	 but that stuff is all in Lisp currently. */
 args[1] = errordata;
 warn_when_safe_lispobj
 	(Qerror, Qwarning,
-	 emacs_doprnt_string_lisp ((const Bufbyte *) "%s: %s",
+	 emacs_doprnt_string_lisp ((CONST Bufbyte *) "%s: %s",
 				   Qnil, -1, 2, args));
 }
 return Qunbound;
 }
 {
 return eval_in_buffer (XBUFFER (XCAR (cons)), XCDR (cons));
 }
 Lisp_Object
-eval_in_buffer_trapping_errors (const char *warning_string,
+eval_in_buffer_trapping_errors (CONST char *warning_string,
 				struct buffer *buf, Lisp_Object form)
 {
 int speccount = specpdl_depth();
 Lisp_Object tem;
 Lisp_Object buffer;
 specbind (Qinhibit_quit, Qt);
 /* gc_currently_forbidden = 1; Currently no reason to do this; */
 cons = noseeum_cons (buffer, form);
-opaque = (warning_string ? make_opaque_ptr ((void *)warning_string) : Qnil);
+opaque = (warning_string ? make_opaque_ptr (warning_string) : Qnil);
 GCPRO2 (cons, opaque);
 /* Qerror not Qt, so you can get a backtrace */
 tem = condition_case_1 (Qerror,
 catch_them_squirmers_eval_in_buffer, cons,
 			  caught_a_squirmer, opaque);
 free_cons (XCONS (cons));
-if (OPAQUE_PTRP (opaque))
+if (OPAQUEP (opaque))
 free_opaque_ptr (opaque);
 UNGCPRO;
 /* gc_currently_forbidden = 0; */
 return unbind_to (speccount, tem);
 run_hook (hook_symbol);
 return Qnil;
 }
 Lisp_Object
-run_hook_trapping_errors (const char *warning_string, Lisp_Object hook_symbol)
+run_hook_trapping_errors (CONST char *warning_string, Lisp_Object hook_symbol)
 {
 int speccount;
 Lisp_Object tem;
 Lisp_Object opaque;
 struct gcpro gcpro1;
 return Qnil;
 speccount = specpdl_depth();
 specbind (Qinhibit_quit, Qt);
-opaque = (warning_string ? make_opaque_ptr ((void *)warning_string) : Qnil);
+opaque = (warning_string ? make_opaque_ptr (warning_string) : Qnil);
 GCPRO1 (opaque);
 /* Qerror not Qt, so you can get a backtrace */
 tem = condition_case_1 (Qerror,
 catch_them_squirmers_run_hook, hook_symbol,
 caught_a_squirmer, opaque);
-if (OPAQUE_PTRP (opaque))
+if (OPAQUEP (opaque))
 free_opaque_ptr (opaque);
 UNGCPRO;
 return unbind_to (speccount, tem);
 }
 /* Same as run_hook_trapping_errors() but also set the hook to nil
 if an error occurs. */
 Lisp_Object
-safe_run_hook_trapping_errors (const char *warning_string,
+safe_run_hook_trapping_errors (CONST char *warning_string,
 			       Lisp_Object hook_symbol,
 			       int allow_quit)
 {
 int speccount = specpdl_depth();
 Lisp_Object tem;
 if (!allow_quit)
 specbind (Qinhibit_quit, Qt);
 cons = noseeum_cons (hook_symbol,
-		       warning_string ? make_opaque_ptr ((void *)warning_string)
+		       warning_string ? make_opaque_ptr (warning_string)
 		       : Qnil);
 GCPRO1 (cons);
 /* Qerror not Qt, so you can get a backtrace */
 tem = condition_case_1 (Qerror,
 catch_them_squirmers_run_hook,
 			  hook_symbol,
 			  allow_quit ?
 			  allow_quit_safe_run_hook_caught_a_squirmer :
 safe_run_hook_caught_a_squirmer,
 			  cons);
-if (OPAQUE_PTRP (XCDR (cons)))
+if (OPAQUEP (XCDR (cons)))
 free_opaque_ptr (XCDR (cons));
 free_cons (XCONS (cons));
 UNGCPRO;
 return unbind_to (speccount, tem);
 /* This function can GC */
 return call0 (function);
 }
 Lisp_Object
-call0_trapping_errors (const char *warning_string, Lisp_Object function)
+call0_trapping_errors (CONST char *warning_string, Lisp_Object function)
 {
 int speccount;
 Lisp_Object tem;
 Lisp_Object opaque = Qnil;
 struct gcpro gcpro1, gcpro2;
 GCPRO2 (opaque, function);
 speccount = specpdl_depth();
 specbind (Qinhibit_quit, Qt);
 /* gc_currently_forbidden = 1; Currently no reason to do this; */
-opaque = (warning_string ? make_opaque_ptr ((void *)warning_string) : Qnil);
+opaque = (warning_string ? make_opaque_ptr (warning_string) : Qnil);
 /* Qerror not Qt, so you can get a backtrace */
 tem = condition_case_1 (Qerror,
 catch_them_squirmers_call0, function,
 caught_a_squirmer, opaque);
-if (OPAQUE_PTRP (opaque))
+if (OPAQUEP (opaque))
 free_opaque_ptr (opaque);
 UNGCPRO;
 /* gc_currently_forbidden = 0; */
 return unbind_to (speccount, tem);
 /* This function can GC */
 return call2 (XCAR (cons), XCAR (XCDR (cons)), XCAR (XCDR (XCDR (cons))));
 }
 Lisp_Object
-call1_trapping_errors (const char *warning_string, Lisp_Object function,
+call1_trapping_errors (CONST char *warning_string, Lisp_Object function,
 		       Lisp_Object object)
 {
 int speccount = specpdl_depth();
 Lisp_Object tem;
 Lisp_Object cons = Qnil;
 specbind (Qinhibit_quit, Qt);
 /* gc_currently_forbidden = 1; Currently no reason to do this; */
 cons = noseeum_cons (function, object);
-opaque = (warning_string ? make_opaque_ptr ((void *)warning_string) : Qnil);
+opaque = (warning_string ? make_opaque_ptr (warning_string) : Qnil);
 /* Qerror not Qt, so you can get a backtrace */
 tem = condition_case_1 (Qerror,
 catch_them_squirmers_call1, cons,
 caught_a_squirmer, opaque);
-if (OPAQUE_PTRP (opaque))
+if (OPAQUEP (opaque))
 free_opaque_ptr (opaque);
 free_cons (XCONS (cons));
 UNGCPRO;
 /* gc_currently_forbidden = 0; */
 return unbind_to (speccount, tem);
 }
 Lisp_Object
-call2_trapping_errors (const char *warning_string, Lisp_Object function,
+call2_trapping_errors (CONST char *warning_string, Lisp_Object function,
 		       Lisp_Object object1, Lisp_Object object2)
 {
 int speccount = specpdl_depth();
 Lisp_Object tem;
 Lisp_Object cons = Qnil;
 GCPRO5 (cons, opaque, function, object1, object2);
 specbind (Qinhibit_quit, Qt);
 /* gc_currently_forbidden = 1; Currently no reason to do this; */
 cons = list3 (function, object1, object2);
-opaque = (warning_string ? make_opaque_ptr ((void *)warning_string) : Qnil);
+opaque = (warning_string ? make_opaque_ptr (warning_string) : Qnil);
 /* Qerror not Qt, so you can get a backtrace */
 tem = condition_case_1 (Qerror,
 catch_them_squirmers_call2, cons,
 caught_a_squirmer, opaque);
-if (OPAQUE_PTRP (opaque))
+if (OPAQUEP (opaque))
 free_opaque_ptr (opaque);
 free_list (cons);
 UNGCPRO;
 /* gc_currently_forbidden = 0; */
 static Lisp_Object
 specbind_unwind_local (Lisp_Object ovalue)
 {
 Lisp_Object current = Fcurrent_buffer ();
 Lisp_Object symbol = specpdl_ptr->symbol;
-Lisp_Cons *victim = XCONS (ovalue);
+struct Lisp_Cons *victim = XCONS (ovalue);
 Lisp_Object buf = get_buffer (victim->car, 0);
 ovalue = victim->cdr;
 free_cons (victim);
 void
 unbind_to_hairy (int count)
 {
 int quitf;
-++specpdl_ptr;
-++specpdl_depth_counter;
 check_quit (); /* make Vquit_flag accurate */
 quitf = !NILP (Vquit_flag);
 Vquit_flag = Qnil;
+++specpdl_ptr;
+++specpdl_depth_counter;
 while (specpdl_depth_counter != count)
 {
 --specpdl_ptr;
 --specpdl_depth_counter;
 	(*specpdl_ptr->func) (specpdl_ptr->old_value);
 else
 	{
 	  /* We checked symbol for validity when we specbound it,
 	     so only need to call Fset if symbol has magic value.  */
-	  Lisp_Symbol *sym = XSYMBOL (specpdl_ptr->symbol);
+	  struct Lisp_Symbol *sym = XSYMBOL (specpdl_ptr->symbol);
 	  if (!SYMBOL_VALUE_MAGIC_P (sym->value))
 	    sym->value = specpdl_ptr->old_value;
 	  else
 	    Fset (specpdl_ptr->symbol, specpdl_ptr->old_value);
 	}
 if (printing_bindings) write_c_string (")\n", stream);
 }
 DEFUN ("backtrace", Fbacktrace, 0, 2, "", /*
 Print a trace of Lisp function calls currently active.
-Optional arg STREAM specifies the output stream to send the backtrace to,
+Option arg STREAM specifies the output stream to send the backtrace to,
 and defaults to the value of `standard-output'.  Optional second arg
 DETAILED means show places where currently active variable bindings,
 catches, condition-cases, and unwind-protects were made as well as
 function calls.
 */
 for (;;)
 {
 if (!NILP (detailed) && catches && catches->backlist == backlist)
 	{
 int catchpdl = catches->pdlcount;
-if (speccount > catchpdl
+if (specpdl[catchpdl].func == condition_case_unwind
-	      && specpdl[catchpdl].func == condition_case_unwind)
+&& speccount > catchpdl)
 /* This is a condition-case catchpoint */
 catchpdl = catchpdl + 1;
 backtrace_specials (speccount, catchpdl, stream);
 		      }
 		      if (i != 0) write_c_string (" ", stream);
 		      Fprin1 (backlist->args[i], stream);
 		    }
 		}
-	      write_c_string (")\n", stream);
 	    }
+	  write_c_string (")\n", stream);
 	  backlist = backlist->next;
 	}
 }
 Vprint_level = old_level;
 print_readably = old_pr;
 An alternative approach is to just pass some non-string type of
 Lisp_Object to warn_when_safe_lispobj(); `prin1-to-string' will
 automatically be called when it is safe to do so. */
 void
-warn_when_safe (Lisp_Object class, Lisp_Object level, const char *fmt, ...)
+warn_when_safe (Lisp_Object class, Lisp_Object level, CONST char *fmt, ...)
 {
 Lisp_Object obj;
 va_list args;
 va_start (args, fmt);
-obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt),
+obj = emacs_doprnt_string_va ((CONST Bufbyte *) GETTEXT (fmt),
 				Qnil, -1, args);
 va_end (args);
 warn_when_safe_lispobj (class, level, obj);
 }
 /************************************************************************/
 void
 syms_of_eval (void)
 {
-INIT_LRECORD_IMPLEMENTATION (subr);
 defsymbol (&Qinhibit_quit, "inhibit-quit");
 defsymbol (&Qautoload, "autoload");
 defsymbol (&Qdebug_on_error, "debug-on-error");
 defsymbol (&Qstack_trace_on_error, "stack-trace-on-error");
 defsymbol (&Qdebug_on_signal, "debug-on-signal");
 lisp_eval_depth = 0;
 entering_debugger = 0;
 }
 void
-reinit_vars_of_eval (void)
-{
-preparing_for_armageddon = 0;
-in_warnings = 0;
-Qunbound_suspended_errors_tag = make_opaque_ptr (&Qunbound_suspended_errors_tag);
-staticpro_nodump (&Qunbound_suspended_errors_tag);
-specpdl_size = 50;
-specpdl = xnew_array (struct specbinding, specpdl_size);
-/* XEmacs change: increase these values. */
-max_specpdl_size = 3000;
-max_lisp_eval_depth = 500;
-#ifdef DEFEND_AGAINST_THROW_RECURSION
-throw_level = 0;
-#endif
-}
-void
 vars_of_eval (void)
 {
-reinit_vars_of_eval ();
 DEFVAR_INT ("max-specpdl-size", &max_specpdl_size /*
 Limit on number of Lisp variable bindings & unwind-protects before error.
 */ );
 DEFVAR_INT ("max-lisp-eval-depth", &max_lisp_eval_depth /*
 If due to `apply' or `funcall' entry, one arg, `lambda'.
 If due to `eval' entry, one arg, t.
 */ );
 Vdebugger = Qnil;
+preparing_for_armageddon = 0;
 staticpro (&Vpending_warnings);
 Vpending_warnings = Qnil;
-pdump_wire (&Vpending_warnings_tail);
+Vpending_warnings_tail = Qnil; /* no need to protect this */
-Vpending_warnings_tail = Qnil;
+in_warnings = 0;
 staticpro (&Vautoload_queue);
 Vautoload_queue = Qnil;
 staticpro (&Vcondition_handlers);
 Vcurrent_warning_class = Qnil;
 staticpro (&Vcurrent_error_state);
 Vcurrent_error_state = Qnil; /* errors as normal */
+Qunbound_suspended_errors_tag = make_opaque_long (0);
+staticpro (&Qunbound_suspended_errors_tag);
+specpdl_size = 50;
+specpdl_depth_counter = 0;
+specpdl = xnew_array (struct specbinding, specpdl_size);
+/* XEmacs change: increase these values. */
+max_specpdl_size = 3000;
+max_lisp_eval_depth = 500;
+#if 0 /* no longer used */
+throw_level = 0;
+#endif
 reinit_eval ();
 }

Mercurial > hg > xemacs-beta

comparison src/eval.c @ 412:697ef44129c6 r21-2-14