xemacs-beta: src/eval.c comparison

comparison src/eval.c @ 5125:b5df3737028a ben-lisp-object

merge

author	Ben Wing <ben@xemacs.org>
date	Wed, 24 Feb 2010 01:58:04 -0600
parents	623d57b7fbe8 2ade80e8c640
children	2a462149bd6a

comparison

equal deleted inserted replaced

-:623d57b7fbe8
+:b5df3737028a
 /* Evaluator for XEmacs Lisp interpreter.
 Copyright (C) 1985-1987, 1992-1994 Free Software Foundation, Inc.
 Copyright (C) 1995 Sun Microsystems, Inc.
-Copyright (C) 2000, 2001, 2002, 2003, 2004 Ben Wing.
+Copyright (C) 2000, 2001, 2002, 2003, 2004, 2010 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
 static void
 print_subr (Lisp_Object obj, Lisp_Object printcharfun, int UNUSED (escapeflag))
 {
 Lisp_Subr *subr = XSUBR (obj);
-const CIbyte *header =
+const Ascbyte *header =
-(subr->max_args == UNEVALLED) ? "#<special-form " : "#<subr ";
+(subr->max_args == UNEVALLED) ? "#<special-operator " : "#<subr ";
-const CIbyte *name = subr_name (subr);
+const Ascbyte *name = subr_name (subr);
-const CIbyte *trailer = subr->prompt ? " (interactive)>" : ">";
+const Ascbyte *trailer = subr->prompt ? " (interactive)>" : ">";
 if (print_readably)
 printing_unreadable_object ("%s%s%s", header, name, trailer);
-write_c_string (printcharfun, header);
+write_ascstring (printcharfun, header);
-write_c_string (printcharfun, name);
+write_ascstring (printcharfun, name);
-write_c_string (printcharfun, trailer);
+write_ascstring (printcharfun, trailer);
 }
 static const struct memory_description subr_description[] = {
 { XD_DOC_STRING, offsetof (Lisp_Subr, doc), 0, { 0 }, XD_FLAG_NO_KKCC },
 { XD_END }
 specbind (Qstack_trace_on_error,	Qnil);
 specbind (Qdebug_on_signal,	Qnil);
 specbind (Qstack_trace_on_signal, Qnil);
 if (!noninteractive)
-	internal_with_output_to_temp_buffer (build_string ("*Backtrace*"),
+	internal_with_output_to_temp_buffer (build_ascstring ("*Backtrace*"),
 					     backtrace_259,
 					     Qnil,
 					     Qnil);
 else /* in batch mode, we want this going to stderr. */
 	backtrace_259 (Qnil);
 specbind (Qstack_trace_on_error,	Qnil);
 specbind (Qdebug_on_signal,	Qnil);
 specbind (Qstack_trace_on_signal, Qnil);
 if (!noninteractive)
