xemacs-beta: src/eval.c comparison

comparison src/eval.c @ 442:abe6d1db359e r21-2-36

Import from CVS: tag r21-2-36

author	cvs
date	Mon, 13 Aug 2007 11:35:02 +0200
parents	8de8e3f6228a
children	576fb035e263

comparison

equal deleted inserted replaced

-:72a7cfa4a488
+:abe6d1db359e
 /* Evaluator for XEmacs Lisp interpreter.
 Copyright (C) 1985-1987, 1992-1994 Free Software Foundation, Inc.
 Copyright (C) 1995 Sun Microsystems, Inc.
+Copyright (C) 2000 Ben Wing.
 This file is part of XEmacs.
 XEmacs is free software; you can redistribute it and/or modify it
 under the terms of the GNU General Public License as published by the
 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;
 in.
 */
 static Lisp_Object Vcondition_handlers;
-#if 0 /* no longer used */
+#define DEFEND_AGAINST_THROW_RECURSION
+#ifdef DEFEND_AGAINST_THROW_RECURSION
 /* Used for error catching purposes by throw_or_bomb_out */
 static int throw_level;
-#endif /* unused */
+#endif
+#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);
 { XD_DOC_STRING, offsetof (Lisp_Subr, doc) },
 { XD_END }
 };
 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("subr", subr,
-				     this_one_is_unmarkable, print_subr, 0, 0, 0,
+				     0, print_subr, 0, 0, 0,
 				     subr_description,
 				     Lisp_Subr);
 /************************************************************************/
 /*			 Entering the debugger				*/
 specbind (Qdebug_on_error,	Qnil);
 specbind (Qstack_trace_on_error,	Qnil);
 specbind (Qdebug_on_signal,	Qnil);
 specbind (Qstack_trace_on_signal, Qnil);
-internal_with_output_to_temp_buffer (build_string ("*Backtrace*"),
+if (!noninteractive)
-					   backtrace_259,
+	internal_with_output_to_temp_buffer (build_string ("*Backtrace*"),
-					   Qnil,
+					     backtrace_259,
-					   Qnil);
+					     Qnil,
+					     Qnil);
+else /* in batch mode, we want this going to stderr. */
+	backtrace_259 (Qnil);
 unbind_to (speccount, Qnil);
 *stack_trace_displayed = 1;
 }
 if (!entering_debugger && !*debugger_entered && !signal_vars_only
 specbind (Qdebug_on_error,	Qnil);
 specbind (Qstack_trace_on_error,	Qnil);
 specbind (Qdebug_on_signal,	Qnil);
 specbind (Qstack_trace_on_signal, Qnil);
-internal_with_output_to_temp_buffer (build_string ("*Backtrace*"),
+if (!noninteractive)
-					   backtrace_259,
+	internal_with_output_to_temp_buffer (build_string ("*Backtrace*"),
-					   Qnil,
+					     backtrace_259,
-					   Qnil);
+					     Qnil,
+					     Qnil);
+else /* in batch mode, we want this going to stderr. */
+	backtrace_259 (Qnil);
 unbind_to (speccount, Qnil);
 *stack_trace_displayed = 1;
 }
 if (!entering_debugger && !*debugger_entered
 If all args return nil, return nil.
 */
 (args))
 {
 /* This function can GC */
-REGISTER Lisp_Object arg, val;
+REGISTER Lisp_Object val;
 LIST_LOOP_2 (arg, args)
 {
 if (!NILP (val = Feval (arg)))
 	return val;
 If no arg yields nil, return the last arg's value.
 */
 (args))
 {
 /* This function can GC */
-REGISTER Lisp_Object arg, val = Qt;
+REGISTER Lisp_Object val = Qt;
 LIST_LOOP_2 (arg, args)
 {
 if (NILP (val = Feval (arg)))
 	return val;
 CONDITION's value if non-nil is returned from the cond-form.
 */
 (args))
 {
 /* This function can GC */
-REGISTER Lisp_Object val, clause;
+REGISTER Lisp_Object val;
 LIST_LOOP_2 (clause, args)
 {
 CHECK_CONS (clause);
 if (!NILP (val = Feval (XCAR (clause))))
 */
 (args))
 {
 /* This function can GC */
 /* Caller must provide a true list in ARGS */
-REGISTER Lisp_Object form, val = Qnil;
+REGISTER Lisp_Object val = Qnil;
 struct gcpro gcpro1;
 GCPRO1 (args);
 {
 whose values are discarded.
 */
 (args))
 {
 /* This function can GC */
-REGISTER Lisp_Object val, form;
+REGISTER Lisp_Object val;
 struct gcpro gcpro1;
 val = Feval (XCAR (args));
 GCPRO1 (val);
 whose values are discarded.
 */
 (args))
 {
 /* This function can GC */
-REGISTER Lisp_Object val, form, tail;
+REGISTER Lisp_Object val;
 struct gcpro gcpro1;
 Feval (XCAR (args));
 args = XCDR (args);
 val = Feval (XCAR (args));
 args = XCDR (args);
 GCPRO1 (val);
-LIST_LOOP_3 (form, args, tail)
+{
-Feval (form);
+LIST_LOOP_2 (form, args)
+Feval (form);
+}
 UNGCPRO;
 return val;
 }
 Each VALUEFORM can refer to the symbols already bound by this VARLIST.
 */
 (args))
 {
 /* This function can GC */
-Lisp_Object var, tail;
 Lisp_Object varlist = XCAR (args);
 Lisp_Object body    = XCDR (args);
 int speccount = specpdl_depth();
 EXTERNAL_LIST_LOOP_3 (var, varlist, tail)
 All the VALUEFORMs are evalled before any symbols are bound.
 */
 (args))
 {
 /* This function can GC */
-Lisp_Object var, tail;
 Lisp_Object varlist = XCAR (args);
 Lisp_Object body    = XCDR (args);
 int speccount = specpdl_depth();
 Lisp_Object *temps;
 int idx;
 /* Compute the values and store them in `temps' */
 GCPRO1 (*temps);
 gcpro1.nvars = 0;
 idx = 0;
-LIST_LOOP_3 (var, varlist, tail)
+{
-{
+LIST_LOOP_2 (var, varlist)
-Lisp_Object *value = &temps[idx++];
+{
-if (SYMBOLP (var))
+	Lisp_Object *value = &temps[idx++];
-	*value = Qnil;
+	if (SYMBOLP (var))
-else
+	  *value = Qnil;
-	{
+	else
-	  Lisp_Object tem;
+	  {
-	  CHECK_CONS (var);
+	    Lisp_Object tem;
-	  tem = XCDR (var);
+	    CHECK_CONS (var);
-	  if (NILP (tem))
+	    tem = XCDR (var);
-	    *value = Qnil;
+	    if (NILP (tem))
-	  else
+	      *value = Qnil;
-	    {
+	    else
-	      CHECK_CONS (tem);
+	      {
-	      *value = Feval (XCAR (tem));
+		CHECK_CONS (tem);
-	      gcpro1.nvars = idx;
+		*value = Feval (XCAR (tem));
+		gcpro1.nvars = idx;
-	      if (!NILP (XCDR (tem)))
-		signal_simple_error
+		if (!NILP (XCDR (tem)))
-		  ("`let' bindings can have only one value-form", var);
+		  signal_simple_error
-	    }
+		    ("`let' bindings can have only one value-form", var);
-	}
+	      }
-}
+	  }
+}
+}
 idx = 0;
-LIST_LOOP_3 (var, varlist, tail)
+{
-{
+LIST_LOOP_2 (var, varlist)
-specbind (SYMBOLP (var) ? var : XCAR (var), temps[idx++]);
+{
-}
+	specbind (SYMBOLP (var) ? var : XCAR (var), temps[idx++]);
+}
+}
 UNGCPRO;
 return unbind_to (speccount, Fprogn (body));
 }
 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 and M-x edit-options recognize it.
+This means that M-x set-variable recognizes it.
 If INITVALUE is missing, SYMBOL's value is not set.
 In lisp-interaction-mode defvar is treated as defconst.
 */
 (args))
 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 and M-x edit-options recognize it.
+This means that M-x set-variable recognizes 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,
 Return result of expanding macros at top level of FORM.
 If FORM is not a macro call, it is returned unchanged.
 Otherwise, the macro is expanded and the expansion is considered
 in place of FORM.  When a non-macro-call results, it is returned.
-The second optional arg ENVIRONMENT species an environment of macro
+The second optional arg ENVIRONMENT specifies an environment of macro
 definitions to shadow the loaded ones for use in file byte-compilation.
 */
-(form, env))
+(form, environment))
 {
 /* This function can GC */
 /* With cleanups from Hallvard Furuseth.  */
 REGISTER Lisp_Object expander, sym, def, tem;
 	 until we get a symbol that is not an alias.  */
 while (SYMBOLP (def))
 	{
 	  QUIT;
 	  sym = def;
-	  tem = Fassq (sym, env);
+	  tem = Fassq (sym, environment);
 	  if (NILP (tem))
 	    {
 	      def = XSYMBOL (sym)->function;
 	      if (!UNBOUNDP (def))
 		continue;
 	    }
 	  break;
 	}
-/* Right now TEM is the result from SYM in ENV,
+/* Right now TEM is the result from SYM in ENVIRONMENT,
 	 and if TEM is nil then DEF is SYM's function definition.  */
 if (NILP (tem))
 	{
-	  /* SYM is not mentioned in ENV.
+	  /* SYM is not mentioned in ENVIRONMENT.
 	     Look at its function definition.  */
 	  if (UNBOUNDP (def)
 	      || !CONSP (def))
 	    /* Not defined or definition not suitable */
 	    break;
 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;
-#if 0 /* no longer used */
+#ifdef DEFEND_AGAINST_THROW_RECURSION
 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)
 {
-#if 0
+#ifdef DEFEND_AGAINST_THROW_RECURSION
 /* die if we recurse more than is reasonable */
 if (++throw_level > 20)
 abort();
 #endif
 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);
 }
 than a single list of arguments. */
 Lisp_Object
 condition_case_3 (Lisp_Object bodyform, Lisp_Object var, Lisp_Object handlers)
 {
 /* This function can GC */
-Lisp_Object handler;
 EXTERNAL_LIST_LOOP_2 (handler, handlers)
 {
 if (NILP (handler))
 	;
 else if (CONSP (handler))
 	  /* CONDITIONS must a condition name or a list of condition names */
 	  if (SYMBOLP (conditions))
 	    ;
 	  else
 	    {
-	      Lisp_Object condition;
 	      EXTERNAL_LIST_LOOP_2 (condition, conditions)
 		if (!SYMBOLP (condition))
 		  goto invalid_condition_handler;
 	    }
 	}
 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
+check_error_state_sanity (void)
+{
+struct catchtag *c;
+int found_error_tag = 0;
+for (c = catchlist; c; c = c->next)
+{
+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;
+return Qnil;
+}
+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 + 2, XINT (kludgy_args[1]));
+		     kludgy_args + 3, XINT (kludgy_args[1]));
-return val;
+return unbind_to (speccount, val);
-}
-static Lisp_Object
-restore_current_warning_class (Lisp_Object warning_class)
-{
-Vcurrent_warning_class = warning_class;
-return Qnil;
-}
-static Lisp_Object
-restore_current_error_state (Lisp_Object error_state)
-{
-Vcurrent_error_state = error_state;
-return Qnil;
 }
 /* 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[22];
+Lisp_Object kludgy_args[23];
-Lisp_Object *args = kludgy_args + 2;
+Lisp_Object *args = kludgy_args + 3;
 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);
 /****************** Error functions class 2 ******************/
 /* Class 2: Printf-like functions that signal an error.
-These functions signal an error of type Qerror, whose data
+These functions signal an error of a specified type, whose data
 is a single string, created using the arguments. */
 /* dump an error message; called like printf */
 DOESNT_RETURN