-	internal_with_output_to_temp_buffer (build_string ("*Backtrace*"),
+	internal_with_output_to_temp_buffer (build_ascstring ("*Backtrace*"),
 					     backtrace_259,
 					     Qnil,
 					     Qnil);
 else /* in batch mode, we want this going to stderr. */
 	backtrace_259 (Qnil);
 /************************************************************************/
 /*		       The basic special forms				*/
 /************************************************************************/
-/* Except for Fprogn(), the basic special forms below are only called
+/* Except for Fprogn(), the basic special operators below are only called
 from interpreted code.  The byte compiler turns them into bytecodes. */
 DEFUN ("or", For, 0, UNEVALLED, 0, /*
 Eval ARGS until one of them yields non-nil, then return that value.
 The remaining ARGS are not evalled at all.
 else if (ERRB_EQ (errb, ERROR_ME_DEBUG_WARN))
 warn_when_safe_lispobj (class_, Qdebug, Fcons (sig, data));
 else if (ERRB_EQ (errb, ERROR_ME_WARN))
 warn_when_safe_lispobj (class_, Qwarning, Fcons (sig, data));
 else
-for (;;)
+signal_error_1 (sig, data);
-Fsignal (sig, data);
 }
 /* Signal a continuable error or display a warning or do nothing,
 according to ERRB. */
 /* Out of REASON and FROB, return a list of elements suitable for passing
 to signal_error_1(). */
 Lisp_Object
-build_error_data (const CIbyte *reason, Lisp_Object frob)
+build_error_data (const Ascbyte *reason, Lisp_Object frob)
 {
 if (EQ (frob, Qunbound))
 frob = Qnil;
 else if (CONSP (frob) && EQ (XCAR (frob), Qunbound))
 frob = XCDR (frob);
 else
 return Fcons (build_msg_string (reason), frob);
 }
 DOESNT_RETURN
-signal_error (Lisp_Object type, const CIbyte *reason, Lisp_Object frob)
+signal_error (Lisp_Object type, const Ascbyte *reason, Lisp_Object frob)
 {
 signal_error_1 (type, build_error_data (reason, frob));
 }
+/* NOTE NOTE NOTE: If you feel you need signal_ierror() or something
+similar when reason is a non-ASCII message, you're probably doing
+something wrong.  When you have an error message from an external
+source, you should put the error message as the first item in FROB and
+put a string in REASON indicating what you were doing when the error
+message occurred.  Use signal_error_2() for such a case. */
 void
-maybe_signal_error (Lisp_Object type, const CIbyte *reason,
+maybe_signal_error (Lisp_Object type, const Ascbyte *reason,
 		    Lisp_Object frob, Lisp_Object class_,
 		    Error_Behavior errb)
 {
 /* Optimization: */
 if (ERRB_EQ (errb, ERROR_ME_NOT))
 return;
 maybe_signal_error_1 (type, build_error_data (reason, frob), class_, errb);
 }
 Lisp_Object
-signal_continuable_error (Lisp_Object type, const CIbyte *reason,
+signal_continuable_error (Lisp_Object type, const Ascbyte *reason,
 			  Lisp_Object frob)
 {
 return Fsignal (type, build_error_data (reason, frob));
 }
 Lisp_Object
-maybe_signal_continuable_error (Lisp_Object type, const CIbyte *reason,
+maybe_signal_continuable_error (Lisp_Object type, const Ascbyte *reason,
 				Lisp_Object frob, Lisp_Object class_,
 				Error_Behavior errb)
 {
 /* Optimization: */
 if (ERRB_EQ (errb, ERROR_ME_NOT))
 is three objects, a string and two related Lisp objects.
 (The equivalent could be accomplished using the class 2 functions,
 but these are more convenient in this particular case.) */
 DOESNT_RETURN
-signal_error_2 (Lisp_Object type, const CIbyte *reason,
+signal_error_2 (Lisp_Object type, const Ascbyte *reason,
 		Lisp_Object frob0, Lisp_Object frob1)
 {
 signal_error_1 (type, list3 (build_msg_string (reason), frob0,
 			       frob1));
 }
 void
-maybe_signal_error_2 (Lisp_Object type, const CIbyte *reason,
+maybe_signal_error_2 (Lisp_Object type, const Ascbyte *reason,
 		      Lisp_Object frob0, Lisp_Object frob1,
 		      Lisp_Object class_, Error_Behavior errb)
 {
 /* Optimization: */
 if (ERRB_EQ (errb, ERROR_ME_NOT))
 maybe_signal_error_1 (type, list3 (build_msg_string (reason), frob0,
 				     frob1), class_, errb);
 }
 Lisp_Object
-signal_continuable_error_2 (Lisp_Object type, const CIbyte *reason,
+signal_continuable_error_2 (Lisp_Object type, const Ascbyte *reason,
 			    Lisp_Object frob0, Lisp_Object frob1)
 {
 return Fsignal (type, list3 (build_msg_string (reason), frob0,
 			       frob1));
 }
 Lisp_Object
-maybe_signal_continuable_error_2 (Lisp_Object type, const CIbyte *reason,
+maybe_signal_continuable_error_2 (Lisp_Object type, const Ascbyte *reason,
 				  Lisp_Object frob0, Lisp_Object frob1,
 				  Lisp_Object class_, Error_Behavior errb)
 {
 /* Optimization: */
 if (ERRB_EQ (errb, ERROR_ME_NOT))
 /* Class 4: Printf-like functions that signal an error.
 These functions signal an error of a specified type, whose data
 is a single string, created using the arguments. */
 DOESNT_RETURN
-signal_ferror (Lisp_Object type, const CIbyte *fmt, ...)
+signal_ferror (Lisp_Object type, const Ascbyte *fmt, ...)
 {
 Lisp_Object obj;
 va_list args;
 va_start (args, fmt);
-obj = emacs_vsprintf_string (CGETTEXT (fmt), args);
+obj = emacs_vsprintf_string (GETTEXT (fmt), args);
 va_end (args);
 /* Fsignal GC-protects its args */
 signal_error (type, 0, obj);
 }
 void
 maybe_signal_ferror (Lisp_Object type, Lisp_Object class_, Error_Behavior errb,
-		     const CIbyte *fmt, ...)
+		     const Ascbyte *fmt, ...)
 {
 Lisp_Object obj;
 va_list args;
 /* Optimization: */
 if (ERRB_EQ (errb, ERROR_ME_NOT))
 return;
 va_start (args, fmt);
-obj = emacs_vsprintf_string (CGETTEXT (fmt), args);
+obj = emacs_vsprintf_string (GETTEXT (fmt), args);
 va_end (args);
 /* Fsignal GC-protects its args */
 maybe_signal_error (type, 0, obj, class_, errb);
 }
 Lisp_Object
-signal_continuable_ferror (Lisp_Object type, const CIbyte *fmt, ...)
+signal_continuable_ferror (Lisp_Object type, const Ascbyte *fmt, ...)
 {
 Lisp_Object obj;
 va_list args;
 va_start (args, fmt);
-obj = emacs_vsprintf_string (CGETTEXT (fmt), args);
+obj = emacs_vsprintf_string (GETTEXT (fmt), args);
 va_end (args);
 /* Fsignal GC-protects its args */
 return Fsignal (type, list1 (obj));
 }
 Lisp_Object
 maybe_signal_continuable_ferror (Lisp_Object type, Lisp_Object class_,
-				 Error_Behavior errb, const CIbyte *fmt, ...)
+				 Error_Behavior errb, const Ascbyte *fmt, ...)
 {
 Lisp_Object obj;
 va_list args;
 /* Optimization: */
 if (ERRB_EQ (errb, ERROR_ME_NOT))
 return Qnil;
 va_start (args, fmt);
-obj = emacs_vsprintf_string (CGETTEXT (fmt), args);
+obj = emacs_vsprintf_string (GETTEXT (fmt), args);
 va_end (args);
 /* Fsignal GC-protects its args */
 return maybe_signal_continuable_error (type, 0, obj, class_, errb);
 }
 elements, the first of which is Qunbound), and these functions are
 not commonly used.
 */
 DOESNT_RETURN
-signal_ferror_with_frob (Lisp_Object type, Lisp_Object frob, const CIbyte *fmt,
+signal_ferror_with_frob (Lisp_Object type, Lisp_Object frob, const Ascbyte *fmt,
 			 ...)
 {
 Lisp_Object obj;
 va_list args;
 va_start (args, fmt);
-obj = emacs_vsprintf_string (CGETTEXT (fmt), args);
+obj = emacs_vsprintf_string (GETTEXT (fmt), args);
 va_end (args);
 /* Fsignal GC-protects its args */
 signal_error_1 (type, Fcons (obj, build_error_data (0, frob)));
 }
 void
 maybe_signal_ferror_with_frob (Lisp_Object type, Lisp_Object frob,
 			       Lisp_Object class_, Error_Behavior errb,
-			       const CIbyte *fmt, ...)
+			       const Ascbyte *fmt, ...)
 {
 Lisp_Object obj;
 va_list args;
 /* Optimization: */
 if (ERRB_EQ (errb, ERROR_ME_NOT))
 return;
 va_start (args, fmt);
-obj = emacs_vsprintf_string (CGETTEXT (fmt), args);
+obj = emacs_vsprintf_string (GETTEXT (fmt), args);
 va_end (args);
 /* Fsignal GC-protects its args */
 maybe_signal_error_1 (type, Fcons (obj, build_error_data (0, frob)), class_,
 			errb);
 }
 Lisp_Object
 signal_continuable_ferror_with_frob (Lisp_Object type, Lisp_Object frob,
-				     const CIbyte *fmt, ...)
+				     const Ascbyte *fmt, ...)
 {
 Lisp_Object obj;
 va_list args;
 va_start (args, fmt);
-obj = emacs_vsprintf_string (CGETTEXT (fmt), args);
+obj = emacs_vsprintf_string (GETTEXT (fmt), args);
 va_end (args);
 /* Fsignal GC-protects its args */
 return Fsignal (type, Fcons (obj, build_error_data (0, frob)));
 }
 Lisp_Object
 maybe_signal_continuable_ferror_with_frob (Lisp_Object type, Lisp_Object frob,
 					   Lisp_Object class_,
 					   Error_Behavior errb,
-					   const CIbyte *fmt, ...)
+					   const Ascbyte *fmt, ...)
 {
 Lisp_Object obj;
 va_list args;
 /* Optimization: */
 if (ERRB_EQ (errb, ERROR_ME_NOT))
 return Qnil;
 va_start (args, fmt);
-obj = emacs_vsprintf_string (CGETTEXT (fmt), args);
+obj = emacs_vsprintf_string (GETTEXT (fmt), args);
 va_end (args);
 /* Fsignal GC-protects its args */
 return maybe_signal_continuable_error_1 (type,
 					   Fcons (obj,
 signal_error (Qcircular_property_list, 0, list);
 }
 /* Called from within emacs_doprnt_1, so REASON is not formatted. */
 DOESNT_RETURN
-syntax_error (const CIbyte *reason, Lisp_Object frob)
+syntax_error (const Ascbyte *reason, Lisp_Object frob)
 {
 signal_error (Qsyntax_error, reason, frob);
 }
 DOESNT_RETURN
-syntax_error_2 (const CIbyte *reason, Lisp_Object frob1, Lisp_Object frob2)
+syntax_error_2 (const Ascbyte *reason, Lisp_Object frob1, Lisp_Object frob2)
 {
 signal_error_2 (Qsyntax_error, reason, frob1, frob2);
 }
 void
-maybe_syntax_error (const CIbyte *reason, Lisp_Object frob,
+maybe_syntax_error (const Ascbyte *reason, Lisp_Object frob,
 		    Lisp_Object class_, Error_Behavior errb)
 {
 maybe_signal_error (Qsyntax_error, reason, frob, class_, errb);
 }
 DOESNT_RETURN
-sferror (const CIbyte *reason, Lisp_Object frob)
+sferror (const Ascbyte *reason, Lisp_Object frob)
 {
 signal_error (Qstructure_formation_error, reason, frob);
 }
 DOESNT_RETURN
-sferror_2 (const CIbyte *reason, Lisp_Object frob1, Lisp_Object frob2)
+sferror_2 (const Ascbyte *reason, Lisp_Object frob1, Lisp_Object frob2)
 {
 signal_error_2 (Qstructure_formation_error, reason, frob1, frob2);
 }
 void
-maybe_sferror (const CIbyte *reason, Lisp_Object frob,
+maybe_sferror (const Ascbyte *reason, Lisp_Object frob,
 	       Lisp_Object class_, Error_Behavior errb)
 {
 maybe_signal_error (Qstructure_formation_error, reason, frob, class_, errb);
 }
 DOESNT_RETURN
-invalid_argument (const CIbyte *reason, Lisp_Object frob)
+invalid_argument (const Ascbyte *reason, Lisp_Object frob)
 {
 signal_error (Qinvalid_argument, reason, frob);
 }
 DOESNT_RETURN
-invalid_argument_2 (const CIbyte *reason, Lisp_Object frob1,
+invalid_argument_2 (const Ascbyte *reason, Lisp_Object frob1,
 		    Lisp_Object frob2)
 {
 signal_error_2 (Qinvalid_argument, reason, frob1, frob2);
 }
 void
-maybe_invalid_argument (const CIbyte *reason, Lisp_Object frob,
+maybe_invalid_argument (const Ascbyte *reason, Lisp_Object frob,
 			Lisp_Object class_, Error_Behavior errb)
 {
 maybe_signal_error (Qinvalid_argument, reason, frob, class_, errb);
 }
 DOESNT_RETURN
-invalid_constant (const CIbyte *reason, Lisp_Object frob)
+invalid_constant (const Ascbyte *reason, Lisp_Object frob)
 {
 signal_error (Qinvalid_constant, reason, frob);
 }
 DOESNT_RETURN
-invalid_constant_2 (const CIbyte *reason, Lisp_Object frob1,
+invalid_constant_2 (const Ascbyte *reason, Lisp_Object frob1,
 		    Lisp_Object frob2)
 {
 signal_error_2 (Qinvalid_constant, reason, frob1, frob2);
 }
 void
-maybe_invalid_constant (const CIbyte *reason, Lisp_Object frob,
+maybe_invalid_constant (const Ascbyte *reason, Lisp_Object frob,
 			Lisp_Object class_, Error_Behavior errb)
 {
 maybe_signal_error (Qinvalid_constant, reason, frob, class_, errb);
 }
 DOESNT_RETURN
-invalid_operation (const CIbyte *reason, Lisp_Object frob)
+invalid_operation (const Ascbyte *reason, Lisp_Object frob)
 {
 signal_error (Qinvalid_operation, reason, frob);
 }
 DOESNT_RETURN
-invalid_operation_2 (const CIbyte *reason, Lisp_Object frob1,
+invalid_operation_2 (const Ascbyte *reason, Lisp_Object frob1,
 		     Lisp_Object frob2)
 {
 signal_error_2 (Qinvalid_operation, reason, frob1, frob2);
 }
 void
-maybe_invalid_operation (const CIbyte *reason, Lisp_Object frob,
+maybe_invalid_operation (const Ascbyte *reason, Lisp_Object frob,
 			 Lisp_Object class_, Error_Behavior errb)
 {
 maybe_signal_error (Qinvalid_operation, reason, frob, class_, errb);
 }
 DOESNT_RETURN
-invalid_change (const CIbyte *reason, Lisp_Object frob)
+invalid_change (const Ascbyte *reason, Lisp_Object frob)
 {
 signal_error (Qinvalid_change, reason, frob);
 }
 DOESNT_RETURN
-invalid_change_2 (const CIbyte *reason, Lisp_Object frob1, Lisp_Object frob2)
+invalid_change_2 (const Ascbyte *reason, Lisp_Object frob1, Lisp_Object frob2)
 {
 signal_error_2 (Qinvalid_change, reason, frob1, frob2);
 }
 void
-maybe_invalid_change (const CIbyte *reason, Lisp_Object frob,
+maybe_invalid_change (const Ascbyte *reason, Lisp_Object frob,
 		      Lisp_Object class_, Error_Behavior errb)
 {
 maybe_signal_error (Qinvalid_change, reason, frob, class_, errb);
 }
 DOESNT_RETURN
-invalid_state (const CIbyte *reason, Lisp_Object frob)
+invalid_state (const Ascbyte *reason, Lisp_Object frob)
 {
 signal_error (Qinvalid_state, reason, frob);
 }
 DOESNT_RETURN
-invalid_state_2 (const CIbyte *reason, Lisp_Object frob1, Lisp_Object frob2)
+invalid_state_2 (const Ascbyte *reason, Lisp_Object frob1, Lisp_Object frob2)
 {
 signal_error_2 (Qinvalid_state, reason, frob1, frob2);
 }
 void
-maybe_invalid_state (const CIbyte *reason, Lisp_Object frob,
+maybe_invalid_state (const Ascbyte *reason, Lisp_Object frob,
 		     Lisp_Object class_, Error_Behavior errb)
 {
 maybe_signal_error (Qinvalid_state, reason, frob, class_, errb);
 }
 DOESNT_RETURN
-wtaerror (const CIbyte *reason, Lisp_Object frob)
+wtaerror (const Ascbyte *reason, Lisp_Object frob)
 {
 signal_error (Qwrong_type_argument, reason, frob);
 }
 DOESNT_RETURN
-stack_overflow (const CIbyte *reason, Lisp_Object frob)
+stack_overflow (const Ascbyte *reason, Lisp_Object frob)
 {
 signal_error (Qstack_overflow, reason, frob);
 }
 DOESNT_RETURN
-out_of_memory (const CIbyte *reason, Lisp_Object frob)
+out_of_memory (const Ascbyte *reason, Lisp_Object frob)
 {
 signal_error (Qout_of_memory, reason, frob);
-}
-DOESNT_RETURN
-printing_unreadable_object (const CIbyte *fmt, ...)
-{
-Lisp_Object obj;
-va_list args;
-va_start (args, fmt);
-obj = emacs_vsprintf_string (CGETTEXT (fmt), args);
-va_end (args);
-/* Fsignal GC-protects its args */
-signal_error (Qprinting_unreadable_object, 0, obj);
 }
 /************************************************************************/
 /*			      User commands				*/
 byte-compiled functions, we'll accept it for now.  */
 if (EQ (*btp->function, Qbyte_code))
 btp = btp->next;
 /* If this isn't a byte-compiled function, then we may now be
-looking at several frames for special forms.  Skip past them.  */
+looking at several frames for special operators.  Skip past them.  */
 while (btp &&
 	 btp->nargs == UNEVALLED)
 btp = btp->next;
 #else
 }
 {
 Lisp_Object value =
 execute_optimized_program ((Opbyte *) XOPAQUE_DATA (f->instructions),
+#ifdef ERROR_CHECK_BYTE_CODE
+				 XOPAQUE_SIZE (f->instructions) /
+				 sizeof (Opbyte),
+#endif
 				 f->stack_depth,
 				 XVECTOR_DATA (f->constants));
 /* The attempt to optimize this by only unbinding variables failed
 because using buffer-local variables as function parameters
 	{
 	  PROFILE_ENTER_FUNCTION ();
 	  val = SUBR_FUNCTION (subr, MANY) (fun_nargs, fun_args);
 	  PROFILE_EXIT_FUNCTION ();
 	}
-else if (max_args == UNEVALLED) /* Can't funcall a special form */
+else if (max_args == UNEVALLED) /* Can't funcall a special operator */
 	{
 /* Ugh, ugh, ugh. */
 if (EQ (fun, XSYMBOL_FUNCTION (Qthrow)))
 {
 args[0] = Qobsolete_throw;
 (object))
 {
 if (SYMBOLP (object))
 object = indirect_function (object, 0);
-if (COMPILED_FUNCTIONP (object) || SUBRP (object))
+if (COMPILED_FUNCTIONP (object)
+|| (SUBRP (object)
+	  && (XSUBR (object)->max_args != UNEVALLED)))
 return Qt;
 if (CONSP (object))
 {
 Lisp_Object car = XCAR (object);
 if (EQ (car, Qlambda))
 	return Qt;
 if (EQ (car, Qautoload)
-	  && NILP (Fcar_safe (Fcdr_safe (Fcdr_safe (Fcdr_safe (XCDR (object)))))))
+	  && NILP (Fcar_safe (Fcdr_safe(Fcdr_safe
+					(Fcdr_safe (XCDR (object)))))))
 	return Qt;
 }
 return Qnil;
 }
 }
 DEFUN ("function-min-args", Ffunction_min_args, 1, 1, 0, /*
 Return the minimum number of arguments a function may be called with.
 The function may be any form that can be passed to `funcall',
-any special form, or any macro.
+any special operator, or any macro.
 To check if a function can be called with a specified number of
 arguments, use `function-allows-args'.
 */
 (function))
 }
 DEFUN ("function-max-args", Ffunction_max_args, 1, 1, 0, /*
 Return the maximum number of arguments a function may be called with.
 The function may be any form that can be passed to `funcall',
-any special form, or any macro.
+any special operator, or any macro.
 If the function takes an arbitrary number of arguments or is
-a built-in special form, nil is returned.
+a built-in special operator, nil is returned.
 To check if a function can be called with a specified number of
 arguments, use `function-allows-args'.
 */
 (function))
 /* Multiple values.
 A multiple value object is returned by #'values if:
 -- The number of arguments to #'values is not one, and:
--- Some special form in the call stack is prepared to handle more than
+-- Some special operator in the call stack is prepared to handle more than
 one multiple value.
 The return value of #'values-list is analogous to that of #'values.
 Henry Baker, in https://eprints.kfupm.edu.sa/31898/1/31898.pdf ("CONS
 something not true for us. As far as I can tell, it also ignores the
 contexts where multiple-values need to be thrown, or maybe it thinks such
 objects should be converted to heap allocation at that point.
 The specific multiple values saved and returned depend on how many
-multiple-values special forms in the stack are interested in; for
+multiple-values special operators in the stack are interested in; for
 example, if #'multiple-value-call is somewhere in the call stack, all
 values passed to #'values will be saved and returned.  If an expansion of
 #'multiple-value-setq with 10 SYMS is the only part of the call stack
 interested in multiple values, then a maximum of ten multiple values will
 be saved and returned.
 printing_unreadable_object ("multiple values");
 }
 if (0 == count)
 {
-write_c_string (printcharfun, "#<zero-length multiple value>");
+write_msg_string (printcharfun, "#<zero-length multiple value>");
 }
 for (index = 0; index < count;)
 {
 if (index != 0 &&
 ++index;
 if (count > 1 && index < count)
 {
-write_c_string (printcharfun, " ;\n");
+write_ascstring (printcharfun, " ;\n");
 }
 }
 }
 static Lisp_Object
 {
 result = args[i];
 if (MULTIPLE_VALUEP (result))
 {
 Lisp_Object val;
-Elemcount i, count = XMULTIPLE_VALUE_COUNT (result);
+Elemcount j, count = XMULTIPLE_VALUE_COUNT (result);
-for (i = 0; i < count; i++)
+for (j = 0; j < count; j++)
 {
-val = multiple_value_aref (result, i);
+val = multiple_value_aref (result, j);
 assert (!UNBOUNDP (val));
 XSETCDR (list_offset, Fcons (val, Qnil));
 list_offset = XCDR (list_offset);
 }
 	  Lisp_Object errstr =
 	    emacs_sprintf_string_lisp
 	    ("%s: Attempt to throw outside of function:"
 	     "To catch `%s' with value `%s'\n\nBacktrace follows:\n\n%s",
 	     Qnil, 4,
-	     build_msg_string (warning_string ? warning_string : "error"),
+	     build_msg_cistring (warning_string ? warning_string : "error"),
 	     p->thrown_tag, p->thrown_value, p->backtrace);
 	  warn_when_safe_lispobj (Qerror, current_warning_level (), errstr);
 	}
 else if (p->caught_error && !EQ (p->error_conditions, Qquit))
 	{
 	     but that stuff is all in Lisp currently. */
 	  errstr =
 	    emacs_sprintf_string_lisp
 	    ("%s: (%s %s)\n\nBacktrace follows:\n\n%s",
 	     Qnil, 4,
-	     build_msg_string (warning_string ? warning_string : "error"),
+	     build_msg_cistring (warning_string ? warning_string : "error"),
 	     p->error_conditions, p->data, p->backtrace);
 	  warn_when_safe_lispobj (warning_class, current_warning_level (),
 				  errstr);
 	}
 }
 static Lisp_Object
 safe_run_hook_trapping_problems_1 (void *puta)
 {
-Lisp_Object hook = VOID_TO_LISP (puta);
+Lisp_Object hook = GET_LISP_FROM_VOID (puta);
 run_hook (hook);
 return Qnil;
 }
 GCPRO2 (hook_symbol, tem);
 tem = call_trapping_problems (Qerror, NULL,
 				flags | POSTPONE_WARNING_ISSUE,
 				&prob,
 				safe_run_hook_trapping_problems_1,
-				LISP_TO_VOID (hook_symbol));
+				STORE_LISP_IN_VOID (hook_symbol));
 {
 Lisp_Object hook_name = XSYMBOL_NAME (hook_symbol);
 Ibyte *hook_str = XSTRING_DATA (hook_name);
 Ibyte *err = alloca_ibytes (XSTRING_LENGTH (hook_name) + 100);
 }
 static Lisp_Object
 restore_lisp_object (Lisp_Object cons)
 {
-Lisp_Object opaque = XCAR (cons);
+Lisp_Object laddr = XCAR (cons);
-Lisp_Object *addr = (Lisp_Object *) get_opaque_ptr (opaque);
+Lisp_Object *addr = (Lisp_Object *) GET_VOID_FROM_LISP (laddr);
 *addr = XCDR (cons);
-free_opaque_ptr (opaque);
 free_cons (cons);
 return Qnil;
 }
 /* Establish an unwind-protect which will restore the Lisp_Object pointed to
 by ADDR with the value VAL. */
 static int
 record_unwind_protect_restoring_lisp_object (Lisp_Object *addr,
 					     Lisp_Object val)
 {
-Lisp_Object opaque = make_opaque_ptr (addr);
+/* We use a cons rather than a malloc()ed structure because we want the
+Lisp object to have garbage-collection protection */
+Lisp_Object laddr = STORE_VOID_IN_LISP (addr);
 return record_unwind_protect (restore_lisp_object,
-				noseeum_cons (opaque, val));
+				noseeum_cons (laddr, val));
 }
 /* Similar to specbind() but for any C variable whose value is a
 Lisp_Object.  Sets up an unwind-protect to restore the variable
 pointed to by ADDR to its existing value, and then changes its
 record_unwind_protect_restoring_lisp_object (addr, *addr);
 *addr = newval;
 return count;
 }
+struct restore_int
+{
+int *addr;
+int val;
+};
 static Lisp_Object
-restore_int (Lisp_Object cons)
+restore_int (Lisp_Object obj)
 {
-Lisp_Object opaque = XCAR (cons);
+struct restore_int *ri = (struct restore_int *) GET_VOID_FROM_LISP (obj);
-Lisp_Object lval = XCDR (cons);
+*(ri->addr) = ri->val;
-int *addr = (int *) get_opaque_ptr (opaque);
+xfree (ri);
-int val;
-/* In the event that a C integer will always fit in an Emacs int, we
-haven't ever stored a C integer as an opaque pointer. This #ifdef
-eliminates a warning on AMD 64, where EMACS_INT has 63 value bits and C
-integers have 32 value bits.  */
-#if INT_VALBITS < INTBITS
-if (INTP (lval))
-{
-val = XINT (lval);
-}
-else
-{
-val = (int) get_opaque_ptr (lval);
-free_opaque_ptr (lval);
-}
-#else /* !(INT_VALBITS < INTBITS) */
-val = XINT(lval);
-#endif /* INT_VALBITS < INTBITS */
-*addr = val;
-free_opaque_ptr (opaque);
-free_cons (cons);
 return Qnil;
 }
 /* Establish an unwind-protect which will restore the int pointed to
 by ADDR with the value VAL.  This function works correctly with
 all ints, even those that don't fit into a Lisp integer. */
 int
 record_unwind_protect_restoring_int (int *addr, int val)
 {
-Lisp_Object opaque = make_opaque_ptr (addr);
+struct restore_int *ri = xnew (struct restore_int);
-Lisp_Object lval;
+ri->addr = addr;
+ri->val = val;
-/* In the event that a C integer will always fit in an Emacs int, we don't
+return record_unwind_protect (restore_int, STORE_VOID_IN_LISP (ri));
-ever want to store a C integer as an opaque pointer. This #ifdef
-eliminates a warning on AMD 64, where EMACS_INT has 63 value bits and C
-integers have 32 value bits.  */
-#if INT_VALBITS <= INTBITS
-if (NUMBER_FITS_IN_AN_EMACS_INT (val))
-lval = make_int (val);
-else
-lval = make_opaque_ptr ((void *) val);
-#else /* !(INT_VALBITS < INTBITS) */
-lval = make_int (val);
-#endif /* INT_VALBITS <= INTBITS */
-return record_unwind_protect (restore_int, noseeum_cons (opaque, lval));
 }
 /* Similar to specbind() but for any C variable whose value is an int.
 Sets up an unwind-protect to restore the variable pointed to by
 ADDR to its existing value, and then changes its value to NEWVAL.
 }
 static Lisp_Object
 free_pointer (Lisp_Object opaque)
 {
-xfree (get_opaque_ptr (opaque), void *);
+void *ptr = GET_VOID_FROM_LISP (opaque);
-free_opaque_ptr (opaque);
+xfree (ptr);
 return Qnil;
 }
 /* Establish an unwind-protect which will free the specified block.
 */
 int
 record_unwind_protect_freeing (void *ptr)
 {
-Lisp_Object opaque = make_opaque_ptr (ptr);
+return record_unwind_protect (free_pointer, STORE_VOID_IN_LISP (ptr));
-return record_unwind_protect (free_pointer, opaque);
 }
 static Lisp_Object
 free_dynarr (Lisp_Object opaque)
 {
-Dynarr_free (get_opaque_ptr (opaque));
+Dynarr_free (GET_VOID_FROM_LISP (opaque));
-free_opaque_ptr (opaque);
 return Qnil;
 }
 int
 record_unwind_protect_freeing_dynarr (void *ptr)
 {
-Lisp_Object opaque = make_opaque_ptr (ptr);
+return record_unwind_protect (free_dynarr, STORE_VOID_IN_LISP (ptr));
-return record_unwind_protect (free_dynarr, opaque);
 }
 /* Unwind the stack till specpdl_depth() == COUNT.
 VALUE is not used, except that, purely as a convenience to the
 caller, it is protected from garbage-protection and returned. */
 {
 if (specpdl[speccount - 1].func == 0
 || specpdl[speccount - 1].func == specbind_unwind_local
 || specpdl[speccount - 1].func == specbind_unwind_wasnt_local)
 	{
-	  write_c_string (stream, !printing_bindings ? "  # bind (" : " ");
+	  write_ascstring (stream, !printing_bindings ? "  # bind (" : " ");
 	  Fprin1 (specpdl[speccount - 1].symbol, stream);
 	  printing_bindings = 1;
 	}
 else
 	{
-	  if (printing_bindings) write_c_string (stream, ")\n");
+	  if (printing_bindings) write_ascstring (stream, ")\n");
-	  write_c_string (stream, "  # (unwind-protect ...)\n");
+	  write_ascstring (stream, "  # (unwind-protect ...)\n");
 	  printing_bindings = 0;
 	}
 }
-if (printing_bindings) write_c_string (stream, ")\n");
+if (printing_bindings) write_ascstring (stream, ")\n");
 }
 static Lisp_Object
 backtrace_unevalled_args (Lisp_Object *args)
 {
 if (args)
 return *args;
 else
-return list1 (build_string ("[internal]"));
+return list1 (build_ascstring ("[internal]"));
 }
 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,
 backtrace_specials (speccount, catchpdl, stream);
 speccount = catches->pdlcount;
 if (catchpdl == speccount)
 	    {
-	      write_c_string (stream, "  # (catch ");
+	      write_ascstring (stream, "  # (catch ");
 	      Fprin1 (catches->tag, stream);
-	      write_c_string (stream, " ...)\n");
+	      write_ascstring (stream, " ...)\n");
 	    }
 else
 {
-write_c_string (stream, "  # (condition-case ... . ");
+write_ascstring (stream, "  # (condition-case ... . ");
 Fprin1 (Fcdr (Fcar (catches->tag)), stream);
-write_c_string (stream, ")\n");
+write_ascstring (stream, ")\n");
 }
 catches = catches->next;
 	}
 else if (!backlist)
 	break;
 	  if (!NILP (detailed) && backlist->pdlcount < speccount)
 	    {
 	      backtrace_specials (speccount, backlist->pdlcount, stream);
 	      speccount = backlist->pdlcount;
 	    }
-	  write_c_string (stream, backlist->debug_on_exit ? "* " : "  ");
+	  write_ascstring (stream, backlist->debug_on_exit ? "* " : "  ");
 	  if (backlist->nargs == UNEVALLED)
 	    {
 	      Fprin1 (Fcons (*backlist->function,
 			     backtrace_unevalled_args (backlist->args)),
 		      stream);
-	      write_c_string (stream, "\n"); /* from FSFmacs 19.30 */
+	      write_ascstring (stream, "\n"); /* from FSFmacs 19.30 */
 	    }
 	  else
 	    {
 	      Lisp_Object tem = *backlist->function;
 	      Fprin1 (tem, stream); /* This can QUIT */
-	      write_c_string (stream, "(");
+	      write_ascstring (stream, "(");
 	      if (backlist->nargs == MANY)
 		{
 		  int i;
 		  Lisp_Object tail = Qnil;
 		  struct gcpro ngcpro1;
 		  NGCPRO1 (tail);
 		  for (tail = *backlist->args, i = 0;
 		       !NILP (tail);
 		       tail = Fcdr (tail), i++)
 		    {
-		      if (i != 0) write_c_string (stream, " ");
+		      if (i != 0) write_ascstring (stream, " ");
 		      Fprin1 (Fcar (tail), stream);
 		    }
 		  NUNGCPRO;
 		}
 	      else
 		  int i;
 		  for (i = 0; i < backlist->nargs; i++)
 		    {
 		      if (!i && EQ (tem, Qbyte_code))
 			{
-			  write_c_string (stream, "\"...\"");
+			  write_ascstring (stream, "\"...\"");
 			  continue;
 			}
-		      if (i != 0) write_c_string (stream, " ");
+		      if (i != 0) write_ascstring (stream, " ");
 		      Fprin1 (backlist->args[i], stream);
 		    }
 		}
-	      write_c_string (stream, ")\n");
+	      write_ascstring (stream, ")\n");
 	    }
 	  backlist = backlist->next;
 	}
 }
 Vprint_level = old_level;
 }
 DEFUN ("backtrace-frame", Fbacktrace_frame, 1, 1, 0, /*
 Return the function and arguments NFRAMES up from current execution point.
-If that frame has not evaluated the arguments yet (or is a special form),
+If that frame has not evaluated the arguments yet (or involves a special
-the value is (nil FUNCTION ARG-FORMS...).
+operator), the value is (nil FUNCTION ARG-FORMS...).
 If that frame has evaluated its arguments and called its function already,
 the value is (t FUNCTION ARG-VALUES...).
 A &rest arg is represented as the tail of the list ARG-VALUES.
 FUNCTION is whatever was supplied as car of evaluated list,
 or a lambda expression for macro calls.
 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 CIbyte *fmt, ...)
+warn_when_safe (Lisp_Object class_, Lisp_Object level, const Ascbyte *fmt, ...)
 {
 Lisp_Object obj;
 va_list args;
 if (warning_will_be_discarded (level))
 return;
 va_start (args, fmt);
-obj = emacs_vsprintf_string (CGETTEXT (fmt), args);
+obj = emacs_vsprintf_string (GETTEXT (fmt), args);
 va_end (args);
 warn_when_safe_lispobj (class_, level, obj);
 }
 DEFVAR_CONST_INT ("multiple-values-limit", &Vmultiple_values_limit /*
 The exclusive upper bound on the number of multiple values.
 This applies to `values', `values-list', `multiple-value-bind' and related
-macros and special forms.
+macros and special operators.
 */);
 Vmultiple_values_limit = EMACS_INT_MAX > INT_MAX ? INT_MAX : EMACS_INT_MAX;
 staticpro (&Vcatch_everything_tag);
 Vcatch_everything_tag = make_opaque (OPAQUE_CLEAR, 0);

Mercurial > hg > xemacs-beta

comparison src/eval.c @ 5125:b5df3737028a ben-lisp-object