-error (CONST char *fmt, ...)
+type_error (Lisp_Object type, 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));
+signal_error (type, list1 (obj));
 }
 void
-maybe_error (Lisp_Object class, Error_behavior errb, CONST char *fmt, ...)
+maybe_type_error (Lisp_Object type, 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);
+maybe_signal_error (type, list1 (obj), class, errb);
 }
 Lisp_Object
-continuable_error (CONST char *fmt, ...)
+continuable_type_error (Lisp_Object type, 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));
+return Fsignal (type, list1 (obj));
 }
 Lisp_Object
-maybe_continuable_error (Lisp_Object class, Error_behavior errb,
+maybe_continuable_type_error (Lisp_Object type, Lisp_Object class,
-			 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, list1 (obj), class, errb);
+return maybe_signal_continuable_error (type, list1 (obj), class, errb);
 }
 /****************** Error functions class 3 ******************/
 /* Class 3: Signal an error with a string and an associated object.
+These functions signal an error of a specified type, whose data
+is two objects, a string and a related Lisp object (usually the object
+where the error is occurring). */
+DOESNT_RETURN
+signal_type_error (Lisp_Object type, const char *reason, Lisp_Object frob)
+{
+if (UNBOUNDP (frob))
+signal_error (type, list1 (build_translated_string (reason)));
+else
+signal_error (type, list2 (build_translated_string (reason), frob));
+}
+void
+maybe_signal_type_error (Lisp_Object type, const char *reason,
+			 Lisp_Object frob, Lisp_Object class,
+			 Error_behavior errb)
+{
+/* Optimization: */
+if (ERRB_EQ (errb, ERROR_ME_NOT))
+return;
+maybe_signal_error (type, list2 (build_translated_string (reason), frob),
+				     class, errb);
+}
+Lisp_Object
+signal_type_continuable_error (Lisp_Object type, const char *reason,
+			       Lisp_Object frob)
+{
+return Fsignal (type, list2 (build_translated_string (reason), frob));
+}
+Lisp_Object
+maybe_signal_type_continuable_error (Lisp_Object type, const char *reason,
+				     Lisp_Object frob, Lisp_Object class,
+				     Error_behavior errb)
+{
+/* Optimization: */
+if (ERRB_EQ (errb, ERROR_ME_NOT))
+return Qnil;
+return maybe_signal_continuable_error
+(type, list2 (build_translated_string (reason),
+		    frob), class, errb);
+}
+/****************** Error functions class 4 ******************/
+/* Class 4: Printf-like functions that signal an error.
+These functions signal an error of a specified type, whose data
+is a two objects, a string (created using the arguments) and a
+Lisp object.
+*/
+DOESNT_RETURN
+type_error_with_frob (Lisp_Object type, 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,
+				args);
+va_end (args);
+/* Fsignal GC-protects its args */
+signal_error (type, list2 (obj, frob));
+}
+void
+maybe_type_error_with_frob (Lisp_Object type, Lisp_Object frob,
+			    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,
+				args);
+va_end (args);
+/* Fsignal GC-protects its args */
+maybe_signal_error (type, list2 (obj, frob), class, errb);
+}
+Lisp_Object
+continuable_type_error_with_frob (Lisp_Object type, 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,
+				args);
+va_end (args);
+/* Fsignal GC-protects its args */
+return Fsignal (type, list2 (obj, frob));
+}
+Lisp_Object
+maybe_continuable_type_error_with_frob (Lisp_Object type, Lisp_Object frob,
+					Lisp_Object class, 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,
+				args);
+va_end (args);
+/* Fsignal GC-protects its args */
+return maybe_signal_continuable_error (type, list2 (obj, frob),
+					 class, errb);
+}
+/****************** Error functions class 5 ******************/
+/* Class 5: Signal an error with a string and two associated objects.
+These functions signal an error of a specified type, whose data
+is three objects, a string and two related Lisp objects. */
+DOESNT_RETURN
+signal_type_error_2 (Lisp_Object type, const char *reason,
+		     Lisp_Object frob0, Lisp_Object frob1)
+{
+signal_error (type, list3 (build_translated_string (reason), frob0,
+			       frob1));
+}
+void
+maybe_signal_type_error_2 (Lisp_Object type, const char *reason,
+			   Lisp_Object frob0, Lisp_Object frob1,
+			   Lisp_Object class, Error_behavior errb)
+{
+/* Optimization: */
+if (ERRB_EQ (errb, ERROR_ME_NOT))
+return;
+maybe_signal_error (type, list3 (build_translated_string (reason), frob0,
+				     frob1), class, errb);
+}
+Lisp_Object
+signal_type_continuable_error_2 (Lisp_Object type, const char *reason,
+				 Lisp_Object frob0, Lisp_Object frob1)
+{
+return Fsignal (type, list3 (build_translated_string (reason), frob0,
+				 frob1));
+}
+Lisp_Object
+maybe_signal_type_continuable_error_2 (Lisp_Object type, const char *reason,
+				       Lisp_Object frob0, Lisp_Object frob1,
+				       Lisp_Object class, Error_behavior errb)
+{
+/* Optimization: */
+if (ERRB_EQ (errb, ERROR_ME_NOT))
+return Qnil;
+return maybe_signal_continuable_error
+(type, list3 (build_translated_string (reason), frob0,
+		    frob1),
+class, errb);
+}
+/****************** Simple error functions class 2 ******************/
+/* Simple class 2: Printf-like functions that signal an error.
+These functions signal an error of type Qerror, whose data
+is a single string, created using the arguments. */
+/* dump an error message; called like printf */
+DOESNT_RETURN
+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,
+				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, ...)
+{
+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,
+				args);
+va_end (args);
+/* Fsignal GC-protects its args */
+maybe_signal_error (Qerror, list1 (obj), class, errb);
+}
+Lisp_Object
+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,
+				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, ...)
+{
+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,
+				args);
+va_end (args);
+/* Fsignal GC-protects its args */
+return maybe_signal_continuable_error (Qerror, list1 (obj), class, errb);
+}
+/****************** Simple error functions class 3 ******************/
+/* Simple class 3: Signal an error with a string and an associated object.
 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;
 (Qerror, list2 (build_translated_string (reason),
 		    frob), class, errb);
 }
-/****************** Error functions class 4 ******************/
+/****************** Simple error functions class 4 ******************/
-/* Class 4: Printf-like functions that signal an error.
+/* Simple class 4: Printf-like functions that signal an error.
 These functions signal an error of type Qerror, whose data
 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, errb);
 }
-/****************** Error functions class 5 ******************/
+/****************** Simple error functions class 5 ******************/
-/* Class 5: Signal an error with a string and two associated objects.
+/* Simple 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))
 DOESNT_RETURN
 signal_circular_property_list_error (Lisp_Object list)
 {
 signal_error (Qcircular_property_list, list1 (list));
 }
+DOESNT_RETURN
+syntax_error (const char *reason, Lisp_Object frob)
+{
+signal_type_error (Qsyntax_error, reason, frob);
+}
+DOESNT_RETURN
+syntax_error_2 (const char *reason, Lisp_Object frob1, Lisp_Object frob2)
+{
+signal_type_error_2 (Qsyntax_error, reason, frob1, frob2);
+}
+DOESNT_RETURN
+invalid_argument (const char *reason, Lisp_Object frob)
+{
+signal_type_error (Qinvalid_argument, reason, frob);
+}
+DOESNT_RETURN
+invalid_argument_2 (const char *reason, Lisp_Object frob1, Lisp_Object frob2)
+{
+signal_type_error_2 (Qinvalid_argument, reason, frob1, frob2);
+}
+DOESNT_RETURN
+invalid_operation (const char *reason, Lisp_Object frob)
+{
+signal_type_error (Qinvalid_operation, reason, frob);
+}
+DOESNT_RETURN
+invalid_operation_2 (const char *reason, Lisp_Object frob1, Lisp_Object frob2)
+{
+signal_type_error_2 (Qinvalid_operation, reason, frob1, frob2);
+}
+DOESNT_RETURN
+invalid_change (const char *reason, Lisp_Object frob)
+{
+signal_type_error (Qinvalid_change, reason, frob);
+}
+DOESNT_RETURN
+invalid_change_2 (const char *reason, Lisp_Object frob1, Lisp_Object frob2)
+{
+signal_type_error_2 (Qinvalid_change, reason, frob1, frob2);
+}
 /************************************************************************/
 /*			      User commands				*/
 /************************************************************************/
 /************************************************************************/
 /*			   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)
 {
 	  GCPRO1 (args[0]);
 	  gcpro1.nvars = 0;
 	  {
-	    REGISTER Lisp_Object arg;
 	    LIST_LOOP_2 (arg, original_args)
 	      {
 		*p++ = Feval (arg);
 		gcpro1.nvars++;
 	      }
 	  GCPRO1 (args[0]);
 	  gcpro1.nvars = 0;
 	  {
-	    REGISTER Lisp_Object arg;
 	    LIST_LOOP_2 (arg, original_args)
 	      {
 		*p++ = Feval (arg);
 		gcpro1.nvars++;
 	      }
 GCPRO1 (args[0]);
 gcpro1.nvars = 0;
 {
-	REGISTER Lisp_Object arg;
 	LIST_LOOP_2 (arg, original_args)
 	  {
 	    *p++ = Feval (arg);
 	    gcpro1.nvars++;
 	  }
 	  GCPRO1 (args[0]);
 	  gcpro1.nvars = 0;
 	  {
-	    REGISTER Lisp_Object arg;
 	    LIST_LOOP_2 (arg, original_args)
 	      {
 		*p++ = Feval (arg);
 		gcpro1.nvars++;
 	      }
 if (SYMBOLP (function))
 function = indirect_function (function, 1);
 if (SUBRP (function))
 {
-return function_min_args_p ?
+/* Using return with the ?: operator tickles a DEC CC compiler bug. */
-	Fsubr_min_args (function):
+if (function_min_args_p)
-	Fsubr_max_args (function);
+	return Fsubr_min_args (function);
+else
+	return Fsubr_max_args (function);
 }
 else if (COMPILED_FUNCTIONP (function))
 {
 arglist = compiled_function_arglist (XCOMPILED_FUNCTION (function));
 }
 	  function = XCDR (function);
 	  goto retry;
 	}
 else if (EQ (funcar, Qautoload))
 	{
+	  struct gcpro gcpro1;
+	  GCPRO1 (function);
 	  do_autoload (function, orig_function);
+	  UNGCPRO;
+	  function = orig_function;
 	  goto retry;
 	}
 else if (EQ (funcar, Qlambda))
 	{
 	  arglist = Fcar (XCDR (function));
 	}
 }
 else
 {
 invalid_function:
-return signal_invalid_function_error (function);
+return signal_invalid_function_error (orig_function);
 }
 {
 int argcount = 0;
-Lisp_Object arg;
 EXTERNAL_LIST_LOOP_2 (arg, arglist)
 {
 	if (EQ (arg, Qand_optional))
 	  {
 static Lisp_Object
 funcall_lambda (Lisp_Object fun, int nargs, Lisp_Object args[])
 {
 /* This function can GC */
-Lisp_Object symbol, arglist, body, tail;
+Lisp_Object arglist, body, tail;
 int speccount = specpdl_depth();
 REGISTER int i = 0;
 tail = XCDR (fun);
 body    = XCDR (tail);
 {
 int optional = 0, rest = 0;
-EXTERNAL_LIST_LOOP_3 (symbol, arglist, tail)
+EXTERNAL_LIST_LOOP_2 (symbol, arglist)
 {
 	if (!SYMBOLP (symbol))
 	  goto invalid_function;
 	if (EQ (symbol, Qand_rest))
 	  rest = 1;
 	 (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;
 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;
 /* 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;
 /* 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;
 /* 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;
 /* 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;
 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;
 		      }
 		      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");
 specpdl_size = 50;
 specpdl = xnew_array (struct specbinding, specpdl_size);
 /* XEmacs change: increase these values. */
 max_specpdl_size = 3000;
-max_lisp_eval_depth = 500;
+max_lisp_eval_depth = 1000;
-#if 0 /* no longer used */
+#ifdef DEFEND_AGAINST_THROW_RECURSION
 throw_level = 0;
 #endif
 }
 void

Mercurial > hg > xemacs-beta

comparison src/eval.c @ 442:abe6d1db359e r21-2-36